0.pre7.31:

[sbcl.git] / src / compiler / ir1tran.lisp

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 307d762..bd62c93 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -42,25 +42,12 @@
 (declaim (list *current-path*))
 (defvar *current-path* nil)
 
 (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.")

 \f
 ;;;; namespace management utilities
 
 \f
 ;;;; 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
 
 ;;; 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
 ;;; 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*
                                `(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)))))
                                       ,@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
     (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)
   ;; 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))
         (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)
           (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"))
 
   (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
 (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
 
 ;;; 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))))
 (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.
 ;;;
 ;;; If the function isn't a predicate, then we call
 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.

@@ -1784,7 +1767,7 @@
 
     res))
 
 
     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"
 (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))))
       (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))))))
 
              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
 (def-ir1-translator go ((tag) start cont)
   #!+sb-doc
   "Go Tag

@@ -2008,139 +1991,76 @@
 \f
 ;;;; translators for compiler-magic special forms
 
 \f
 ;;;; 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*
   #!+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))
 
   (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*
 (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."
   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)
 
 ;;; 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))))
 
       (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
 ;;; 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
 ;;; 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))
 
   (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)))))

 \f
 ;;;; QUOTE and FUNCTION
 
 \f
 ;;;; QUOTE and FUNCTION
 

@@ -2308,32 +2243,6 @@
   "optimize away possible call to FDEFINITION at runtime"
   'thing)
 \f
   "optimize away possible call to FDEFINITION at runtime"
   'thing)
 \f

-;;;; 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)))))
-\f

 ;;; 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
 ;;; 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)))))
 
       (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."
   #!+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))

 \f
 ;;;; FLET and LABELS
 
 ;;; Given a list of local function specifications in the style of
 \f
 ;;;; 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.
 ;;;
 ;;; 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))
 ;;; 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))))
 
               (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))
 
     (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
        (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)
        name
        (info :function :where-from name)))
       (:macro)

@@ -2995,9 +2912,9 @@
                                             (make-null-lexenv))
                     :variables (copy-list symbol-macros)
                     :functions
                                             (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))))
                             macros)
                     :policy (lexenv-policy *lexenv*))))
       (ir1-convert-lambda `(lambda ,@body) name))))