From 25a75df79ff1fbd528f33f0ea4998ea8960a883a Mon Sep 17 00:00:00 2001
From: pw <pw>
Date: Wed, 31 Oct 2001 13:16:38 +0000
Subject: [PATCH] Backout previous change for wrong use of symbol-macrolet as
 it broke the SPARC port.

---
 compiler/ir1tran.lisp   |  4 +--
 compiler/new-assem.lisp | 67 +++++++++++++++++++++++------------------
 2 files changed, 38 insertions(+), 33 deletions(-)

diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 474f623b2..d97246607 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.126 2001/10/28 14:35:57 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.127 2001/10/31 13:16:37 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2489,8 +2489,6 @@
 	    (def (second spec)))
 	(unless (symbolp name)
 	  (compiler-error "Symbol macro name is not a symbol: ~S." name))
-        (when (eq (info variable kind name) :special)
-          (compiler-error "Attempt to bind a special variable with SYMBOL-MACROLET: ~S." name))
 	(when (assoc name (res) :test #'eq)
 	  (compiler-warning "Repeated name in SYMBOL-MACROLET: ~S." name))
 	(res `(,name . (MACRO . ,def)))))
diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
index 3cebcacde..a7ca86b4b 100644
--- a/compiler/new-assem.lisp
+++ b/compiler/new-assem.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.28 2001/10/28 14:35:58 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.29 2001/10/31 13:16:38 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -49,7 +49,7 @@
 ;;;
 (defmacro def-assembler-params (&rest options)
   "Set up the assembler."
-  `(eval-when (:compile-toplevel :load-toplevel :execute)
+  `(eval-when (compile load eval)
      (setf (c:backend-assembler-params c:*target-backend*)
 	   (make-assem-params :backend c:*target-backend*
 			      ,@options))))
@@ -306,7 +306,7 @@
 
 ;;; WITHOUT-SCHEDULING -- interface.
 ;;;
-(defmacro without-scheduling ((&optional (segment (%%current-segment%%)))
+(defmacro without-scheduling ((&optional (segment '*current-segment*))
 			      &body body)
   "Execute BODY (as a progn) without scheduling any of the instructions
    generated inside it.  DO NOT throw or return-from out of it."
@@ -1304,29 +1304,29 @@
 
 ;;;; Interface to the rest of the compiler.
 
-;;; Macro %%CURRENT-SEGMENT%% -- internal.
+;;; *CURRENT-SEGMENT* -- internal.
 ;;;
-;;; Returns the current segment while assembling. Use ASSEMBLE to
-;;; change it.
+;;; The holds the current segment while assembling.  Use ASSEMBLE to change
+;;; it.
 ;;; 
-;;; Using a macro to access the underlying special variable
-;;; *CURRENT-SEGMENT* allows us to play scoping tricks in
-;;; DEFINE-INSTRUCTION to detect calls to the INST macro which aren't
-;;; inside the scope of an ASSEMBLE. 
-;;; 
-(defvar *current-segment* nil)
-(defmacro %%current-segment%% () '*current-segment*)
+(defvar *current-segment*)
 
-;;; Macro %%CURRENT-VOP%% -- internal.
+;;; *CURRENT-VOP* -- internal.
 ;;;
-;;; Just like %%CURRENT-SEGMENT%%, but holds the current vop.  Used only to keep
+;;; Just like *CURRENT-SEGMENT*, but holds the current vop.  Used only to keep
 ;;; track of which vops emit which insts.
 ;;; 
 (defvar *current-vop* nil)
-(defmacro %%current-vop%% () '*current-vop*)
 
 ;;; ASSEMBLE -- interface.
 ;;;
+;;; We also symbol-macrolet *current-segment* to a local holding the segment
+;;; so uses of *current-segment* inside the body don't have to keep
+;;; dereferencing the symbol.  Given that ASSEMBLE is the only interface to
+;;; *current-segment*, we don't have to worry about the special value becomming
+;;; out of sync with the lexical value.  Unless some bozo closes over it,
+;;; but nobody does anything like that...
+;;;
 (defmacro assemble ((&optional segment vop &key labels) &body body
 		    &environment env)
   "Execute BODY (as a progn) with SEGMENT as the current segment."
@@ -1348,14 +1348,18 @@
       (when (intersection labels inherited-labels)
 	(error "Duplicate nested labels: ~S"
 	       (intersection labels inherited-labels)))
-      `(let* ((,seg-var ,(or segment (%%current-segment%%)))
-              (,vop-var ,(or vop (%%current-vop%%)))
-              (*current-segment* ,seg-var)
-              (*current-vop* ,vop-var)
+      `(let* ((,seg-var ,(or segment '*current-segment*))
+	      (,vop-var ,(or vop '*current-vop*))
+	      ,@(when segment
+		  `((*current-segment* ,seg-var)))
+	      ,@(when vop
+		  `((*current-vop* ,vop-var)))
 	      ,@(mapcar #'(lambda (name)
 			    `(,name (gen-label)))
 			new-labels))
-        (symbol-macrolet (,@(when (or inherited-labels nested-labels)
+	 (symbol-macrolet ((*current-segment* ,seg-var)
+			   (*current-vop* ,vop-var)
+			   ,@(when (or inherited-labels nested-labels)
 			       `((..inherited-labels.. ,nested-labels))))
 	   ,@(mapcar #'(lambda (form)
 			 (if (label-name-p form)
@@ -1375,24 +1379,24 @@
 	  ((functionp inst)
 	   (funcall inst (cdr whole) env))
 	  (t
-	   `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
+	   `(,inst *current-segment* *current-vop* ,@args)))))
 
 ;;; EMIT-LABEL -- interface.
 ;;; 
 (defmacro emit-label (label)
   "Emit LABEL at this location in the current segment."
-  `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
+  `(%emit-label *current-segment* *current-vop* ,label))
 
 ;;; EMIT-POSTIT -- interface.
 ;;;
 (defmacro emit-postit (function)
-  `(%emit-postit (%%current-segment%%) ,function))
+  `(%emit-postit *current-segment* ,function))
 
 ;;; ALIGN -- interface.
 ;;; 
 (defmacro align (bits &optional (fill-byte 0))
   "Emit an alignment restriction to the current segment."
-  `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
+  `(emit-alignment *current-segment* *current-vop* ,bits ,fill-byte))
 
 ;;; LABEL-POSITION -- interface.
 ;;; 
@@ -1804,11 +1808,15 @@
 	       `((declare ,@decls)))
 	   (let ((,postits (segment-postits ,segment-name)))
 	     (setf (segment-postits ,segment-name) nil)
-             (macrolet ((%%current-segment%% ()
-                          (error "Can't use INST without an ASSEMBLE inside emitters.")))
+	     (symbol-macrolet
+		 ((*current-segment*
+		   (macrolet ((lose ()
+				(error "Can't use INST without an ASSEMBLE ~
+					inside emitters.")))
+		     (lose))))
 	       ,@emitter))
 	   (ext:undefined-value))
-        (eval-when (:compile-toplevel :load-toplevel :execute)
+	 (eval-when (compile load eval)
 	   (%define-instruction ,sym-name ',defun-name))
 	 ,@(extract-nths 1 'progn pdefs)
 	 ,@(when pdefs
@@ -1816,7 +1824,6 @@
 		',name
 		(append ,@(extract-nths 0 'list pdefs)))))))))
 
-
 ;;; DEFINE-INSTRUCTION-MACRO -- interface.
 ;;;
 (defmacro define-instruction-macro (name lambda-list &body body)
@@ -1826,7 +1833,7 @@
 	(body local-defs)
 	(lisp::parse-defmacro lambda-list whole body name 'instruction-macro
 			      :environment env)
-      `(eval-when (:compile-toplevel :load-toplevel :execute)
+      `(eval-when (compile load eval)
 	 (%define-instruction ,(symbol-name name)
 			      #'(lambda (,whole ,env)
 				  ,@local-defs
-- 
GitLab