From 78981d684ccc0f3e5d364c08aa9308d521d5f989 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 12 Jun 1992 05:39:09 +0000
Subject: [PATCH] Spiffed up the ASSEMBLE macro.  You can now tell it about
 labels defined in a nested use of ASSEMBLE and have variable scoped in the
 outside ASSEMBLE. Also, only bind *current-segment* and *current-vop* if they
 were supplied.

Added a :vop-var option to DEFINE-INSTRUCTION so you can use the assemble
(and inst) macro inside instruction emitters.

Fixed DEFINE-INSTRUCTION-MACRO to enter the expander under the symbol's
name instead of the symbol itself, because that is what we look for.
---
 compiler/new-assem.lisp | 126 ++++++++++++++++++++++++----------------
 1 file changed, 77 insertions(+), 49 deletions(-)

diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
index 6eaf533ae..9dea91b2c 100644
--- a/compiler/new-assem.lisp
+++ b/compiler/new-assem.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.2 1992/05/28 23:40:49 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.3 1992/06/12 05:39:09 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1148,22 +1148,40 @@
 ;;; out of sync with the lexical value.  Unless some bozo closes over it,
 ;;; but nobody does anything like that...
 ;;;
-(defmacro assemble ((&optional segment vop) &body body)
+(defmacro assemble ((&optional segment vop &key labels) &body body
+		    &environment env)
   "Execute BODY (as a progn) with SEGMENT as the current segment."
   (flet ((label-name-p (thing)
 	   (and thing (symbolp thing))))
-    (let ((seg-var (gensym "SEGMENT-"))
-	  (vop-var (gensym "VOP-"))
-	  (label-names (remove-if-not #'label-name-p body)))
+    (let* ((seg-var (gensym "SEGMENT-"))
+	   (vop-var (gensym "VOP-"))
+	   (visable-labels (remove-if-not #'label-name-p body))
+	   (inherited-labels
+	    (multiple-value-bind
+		(expansion expanded)
+		(macroexpand '..inherited-labels.. env)
+	      (if expanded expansion nil)))
+	   (new-labels (append labels
+			       (set-difference visable-labels
+					       inherited-labels)))
+	   (nested-labels (set-difference (append inherited-labels new-labels)
+					  visable-labels)))
+      (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)
+	      ,@(when segment
+		  `((*current-segment* ,seg-var)))
+	      ,@(when vop
+		  `((*current-vop* ,vop-var)))
 	      ,@(mapcar #'(lambda (name)
 			    `(,name (gen-label)))
-			label-names))
+			new-labels))
 	 (symbol-macrolet ((*current-segment* ,seg-var)
-			   (*current-vop* ,vop-var))
+			   (*current-vop* ,vop-var)
+			   ,@(when (or inherited-labels nested-labels)
+			       `((..inherited-labels.. ,nested-labels))))
 	   ,@(mapcar #'(lambda (form)
 			 (if (label-name-p form)
 			     `(emit-label ,form)
@@ -1418,9 +1436,9 @@
 	       (:big-endian forms))
 	   ',name)))))
 
-(defun grovel-lambda-list (lambda-list)
+(defun grovel-lambda-list (lambda-list vop-var)
   (let ((segment-name (car lambda-list))
-	(vop-var (gensym "VOP-")))
+	(vop-var (or vop-var (gensym "VOP-"))))
     (ext:collect ((new-lambda-list))
       (new-lambda-list segment-name)
       (new-lambda-list vop-var)
@@ -1485,6 +1503,7 @@
 (defmacro define-instruction (name lambda-list &rest options)
   (let* ((sym-name (symbol-name name))
 	 (defun-name (ext:symbolicate sym-name "-INST-EMITTER"))
+	 (vop-var nil)
 	 (postits (gensym "POSTITS-"))
 	 (emitter nil)
 	 (decls nil)
@@ -1493,42 +1512,46 @@
 	 (writes nil)
 	 (delay nil)
 	 (pinned nil))
+    (dolist (option-spec options)
+      (multiple-value-bind
+	  (option args)
+	  (if (consp option-spec)
+	      (values (car option-spec) (cdr option-spec))
+	      (values option-spec nil))
+	(case option
+	  (:emitter
+	   (when emitter
+	     (error "Can only specify one emitter per instruction."))
+	   (setf emitter args))
+	  (:declare
+	   (setf decls (append decls args)))
+	  (:attributes
+	   (setf attributes (append attributes args)))
+	  (:reads
+	   (when reads
+	     (error
+	      "Can only specify one reads expression per instruction."))
+	   (setf reads args))
+	  (:writes
+	   (when writes
+	     (error
+	      "Can only specify one writes expression per instruction."))
+	   (setf writes args))
+	  (:delay
+	   (when delay
+	     (error "Can only specify delay once per instruction."))
+	   (setf delay args))
+	  (:pinned
+	   (setf pinned t))
+	  (:vop-var
+	   (if vop-var
+	       (error "Can only specify :vop-var once.")
+	       (setf vop-var (car args))))
+	  (t
+	   (error "Unknown option: ~S" (car option))))))
     (multiple-value-bind
 	(new-lambda-list segment-name vop-name arg-reconstructor)
-	(grovel-lambda-list lambda-list)
-      (dolist (option-spec options)
-	(multiple-value-bind
-	    (option args)
-	    (if (consp option-spec)
-		(values (car option-spec) (cdr option-spec))
-		(values option-spec nil))
-	  (case option
-	    (:emitter
-	     (when emitter
-	       (error "Can only specify one emitter per instruction."))
-	     (setf emitter args))
-	    (:declare
-	     (setf decls (append decls args)))
-	    (:attributes
-	     (setf attributes (append attributes args)))
-	    (:reads
-	     (when reads
-	       (error
-		"Can only specify one reads expression per instruction."))
-	     (setf reads args))
-	    (:writes
-	     (when writes
-	       (error
-		"Can only specify one writes expression per instruction."))
-	     (setf writes args))
-	    (:delay
-	     (when delay
-	       (error "Can only specify delay once per instruction."))
-	     (setf delay args))
-	    (:pinned
-	     (setf pinned t))
-	    (t
-	     (error "Unknown option: ~S" (car option))))))
+	(grovel-lambda-list lambda-list vop-var)
       (push `(let ((hook (segment-inst-hook ,segment-name)))
 	       (when hook
 		 (funcall hook ,segment-name ,vop-name ,sym-name
@@ -1564,8 +1587,12 @@
 	       `((declare ,@decls)))
 	   (let ((,postits (segment-postits ,segment-name)))
 	     (setf (segment-postits ,segment-name) nil)
-	     (symbol-macrolet ((*current-segment* ,segment-name)
-			       (*current-vop* ,vop-name))
+	     (symbol-macrolet
+		 ((*current-segment*
+		   (macrolet ((lose ()
+				(error "Can't use INST without an ASSEMBLE ~
+					inside emitters.")))
+		     (lose))))
 	       ,@emitter))
 	   (ext:undefined-value))
 	 (eval-when (compile load eval)
@@ -1581,11 +1608,11 @@
 	(lisp::parse-defmacro lambda-list whole body name 'instruction-macro
 			      :environment env)
       `(eval-when (compile load eval)
-	 (%define-instruction ',name
+	 (%define-instruction ,(symbol-name name)
 			      #'(lambda (,whole ,env)
 				  ,@local-defs
 				  (block ,name
-				    ,@body)))))))
+				    ,body)))))))
 
 (defun %define-instruction (name defun)
   (setf (gethash name
@@ -1593,3 +1620,4 @@
 		  (c:backend-assembler-params c:*target-backend*)))
 	defun)
   name)
+
-- 
GitLab