X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=bd62c93c0b2499317c8f81a9f120dd960cae99df;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=307d76224d37b334e6ab3e26e27a0f5956793abe;hpb=204f2fa9771ad9e55718dc76205afec7d11b3011;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 307d762..bd62c93 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -42,25 +42,12 @@
 (declaim (list *current-path*))
 (defvar *current-path* nil)
 
-;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to
-;;; be interpreted rather than compiled. This inhibits source
-;;; tranformations and stuff.
-(defvar *converting-for-interpreter* nil)
-;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-
-;;; FIXME: This nastiness was one of my original motivations to start
-;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
-;;; be made not the default, and perhaps should be controlled by
-;;; DECLAIM instead of a variable like this. And whether or not this
-;;; kind of checking is on, declarations should be assertions to the
-;;; extent practical, and code which can't be compiled efficiently
-;;; while adhering to that principle should give warnings.
-(defvar *derive-function-types* t
-  #!+sb-doc
-  "(Caution: Soon, this might change its semantics somewhat, or even go away.)
-  If true, argument and result type information derived from compilation of
-  DEFUNs is used when compiling calls to that function. If false, only
-  information from FTYPE proclamations will be used.")
+(defvar *derive-function-types* nil
+  "Should the compiler assume that function types will never change,
+  so that it can use type information inferred from current definitions
+  to optimize code which uses those definitions? Setting this true
+  gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
+  the efficiency of stable code.")
 
 ;;;; namespace management utilities
 
@@ -382,7 +369,7 @@
 
 ;;; This function is called on freshly read forms to record the
 ;;; initial location of each form (and subform.) Form is the form to
-;;; find the paths in, and TLF-Num is the top-level form number of the
+;;; find the paths in, and TLF-NUM is the top-level form number of the
 ;;; truly top-level form.
 ;;;
 ;;; This gets a bit interesting when the source code is circular. This
@@ -430,8 +417,8 @@
 				`(block ,skip
 				   (catch 'ir1-error-abort
 				     (let ((*compiler-error-bailout*
-					    #'(lambda ()
-						(throw 'ir1-error-abort nil))))
+					    (lambda ()
+					      (throw 'ir1-error-abort nil))))
 				       ,@body
 				       (return-from ,skip nil)))
 				   (ir1-convert ,start ,cont ,proxy)))))
@@ -487,7 +474,7 @@
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf
-  ;; if necessary. If we are producing a fasl-file, make sure that
+  ;; if necessary. If we are producing a fasl file, make sure that
   ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
   ;; needs to be.
   (defun reference-constant (start cont value)
@@ -562,8 +549,9 @@
 	 (translator (info :function :ir1-convert fun))
 	 (cmacro (info :function :compiler-macro-function fun)))
     (cond (translator (funcall translator start cont form))
-	  ((and cmacro (not *converting-for-interpreter*)
-		(not (eq (info :function :inlinep fun) :notinline)))
+	  ((and cmacro
+		(not (eq (info :function :inlinep fun)
+			 :notinline)))
 	   (let ((res (careful-expand-macro cmacro form)))
 	     (if (eq res form)
 		 (ir1-convert-global-functoid-no-cmacro start cont form fun)
@@ -592,7 +580,8 @@
   (muffle-warning)
   (error "internal error -- no MUFFLE-WARNING restart"))
 
-;;; Trap errors during the macroexpansion.
+;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
+;;; errors which occur during the macroexpansion.
 (defun careful-expand-macro (fun form)
   (handler-bind (;; When cross-compiling, we can get style warnings
 		 ;; about e.g. undefined functions. An unhandled
@@ -708,32 +697,26 @@
 
 ;;; Convert a call to a global function. If not :NOTINLINE, then we do
 ;;; source transforms and try out any inline expansion. If there is no
-;;; expansion, but is :INLINE, then give an efficiency note (unless a known
-;;; function which will quite possibly be open-coded.)   Next, we go to
-;;; ok-combination conversion.
+;;; expansion, but is :INLINE, then give an efficiency note (unless a
+;;; known function which will quite possibly be open-coded.) Next, we
+;;; go to ok-combination conversion.
 (defun ir1-convert-srctran (start cont var form)
   (declare (type continuation start cont) (type global-var var))
   (let ((inlinep (when (defined-function-p var)
 		   (defined-function-inlinep var))))
-    (cond
-     ((eq inlinep :notinline)
-      (ir1-convert-combination start cont form var))
-     (*converting-for-interpreter*
-      (ir1-convert-combination-checking-type start cont form var))
-     (t
-      (let ((transform (info :function :source-transform (leaf-name var))))
-	(cond
-	 (transform
-	  (multiple-value-bind (result pass) (funcall transform form)
-	    (if pass
-		(ir1-convert-maybe-predicate start cont form var)
-		(ir1-convert start cont result))))
-	 (t
-	  (ir1-convert-maybe-predicate start cont form var))))))))
-
-;;; If the function has the Predicate attribute, and the CONT's DEST isn't
-;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
-;;; appears in a conditional context.
+    (if (eq inlinep :notinline)
+	(ir1-convert-combination start cont form var)
+	(let ((transform (info :function :source-transform (leaf-name var))))
+	  (if transform
+	      (multiple-value-bind (result pass) (funcall transform form)
+		(if pass
+		    (ir1-convert-maybe-predicate start cont form var)
+		    (ir1-convert start cont result)))
+	      (ir1-convert-maybe-predicate start cont form var))))))
+
+;;; If the function has the PREDICATE attribute, and the CONT's DEST
+;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
+;;; predicate always appears in a conditional context.
 ;;;
 ;;; If the function isn't a predicate, then we call
 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
@@ -1784,7 +1767,7 @@
 
     res))
 
-;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf.
+;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
 (defun ir1-convert-lambda (form &optional name)
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"
@@ -1987,11 +1970,11 @@
       (conts cont)
 
       (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
-	(mapc #'(lambda (segment start cont)
-		  (ir1-convert-progn-body start cont (rest segment)))
+	(mapc (lambda (segment start cont)
+		(ir1-convert-progn-body start cont (rest segment)))
 	      segments (starts) (conts))))))
 
-;;; Emit an Exit node without any value.
+;;; Emit an EXIT node without any value.
 (def-ir1-translator go ((tag) start cont)
   #!+sb-doc
   "Go Tag
@@ -2008,139 +1991,76 @@
 
 ;;;; translators for compiler-magic special forms
 
-;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1
-;;; convert method so that it can be shared by the special-case
-;;; top-level form processing code. We play with the dynamic
-;;; environment and eval stuff, then call Fun with a list of forms to
-;;; be processed at load time.
-;;;
-;;; Note: the EVAL situation is always ignored: this is conceptually a
-;;; compile-only implementation.
-;;;
-;;; We have to interact with the interpreter to ensure that the forms
-;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to
-;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1
-;;; conversion done by EVAL, or by conversion of the body for
-;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do
-;;; not* EVAL since some enclosing EVAL-WHEN already did.
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
+;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; so that they're never seen at this level.)
 ;;;
-;;; We know we are EVAL'ing for LOAD since we wouldn't get called
-;;; otherwise. If LOAD is a situation we call FUN on body. If we
-;;; aren't evaluating for LOAD, then we call FUN on NIL for the result
-;;; of the EVAL-WHEN.
-(defun do-eval-when-stuff (situations body fun)
-
-  (when (or (not (listp situations))
-	    (set-difference situations
-			    '(compile load eval
-			      :compile-toplevel :load-toplevel :execute)))
-    (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
-
-  (let ((deprecated-names (intersection situations '(compile load eval))))
-    (when deprecated-names
-      (style-warn "using deprecated EVAL-WHEN situation names ~S"
-		  deprecated-names)))
-
-  (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
-		       (not sb!eval::*already-evaled-this*)))
-	 (sb!eval::*already-evaled-this* t))
-    (when do-eval
-
-      ;; This is the natural way to do it.
-      #-(and sb-xc-host (or sbcl cmu))
-      (eval `(progn ,@body))
-
-      ;; This is a disgusting hack to work around bug IR1-3 when using
-      ;; SBCL (or CMU CL, for that matter) as a cross-compilation
-      ;; host. When we go from the cross-compiler (where we bound
-      ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which
-      ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL
-      ;; would go and execute nested EVAL-WHENs even when they're not
-      ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes
-      ;; the cross-compilation host to bind its own
-      ;; *ALREADY-EVALED-THIS* variable, so that the problem is
-      ;; suppressed.
-      ;;
-      ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if
-      ;; CMU CL doesn't fix the bug, then this hack can be made
-      ;; conditional on #+CMU.)
-      #+(and sb-xc-host (or sbcl cmu))
-      (let (#+sbcl (sb-eval::*already-evaled-this* t)
-	    #+cmu (common-lisp::*already-evaled-this* t))
-	(eval `(eval-when (:compile-toplevel :load-toplevel :execute)
-		 ,@body))))
-
-    (if (or (intersection '(:load-toplevel load) situations)
-	    (and *converting-for-interpreter*
-		 (intersection '(:execute eval) situations)))
-	(funcall fun body)
-	(funcall fun '(nil)))))
-
-(def-ir1-translator eval-when ((situations &rest body) start cont)
+;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
+;;; of non-top-level EVAL-WHENs is very simple:
+;;;   EVAL-WHEN forms cause compile-time evaluation only at top level.
+;;;   Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
+;;;   are ignored for non-top-level forms. For non-top-level forms, an
+;;;   eval-when specifying the :EXECUTE situation is treated as an
+;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
+;;;   form; otherwise, the forms in the body are ignored. 
+(def-ir1-translator eval-when ((situations &rest forms) start cont)
   #!+sb-doc
   "EVAL-WHEN (Situation*) Form*
-  Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
-  This is conceptually a compile-only implementation, so EVAL is a no-op."
-
-  ;; It's difficult to handle EVAL-WHENs completely correctly in the
-  ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly
-  ;; language..) Since we, the system implementors, control not only
-  ;; the cross-compiler but also the code that it processes, we can
-  ;; handle this either by making the cross-compiler smarter about
-  ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult
-  ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs
-  ;; can be generated by many macro expansions, it's not always easy
-  ;; to detect problems by skimming the source code, so we'll try to
-  ;; add some code here to help out.
-  ;;
-  ;; Nested EVAL-WHENs are tricky.
-  #+sb-xc-host
-  (labels ((contains-toplevel-eval-when-p (body-part)
-	     (and (consp body-part)
-		  (or (eq (first body-part) 'eval-when)
-		      (and (member (first body-part)
-				   '(locally macrolet progn symbol-macrolet))
-			   (some #'contains-toplevel-eval-when-p
-				 (rest body-part)))))))
-    (/show "testing for nested EVAL-WHENs" body)
-    (when (some #'contains-toplevel-eval-when-p body)
-      (compiler-style-warning "nested EVAL-WHENs in cross-compilation")))
-
-  (do-eval-when-stuff situations
-		      body
-		      (lambda (forms)
-			(ir1-convert-progn-body start cont forms))))
-
-;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any
-;;; arguments.
-(defun do-macrolet-stuff (definitions fun)
-  (declare (list definitions) (type function fun))
-  (let ((whole (gensym "WHOLE"))
-	(environment (gensym "ENVIRONMENT")))
-    (collect ((new-fenv))
-      (dolist (def definitions)
-	(let ((name (first def))
-	      (arglist (second def))
-	      (body (cddr def)))
-	  (unless (symbolp name)
-	    (compiler-error "The local macro name ~S is not a symbol." name))
-	  (when (< (length def) 2)
-	    (compiler-error
-	     "The list ~S is too short to be a legal local macro definition."
-	     name))
-	  (multiple-value-bind (body local-decs)
-	      (parse-defmacro arglist whole body name 'macrolet
-			      :environment environment)
-	    (new-fenv `(,(first def) macro .
-			,(coerce `(lambda (,whole ,environment)
-				    ,@local-decs (block ,name ,body))
-				 'function))))))
-
-      (let ((*lexenv* (make-lexenv :functions (new-fenv))))
-	(funcall fun))))
-
+  Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
+  :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+  (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
+    (declare (ignore ct lt))
+    (ir1-convert-progn-body start cont (and e forms)))
   (values))
 
+;;; common logic for MACROLET and SYMBOL-MACROLET
+;;;
+;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
+;;; in-lexenv representation, stuff the results into *LEXENV*, and
+;;; call FUN (with no arguments).
+(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
+				       definitionize-keyword
+				       definitions
+				       fun)
+  (declare (type function definitionize-fun fun))
+  (declare (type (member :variables :functions) definitionize-keyword))
+  (declare (type list definitions))
+  (unless (= (length definitions)
+             (length (remove-duplicates definitions :key #'first)))
+    (compiler-style-warning "duplicate definitions in ~S" definitions))
+  (let* ((processed-definitions (mapcar definitionize-fun definitions))
+         (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+    (funcall fun)))
+
+;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; call FUN (with no arguments).
+;;;
+;;; This is split off from the IR1 convert method so that it can be
+;;; shared by the special-case top-level MACROLET processing code.
+(defun funcall-in-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (list-of-length-at-least-p definition 2)
+       (compiler-error
+	"The list ~S is too short to be a legal local macro definition."
+	definition))
+     (destructuring-bind (name arglist &body body) definition
+       (unless (symbolp name)
+	 (compiler-error "The local macro name ~S is not a symbol." name))
+       (let ((whole (gensym "WHOLE"))
+	     (environment (gensym "ENVIRONMENT")))
+	 (multiple-value-bind (body local-decls)
+	     (parse-defmacro arglist whole body name 'macrolet
+			     :environment environment)
+	   `(,name macro .
+		   ,(compile nil
+			     `(lambda (,whole ,environment)
+				,@local-decls
+				(block ,name ,body))))))))
+   :functions
+   definitions
+   fun))
+
 (def-ir1-translator macrolet ((definitions &rest body) start cont)
   #!+sb-doc
   "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
@@ -2148,9 +2068,34 @@
   defined. Name is the local macro name, Lambda-List is the DEFMACRO style
   destructuring lambda list, and the Forms evaluate to the expansion. The
   Forms are evaluated in the null environment."
-  (do-macrolet-stuff definitions
-		     #'(lambda ()
-			 (ir1-convert-progn-body start cont body))))
+  (funcall-in-macrolet-lexenv definitions
+			      (lambda ()
+				(ir1-translate-locally body start cont))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (proper-list-of-length-p definition 2)
+       (compiler-error "malformed symbol/expansion pair: ~S" definition))
+     (destructuring-bind (name expansion) definition
+       (unless (symbolp name)
+         (compiler-error
+          "The local symbol macro name ~S is not a symbol."
+          name))
+       `(,name . (MACRO . ,expansion))))
+   :variables
+   definitions
+   fun))
+  
+(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+  #!+sb-doc
+  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+  Define the Names as symbol macros with the given Expansions. Within the
+  body, references to a Name will effectively be replaced with the Expansion."
+  (funcall-in-symbol-macrolet-lexenv
+   macrobindings
+   (lambda ()
+     (ir1-translate-locally body start cont))))
 
 ;;; not really a special form, but..
 (def-ir1-translator declare ((&rest stuff) start cont)
@@ -2174,9 +2119,6 @@
       (compiler-error "Lisp error during evaluation of info args:~%~A"
 		      condition))))
 
-;;; a hashtable that translates from primitive names to translation functions
-(defvar *primitive-translators* (make-hash-table :test 'eq))
-
 ;;; If there is a primitive translator, then we expand the call.
 ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
 ;;; argument is the template, the second is a list of the results of
@@ -2187,60 +2129,53 @@
 ;;; a fatal error during IR2 conversion.
 ;;;
 ;;; KLUDGE: It's confusing having multiple names floating around for
-;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be
-;;; possible to reimplement BYTE-BLT (the only use of
-;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive
-;;; translators altogether, so that there would be no distinction
-;;; between primitives and vops? Then we could call primitives vops,
-;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to
-;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906
-;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I
-;;; think BYTE-BLT could probably just become an inline function.
-(def-ir1-translator %primitive ((&whole form name &rest args) start cont)
-
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
+;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
+;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
+;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
+;;; VOP or %VOP.. -- WHN 2001-06-11
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
+(def-ir1-translator %primitive ((name &rest args) start cont)
   (unless (symbolp name)
     (compiler-error "The primitive name ~S is not a symbol." name))
 
-  (let* ((translator (gethash name *primitive-translators*)))
-    (if translator
-	(ir1-convert start cont (funcall translator (cdr form)))
-	(let* ((template (or (gethash name *backend-template-names*)
-			     (compiler-error
-			      "The primitive name ~A is not defined."
-			      name)))
-	       (required (length (template-arg-types template)))
-	       (info (template-info-arg-count template))
-	       (min (+ required info))
-	       (nargs (length args)))
-	  (if (template-more-args-type template)
-	      (when (< nargs min)
-		(compiler-error "Primitive ~A was called with ~R argument~:P, ~
-	    			 but wants at least ~R."
-				name
-				nargs
-				min))
-	      (unless (= nargs min)
-		(compiler-error "Primitive ~A was called with ~R argument~:P, ~
-				 but wants exactly ~R."
-				name
-				nargs
-				min)))
-
-	  (when (eq (template-result-types template) :conditional)
-	    (compiler-error
-	     "%PRIMITIVE was used with a conditional template."))
-
-	  (when (template-more-results-type template)
-	    (compiler-error
-	     "%PRIMITIVE was used with an unknown values template."))
-
-	  (ir1-convert start
-		       cont
-		      `(%%primitive ',template
-				    ',(eval-info-args
-				       (subseq args required min))
-				    ,@(subseq args 0 required)
-				    ,@(subseq args min)))))))
+  (let* ((template (or (gethash name *backend-template-names*)
+		       (compiler-error
+			"The primitive name ~A is not defined."
+			name)))
+	 (required (length (template-arg-types template)))
+	 (info (template-info-arg-count template))
+	 (min (+ required info))
+	 (nargs (length args)))
+    (if (template-more-args-type template)
+	(when (< nargs min)
+	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+	    		   but wants at least ~R."
+			  name
+			  nargs
+			  min))
+	(unless (= nargs min)
+	  (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+			   but wants exactly ~R."
+			  name
+			  nargs
+			  min)))
+
+    (when (eq (template-result-types template) :conditional)
+      (compiler-error
+       "%PRIMITIVE was used with a conditional template."))
+
+    (when (template-more-results-type template)
+      (compiler-error
+       "%PRIMITIVE was used with an unknown values template."))
+
+    (ir1-convert start
+		 cont
+		 `(%%primitive ',template
+			       ',(eval-info-args
+				  (subseq args required min))
+			       ,@(subseq args 0 required)
+			       ,@(subseq args min)))))
 
 ;;;; QUOTE and FUNCTION
 
@@ -2308,32 +2243,6 @@
   "optimize away possible call to FDEFINITION at runtime"
   'thing)
 
-;;;; symbol macros
-
-(def-ir1-translator symbol-macrolet ((specs &body body) start cont)
-  #!+sb-doc
-  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
-  Define the Names as symbol macros with the given Expansions. Within the
-  body, references to a Name will effectively be replaced with the Expansion."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (collect ((res))
-      (dolist (spec specs)
-	(unless (proper-list-of-length-p spec 2)
-	  (compiler-error "The symbol macro binding ~S is malformed." spec))
-	(let ((name (first spec))
-	      (def (second spec)))
-	  (unless (symbolp name)
-	    (compiler-error "The symbol macro name ~S is not a symbol." name))
-	  (when (assoc name (res) :test #'eq)
-	    (compiler-style-warning
-	     "The name ~S occurs more than once in SYMBOL-MACROLET."
-	     name))
-	  (res `(,name . (MACRO . ,def)))))
-
-      (let* ((*lexenv* (make-lexenv :variables (res)))
-	     (*lexenv* (process-decls decls (res) nil cont)))
-	(ir1-convert-progn-body start cont forms)))))
-
 ;;; This is a frob that DEFSTRUCT expands into to establish the compiler
 ;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do
 ;;; most of the work, we just clear all of the functions out of
@@ -2434,29 +2343,34 @@
       (let ((*lexenv* (process-decls decls vars nil cont)))
 	(ir1-convert-aux-bindings start cont forms vars values)))))
 
-;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY
-;;; has to preserves top-level-formness, but we don't need to worry
-;;; about that here, because special logic in the compiler main loop
-;;; grabs top-level LOCALLYs and takes care of them before this
-;;; transform ever sees them.
-(def-ir1-translator locally ((&body body)
-			     start cont)
+;;; logic shared between IR1 translators for LOCALLY, MACROLET,
+;;; and SYMBOL-MACROLET
+;;;
+;;; Note that all these things need to preserve top-level-formness,
+;;; but we don't need to worry about that within an IR1 translator,
+;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO
+;;; forms before we hit the IR1 transform level.
+(defun ir1-translate-locally (body start cont)
+  (declare (type list body) (type continuation start cont))
+  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+    (let ((*lexenv* (process-decls decls nil nil cont)))
+      (ir1-convert-aux-bindings start cont forms nil nil))))
+
+(def-ir1-translator locally ((&body body) start cont)
   #!+sb-doc
   "LOCALLY Declaration* Form*
   Sequentially evaluate the Forms in a lexical environment where the
   the Declarations have effect. If LOCALLY is a top-level form, then
   the Forms are also processed as top-level forms."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (let ((*lexenv* (process-decls decls nil nil cont)))
-      (ir1-convert-aux-bindings start cont forms nil nil))))
+  (ir1-translate-locally body start cont))
 
 ;;;; FLET and LABELS
 
 ;;; Given a list of local function specifications in the style of
-;;; Flet, return lists of the function names and of the lambdas which
+;;; FLET, return lists of the function names and of the lambdas which
 ;;; are their definitions.
 ;;;
-;;; The function names are checked for legality. Context is the name
+;;; The function names are checked for legality. CONTEXT is the name
 ;;; of the form, for error reporting.
 (declaim (ftype (function (list symbol) (values list list))
 		extract-flet-variables))
@@ -2904,6 +2818,8 @@
 	       (aver (proper-list-of-length-p qdef 2))
 	       (second qdef))))
 
+    (/show "doing IR1 translator for %DEFMACRO" name)
+
     (unless (symbolp name)
       (compiler-error "The macro name ~S is not a symbol." name))
 
@@ -2913,7 +2829,8 @@
        (remhash name *free-functions*)
        (undefine-function-name name)
        (compiler-warning
-	"~S is being redefined as a macro when it was previously ~(~A~) to be a function."
+	"~S is being redefined as a macro when it was ~
+         previously ~(~A~) to be a function."
 	name
 	(info :function :where-from name)))
       (:macro)
@@ -2995,9 +2912,9 @@
 					     (make-null-lexenv))
 		     :variables (copy-list symbol-macros)
 		     :functions
-		     (mapcar #'(lambda (x)
-				 `(,(car x) .
-				   (macro . ,(coerce (cdr x) 'function))))
+		     (mapcar (lambda (x)
+			       `(,(car x) .
+				 (macro . ,(coerce (cdr x) 'function))))
 			     macros)
 		     :policy (lexenv-policy *lexenv*))))
       (ir1-convert-lambda `(lambda ,@body) name))))