0.pre7.36

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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 89c17f6..f8bb594 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -12,9 +12,6 @@
 
 (in-package "SB!C")
 
 
 (in-package "SB!C")
 

-(file-comment
-  "$Header$")
-

 (declaim (special *compiler-error-bailout*))
 
 ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path
 (declaim (special *compiler-error-bailout*))
 
 ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path

@@ -45,32 +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*.
-
-;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO
-;;; definitions to be installed in the compilation environment as
-;;; interpreted functions. We set this to false when compiling some
-;;; parts of the system.
-(defvar *compile-time-define-macros* t)
-;;; FIXME: I think this can go away with the new system.
-
-;;; 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
 

@@ -82,7 +59,13 @@
     (setf (info :function :where-from name) :assumed))
 
   (let ((where (info :function :where-from name)))
     (setf (info :function :where-from name) :assumed))
 
   (let ((where (info :function :where-from name)))

-    (when (eq where :assumed)
+    (when (and (eq where :assumed)
+              ;; In the ordinary target Lisp, it's silly to report
+              ;; undefinedness when the function is defined in the
+              ;; running Lisp. But at cross-compile time, the current
+              ;; definedness of a function is irrelevant to the
+              ;; definedness at runtime, which is what matters.
+              #-sb-xc-host (not (fboundp name)))

       (note-undefined-reference name :function))
     (make-global-var :kind :global-function
                     :name name
       (note-undefined-reference name :function))
     (make-global-var :kind :global-function
                     :name name

@@ -99,11 +82,13 @@
   (let* ((info (layout-info
                (or (info :type :compiler-layout (sb!xc:class-name class))
                    (class-layout class))))
   (let* ((info (layout-info
                (or (info :type :compiler-layout (sb!xc:class-name class))
                    (class-layout class))))

-        (accessor (if (listp name) (cadr name) name))
-        (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
+        (accessor-name (if (listp name) (cadr name) name))
+        (slot (find accessor-name (dd-slots info)
+                    :key #'sb!kernel:dsd-accessor-name))

         (type (dd-name info))
         (slot-type (dsd-type slot)))
         (type (dd-name info))
         (slot-type (dsd-type slot)))

-    (assert slot () "Can't find slot ~S." type)
+    (unless slot
+      (error "can't find slot ~S" type))

     (make-slot-accessor
      :name name
      :type (specifier-type
     (make-slot-accessor
      :name name
      :type (specifier-type

@@ -165,7 +150,7 @@
   (let ((var (lexenv-find name functions :test #'equal)))
     (cond (var
           (unless (leaf-p var)
   (let ((var (lexenv-find name functions :test #'equal)))
     (cond (var
           (unless (leaf-p var)

-            (assert (and (consp var) (eq (car var) 'macro)))
+            (aver (and (consp var) (eq (car var) 'macro)))

             (compiler-error "found macro name ~S ~A" name context))
           var)
          (t
             (compiler-error "found macro name ~S ~A" name context))
           var)
          (t

@@ -207,7 +192,10 @@
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.

-(defconstant list-to-hash-table-threshold 32)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) 
+  ;; below. -- AL 20010227
+  (defconstant list-to-hash-table-threshold 32))

 (defun maybe-emit-make-load-forms (constant)
   (let ((things-processed nil)
        (count 0))
 (defun maybe-emit-make-load-forms (constant)
   (let ((things-processed nil)
        (count 0))

@@ -283,7 +271,7 @@
 #!-sb-fluid (declaim (inline prev-link))
 (defun prev-link (node cont)
   (declare (type node node) (type continuation cont))
 #!-sb-fluid (declaim (inline prev-link))
 (defun prev-link (node cont)
   (declare (type node node) (type continuation cont))

-  (assert (not (continuation-next cont)))
+  (aver (not (continuation-next cont)))

   (setf (continuation-next cont) node)
   (setf (node-prev node) cont))
 
   (setf (continuation-next cont) node)
   (setf (node-prev node) cont))
 

@@ -314,15 +302,15 @@
   (declare (type node node) (type continuation cont) (inline member))
   (let ((block (continuation-block cont))
        (node-block (continuation-block (node-prev node))))
   (declare (type node node) (type continuation cont) (inline member))
   (let ((block (continuation-block cont))
        (node-block (continuation-block (node-prev node))))

-    (assert (eq (continuation-kind cont) :block-start))
-    (assert (not (block-last node-block)) () "~S has already ended."
-           node-block)
+    (aver (eq (continuation-kind cont) :block-start))
+    (when (block-last node-block)
+      (error "~S has already ended." node-block))

     (setf (block-last node-block) node)
     (setf (block-last node-block) node)

-    (assert (null (block-succ node-block)) () "~S already has successors."
-           node-block)
+    (when (block-succ node-block)
+      (error "~S already has successors." node-block))

     (setf (block-succ node-block) (list block))
     (setf (block-succ node-block) (list block))

-    (assert (not (member node-block (block-pred block) :test #'eq)) ()
-           "~S is already a predecessor of ~S." node-block block)
+    (when (memq node-block (block-pred block))
+      (error "~S is already a predecessor of ~S." node-block block))

     (push node-block (block-pred block))
     (add-continuation-use node cont)
     (unless (eq (continuation-asserted-type cont) *wild-type*)
     (push node-block (block-pred block))
     (add-continuation-use node cont)
     (unless (eq (continuation-asserted-type cont) *wild-type*)

@@ -382,7 +370,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 +418,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)))))

@@ -472,8 +460,8 @@
                    (global-var
                     (ir1-convert-srctran start cont lexical-def form))
                    (t
                    (global-var
                     (ir1-convert-srctran start cont lexical-def form))
                    (t

-                    (assert (and (consp lexical-def)
-                                 (eq (car lexical-def) 'macro)))
+                    (aver (and (consp lexical-def)
+                               (eq (car lexical-def) 'macro)))

                     (ir1-convert start cont
                                  (careful-expand-macro (cdr lexical-def)
                                                        form))))))
                     (ir1-convert start cont
                                  (careful-expand-macro (cdr lexical-def)
                                                        form))))))

@@ -487,7 +475,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)

@@ -548,7 +536,7 @@
         (compiler-style-warning "reading an ignored variable: ~S" name))
        (reference-leaf start cont var))
       (cons
         (compiler-style-warning "reading an ignored variable: ~S" name))
        (reference-leaf start cont var))
       (cons

-       (assert (eq (car var) 'MACRO))
+       (aver (eq (car var) 'MACRO))

        (ir1-convert start cont (cdr var)))
       (heap-alien-info
        (ir1-convert start cont `(%heap-alien ',var)))))
        (ir1-convert start cont (cdr var)))
       (heap-alien-info
        (ir1-convert start cont `(%heap-alien ',var)))))

@@ -562,8 +550,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 +581,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 +698,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.

@@ -810,7 +794,7 @@
 ;;; If a lambda-var being bound, we intersect the type with the vars
 ;;; type, otherwise we add a type-restriction on the var. If a symbol
 ;;; macro, we just wrap a THE around the expansion.
 ;;; If a lambda-var being bound, we intersect the type with the vars
 ;;; type, otherwise we add a type-restriction on the var. If a symbol
 ;;; macro, we just wrap a THE around the expansion.

-(defun process-type-declaration (decl res vars)
+(defun process-type-decl (decl res vars)

   (declare (list decl vars) (type lexenv res))
   (let ((type (specifier-type (first decl))))
     (collect ((restr nil cons)
   (declare (list decl vars) (type lexenv res))
   (let ((type (specifier-type (first decl))))
     (collect ((restr nil cons)

@@ -827,9 +811,9 @@
                    (int (if (or (function-type-p type)
                                 (function-type-p old-type))
                             type
                    (int (if (or (function-type-p type)
                                 (function-type-p old-type))
                             type

-                            (type-intersection old-type type))))
+                            (type-approx-intersection2 old-type type))))

               (cond ((eq int *empty-type*)
               (cond ((eq int *empty-type*)

-                     (unless (policy nil (= brevity 3))
+                     (unless (policy *lexenv* (= inhibit-warnings 3))

                        (compiler-warning
                         "The type declarations ~S and ~S for ~S conflict."
                         (type-specifier old-type) (type-specifier type)
                        (compiler-warning
                         "The type declarations ~S and ~S for ~S conflict."
                         (type-specifier old-type) (type-specifier type)

@@ -839,7 +823,7 @@
                      (restr (cons var int))))))
            (cons
             ;; FIXME: non-ANSI weirdness
                      (restr (cons var int))))))
            (cons
             ;; FIXME: non-ANSI weirdness

-            (assert (eq (car var) 'MACRO))
+            (aver (eq (car var) 'MACRO))

             (new-vars `(,var-name . (MACRO . (the ,(first decl)
                                                   ,(cdr var))))))
            (heap-alien-info
             (new-vars `(,var-name . (MACRO . (the ,(first decl)
                                                   ,(cdr var))))))
            (heap-alien-info

@@ -853,12 +837,12 @@
                       :variables (new-vars))
          res))))
 
                       :variables (new-vars))
          res))))
 

-;;; Somewhat similar to Process-Type-Declaration, but handles
+;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles

 ;;; declarations for function variables. In addition to allowing
 ;;; declarations for functions being bound, we must also deal with
 ;;; declarations that constrain the type of lexically apparent
 ;;; functions.
 ;;; declarations for function variables. In addition to allowing
 ;;; declarations for functions being bound, we must also deal with
 ;;; declarations that constrain the type of lexically apparent
 ;;; functions.

-(defun process-ftype-declaration (spec res names fvars)
+(defun process-ftype-decl (spec res names fvars)

   (declare (list spec names fvars) (type lexenv res))
   (let ((type (specifier-type spec)))
     (collect ((res nil cons))
   (declare (list spec names fvars) (type lexenv res))
   (let ((type (specifier-type spec)))
     (collect ((res nil cons))

@@ -881,14 +865,14 @@
 ;;; Process a special declaration, returning a new LEXENV. A non-bound
 ;;; special declaration is instantiated by throwing a special variable
 ;;; into the variables.
 ;;; Process a special declaration, returning a new LEXENV. A non-bound
 ;;; special declaration is instantiated by throwing a special variable
 ;;; into the variables.

-(defun process-special-declaration (spec res vars)
+(defun process-special-decl (spec res vars)

   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
       (let ((var (find-in-bindings vars name)))
        (etypecase var
          (cons
   (declare (list spec vars) (type lexenv res))
   (collect ((new-venv nil cons))
     (dolist (name (cdr spec))
       (let ((var (find-in-bindings vars name)))
        (etypecase var
          (cons

-          (assert (eq (car var) 'MACRO))
+          (aver (eq (car var) 'MACRO))

           (compiler-error
            "~S is a symbol-macro and thus can't be declared special."
            name))
           (compiler-error
            "~S is a symbol-macro and thus can't be declared special."
            name))

@@ -925,8 +909,8 @@
 
 ;;; Parse an inline/notinline declaration. If it's a local function we're
 ;;; defining, set its INLINEP. If a global function, add a new FENV entry.
 
 ;;; Parse an inline/notinline declaration. If it's a local function we're
 ;;; defining, set its INLINEP. If a global function, add a new FENV entry.

-(defun process-inline-declaration (spec res fvars)
-  (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq)))
+(defun process-inline-decl (spec res fvars)
+  (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))

        (new-fenv ()))
     (dolist (name (rest spec))
       (let ((fvar (find name fvars :key #'leaf-name :test #'equal)))
        (new-fenv ()))
     (dolist (name (rest spec))
       (let ((fvar (find name fvars :key #'leaf-name :test #'equal)))

@@ -937,7 +921,7 @@
                    name "in an inline or notinline declaration")))
              (etypecase found
                (functional
                    name "in an inline or notinline declaration")))
              (etypecase found
                (functional

-                (when (policy nil (>= speed brevity))
+                (when (policy *lexenv* (>= speed inhibit-warnings))

                   (compiler-note "ignoring ~A declaration not at ~
                                   definition of local function:~%  ~S"
                                  sense name)))
                   (compiler-note "ignoring ~A declaration not at ~
                                   definition of local function:~%  ~S"
                                  sense name)))

@@ -962,7 +946,7 @@
 
 ;;; Process an ignore/ignorable declaration, checking for various losing
 ;;; conditions.
 
 ;;; Process an ignore/ignorable declaration, checking for various losing
 ;;; conditions.

-(defun process-ignore-declaration (spec vars fvars)
+(defun process-ignore-decl (spec vars fvars)

   (declare (list spec vars fvars))
   (dolist (name (rest spec))
     (let ((var (find-in-bindings-or-fbindings name vars fvars)))
   (declare (list spec vars fvars))
   (dolist (name (rest spec))
     (let ((var (find-in-bindings-or-fbindings name vars fvars)))

@@ -995,86 +979,59 @@
   #!+sb-doc
   "If true, processing of the VALUES declaration is inhibited.")
 
   #!+sb-doc
   "If true, processing of the VALUES declaration is inhibited.")
 

-;;; Process a single declaration spec, agumenting the specified LEXENV
-;;; Res and returning it as a result. Vars and Fvars are as described in
+;;; Process a single declaration spec, augmenting the specified LEXENV
+;;; RES and returning it as a result. VARS and FVARS are as described in

 ;;; PROCESS-DECLS.
 ;;; PROCESS-DECLS.

-(defun process-1-declaration (spec res vars fvars cont)
-  (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
-  (case (first spec)
-    (special (process-special-declaration spec res vars))
-    (ftype
-     (unless (cdr spec)
-       (compiler-error "No type specified in FTYPE declaration: ~S." spec))
-     (process-ftype-declaration (second spec) res (cddr spec) fvars))
-    (function
-     ;; Handle old style FUNCTION declaration, which is an abbreviation for
-     ;; FTYPE. Args are name, arglist, result type.
-     (cond ((and (proper-list-of-length-p spec 3 4)
-                (listp (third spec)))
-           (process-ftype-declaration `(function ,@(cddr spec)) res
-                                      (list (second spec))
-                                      fvars))
-          (t
-           (process-type-declaration spec res vars))))
-    ((inline notinline maybe-inline)
-     (process-inline-declaration spec res fvars))
-    ((ignore ignorable)
-     (process-ignore-declaration spec vars fvars)
-     res)
-    (optimize
-     (make-lexenv
-      :default res
-      :cookie (process-optimize-declaration spec (lexenv-cookie res))))
-    (optimize-interface
-     (make-lexenv
-      :default res
-      :interface-cookie (process-optimize-declaration
-                        spec
-                        (lexenv-interface-cookie res))))
-    (type
-     (process-type-declaration (cdr spec) res vars))
-    (sb!pcl::class
-     (process-type-declaration (list (third spec) (second spec)) res vars))
-    (values
-     (if *suppress-values-declaration*
-        res
-        (let ((types (cdr spec)))
-          (do-the-stuff (if (eql (length types) 1)
-                            (car types)
-                            `(values ,@types))
-                        cont res 'values))))
-    (dynamic-extent
-     (when (policy nil (> speed brevity))
-       (compiler-note
-       "The DYNAMIC-EXTENT declaration is not implemented (ignored)."))
-     res)
-    (t
-     (let ((what (first spec)))
-       (cond ((member what *standard-type-names*)
-             (process-type-declaration spec res vars))
-            ((and (not (and (symbolp what)
-                            (string= (symbol-name what) "CLASS"))) ; pcl hack
-                  (or (info :type :kind what)
-                      (and (consp what) (info :type :translator (car what)))))
-             (unless (policy nil (= brevity 3))
-               ;; FIXME: Is it ANSI to warn about this? I think not.
-               (compiler-note "abbreviated type declaration: ~S." spec))
-             (process-type-declaration spec res vars))
-            ((info :declaration :recognized what)
-             res)
-            (t
-             (compiler-warning "unrecognized declaration ~S" spec)
-             res))))))
-
-;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR and
-;;; Functional structures which are being bound. In addition to filling in
-;;; slots in the leaf structures, we return a new LEXENV which reflects
-;;; pervasive special and function type declarations, (NOT)INLINE declarations
-;;; and OPTIMIZE declarations. CONT is the continuation affected by VALUES
-;;; declarations.
+(defun process-1-decl (raw-spec res vars fvars cont)
+  (declare (type list raw-spec vars fvars))
+  (declare (type lexenv res))
+  (declare (type continuation cont))
+  (let ((spec (canonized-decl-spec raw-spec)))
+    (case (first spec)
+      (special (process-special-decl spec res vars))
+      (ftype
+       (unless (cdr spec)
+        (compiler-error "No type specified in FTYPE declaration: ~S" spec))
+       (process-ftype-decl (second spec) res (cddr spec) fvars))
+      ((inline notinline maybe-inline)
+       (process-inline-decl spec res fvars))
+      ((ignore ignorable)
+       (process-ignore-decl spec vars fvars)
+       res)
+      (optimize
+       (make-lexenv
+       :default res
+       :policy (process-optimize-decl spec (lexenv-policy res))))
+      (type
+       (process-type-decl (cdr spec) res vars))
+      (values
+       (if *suppress-values-declaration*
+          res
+          (let ((types (cdr spec)))
+            (do-the-stuff (if (eql (length types) 1)
+                              (car types)
+                              `(values ,@types))
+                          cont res 'values))))
+      (dynamic-extent
+       (when (policy *lexenv* (> speed inhibit-warnings))
+        (compiler-note
+         "compiler limitation:~
+           ~%  There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
+       res)
+      (t
+       (unless (info :declaration :recognized (first spec))
+        (compiler-warning "unrecognized declaration ~S" raw-spec))
+       res))))
+
+;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
+;;; and FUNCTIONAL structures which are being bound. In addition to
+;;; filling in slots in the leaf structures, we return a new LEXENV
+;;; which reflects pervasive special and function type declarations,
+;;; (NOT)INLINE declarations and OPTIMIZE declarations. CONT is the
+;;; continuation affected by VALUES declarations.

 ;;;
 ;;;

-;;; This is also called in main.lisp when PROCESS-FORM handles a use of
-;;; LOCALLY.
+;;; This is also called in main.lisp when PROCESS-FORM handles a use
+;;; of LOCALLY.

 (defun process-decls (decls vars fvars cont &optional (env *lexenv*))
   (declare (list decls vars fvars) (type continuation cont))
   (dolist (decl decls)
 (defun process-decls (decls vars fvars cont &optional (env *lexenv*))
   (declare (list decls vars fvars) (type continuation cont))
   (dolist (decl decls)

@@ -1083,10 +1040,10 @@
        (compiler-error "malformed declaration specifier ~S in ~S"
                        spec
                        decl))
        (compiler-error "malformed declaration specifier ~S in ~S"
                        spec
                        decl))

-      (setq env (process-1-declaration spec env vars fvars cont))))
+      (setq env (process-1-decl spec env vars fvars cont))))

   env)
 
   env)
 

-;;; Return the Specvar for Name to use when we see a local SPECIAL
+;;; Return the SPECVAR for NAME to use when we see a local SPECIAL

 ;;; declaration. If there is a global variable of that name, then
 ;;; check that it isn't a constant and return it. Otherwise, create an
 ;;; anonymous GLOBAL-VAR.
 ;;; declaration. If there is a global variable of that name, then
 ;;; check that it isn't a constant and return it. Otherwise, create an
 ;;; anonymous GLOBAL-VAR.

@@ -1141,38 +1098,38 @@
           (note-lexical-binding name)
           (make-lambda-var :name name)))))
 
           (note-lexical-binding name)
           (make-lambda-var :name name)))))
 

-;;; Make the keyword for a keyword arg, checking that the keyword
-;;; isn't already used by one of the Vars. We also check that the
-;;; keyword isn't the magical :allow-other-keys.
+;;; Make the default keyword for a &KEY arg, checking that the keyword
+;;; isn't already used by one of the VARS. We also check that the
+;;; keyword isn't the magical :ALLOW-OTHER-KEYS.

 (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
 (defun make-keyword-for-arg (symbol vars keywordify)
   (let ((key (if (and keywordify (not (keywordp symbol)))
 (declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
 (defun make-keyword-for-arg (symbol vars keywordify)
   (let ((key (if (and keywordify (not (keywordp symbol)))

-                (intern (symbol-name symbol) "KEYWORD")
+                (keywordicate symbol)

                 symbol)))
     (when (eq key :allow-other-keys)
                 symbol)))
     (when (eq key :allow-other-keys)

-      (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS."))
+      (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))

     (dolist (var vars)
       (let ((info (lambda-var-arg-info var)))
        (when (and info
                   (eq (arg-info-kind info) :keyword)
     (dolist (var vars)
       (let ((info (lambda-var-arg-info var)))
        (when (and info
                   (eq (arg-info-kind info) :keyword)

-                  (eq (arg-info-keyword info) key))
+                  (eq (arg-info-key info) key))

          (compiler-error
           "The keyword ~S appears more than once in the lambda-list."
           key))))
     key))
 
          (compiler-error
           "The keyword ~S appears more than once in the lambda-list."
           key))))
     key))
 

-;;; Parse a lambda-list into a list of Var structures, stripping off
+;;; Parse a lambda-list into a list of VAR structures, stripping off

 ;;; any aux bindings. Each arg name is checked for legality, and
 ;;; duplicate names are checked for. If an arg is globally special,
 ;;; any aux bindings. Each arg name is checked for legality, and
 ;;; duplicate names are checked for. If an arg is globally special,

-;;; the var is marked as :special instead of :lexical. Keyword,
-;;; optional and rest args are annotated with an arg-info structure
+;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY,
+;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure

 ;;; which contains the extra information. If we hit something losing,
 ;;; which contains the extra information. If we hit something losing,

-;;; we bug out with Compiler-Error. These values are returned:
-;;;  1. A list of the var structures for each top-level argument.
-;;;  2. A flag indicating whether &key was specified.
-;;;  3. A flag indicating whether other keyword args are allowed.
-;;;  4. A list of the &aux variables.
-;;;  5. A list of the &aux values.
+;;; we bug out with COMPILER-ERROR. These values are returned:
+;;;  1. a list of the var structures for each top-level argument;
+;;;  2. a flag indicating whether &KEY was specified;
+;;;  3. a flag indicating whether other &KEY args are allowed;
+;;;  4. a list of the &AUX variables; and
+;;;  5. a list of the &AUX values.

 (declaim (ftype (function (list) (values list boolean boolean list list))
                find-lambda-vars))
 (defun find-lambda-vars (list)
 (declaim (ftype (function (list) (values list boolean boolean list list))
                find-lambda-vars))
 (defun find-lambda-vars (list)

@@ -1183,9 +1140,9 @@
              (names-so-far)
              (aux-vars)
              (aux-vals))
              (names-so-far)
              (aux-vars)
              (aux-vals))

-      ;; Parse-Default deals with defaults and supplied-p args for optionals
-      ;; and keywords args.
-      (flet ((parse-default (spec info)
+      (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args
+            ;; for optionals and keywords args.
+            (parse-default (spec info)

               (when (consp (cdr spec))
                 (setf (arg-info-default info) (second spec))
                 (when (consp (cddr spec))
               (when (consp (cdr spec))
                 (setf (arg-info-default info) (second spec))
                 (when (consp (cddr spec))

@@ -1242,9 +1199,9 @@
            (let ((var (varify-lambda-arg spec (names-so-far))))
              (setf (lambda-var-arg-info var)
                    (make-arg-info :kind :keyword
            (let ((var (varify-lambda-arg spec (names-so-far))))
              (setf (lambda-var-arg-info var)
                    (make-arg-info :kind :keyword

-                                  :keyword (make-keyword-for-arg spec
-                                                                 (vars)
-                                                                 t)))
+                                  :key (make-keyword-for-arg spec
+                                                             (vars)
+                                                             t)))

              (vars var)
              (names-so-far spec)))
           ((atom (first spec))
              (vars var)
              (names-so-far spec)))
           ((atom (first spec))

@@ -1252,7 +1209,7 @@
                   (var (varify-lambda-arg name (names-so-far)))
                   (info (make-arg-info
                          :kind :keyword
                   (var (varify-lambda-arg name (names-so-far)))
                   (info (make-arg-info
                          :kind :keyword

-                         :keyword (make-keyword-for-arg name (vars) t))))
+                         :key (make-keyword-for-arg name (vars) t))))

              (setf (lambda-var-arg-info var) info)
              (vars var)
              (names-so-far name)
              (setf (lambda-var-arg-info var) info)
              (vars var)
              (names-so-far name)

@@ -1260,14 +1217,14 @@
           (t
            (let ((head (first spec)))
              (unless (proper-list-of-length-p head 2)
           (t
            (let ((head (first spec)))
              (unless (proper-list-of-length-p head 2)

-               (error "malformed keyword arg specifier: ~S" spec))
+               (error "malformed &KEY argument specifier: ~S" spec))

              (let* ((name (second head))
                     (var (varify-lambda-arg name (names-so-far)))
                     (info (make-arg-info
                            :kind :keyword
              (let* ((name (second head))
                     (var (varify-lambda-arg name (names-so-far)))
                     (info (make-arg-info
                            :kind :keyword

-                           :keyword (make-keyword-for-arg (first head)
-                                                          (vars)
-                                                          nil))))
+                           :key (make-keyword-for-arg (first head)
+                                                      (vars)
+                                                      nil))))

                (setf (lambda-var-arg-info var) info)
                (vars var)
                (names-so-far name)
                (setf (lambda-var-arg-info var) info)
                (vars var)
                (names-so-far name)

@@ -1291,48 +1248,41 @@
 
        (values (vars) keyp allowp (aux-vars) (aux-vals))))))
 
 
        (values (vars) keyp allowp (aux-vars) (aux-vals))))))
 

-;;; Similar to IR1-Convert-Progn-Body except that we sequentially bind each
-;;; Aux-Var to the corresponding Aux-Val before converting the body. If there
-;;; are no bindings, just convert the body, otherwise do one binding and
-;;; recurse on the rest.
-;;;
-;;;    If Interface is true, then we convert bindings with the interface
-;;; policy. For real &aux bindings, and implicit aux bindings introduced by
-;;; keyword bindings, this is always true. It is only false when LET* directly
-;;; calls this function.
-(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
+;;; This is similar to IR1-CONVERT-PROGN-BODY except that we
+;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before
+;;; converting the body. If there are no bindings, just convert the
+;;; body, otherwise do one binding and recurse on the rest.
+(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals)

   (declare (type continuation start cont) (list body aux-vars aux-vals))
   (if (null aux-vars)
       (ir1-convert-progn-body start cont body)
       (let ((fun-cont (make-continuation))
   (declare (type continuation start cont) (list body aux-vars aux-vals))
   (if (null aux-vars)
       (ir1-convert-progn-body start cont body)
       (let ((fun-cont (make-continuation))

-           (fun (ir1-convert-lambda-body body (list (first aux-vars))
-                                         (rest aux-vars) (rest aux-vals)
-                                         interface)))
+           (fun (ir1-convert-lambda-body body
+                                         (list (first aux-vars))
+                                         :aux-vars (rest aux-vars)
+                                         :aux-vals (rest aux-vals))))

        (reference-leaf start fun-cont fun)
        (reference-leaf start fun-cont fun)

-       (let ((*lexenv* (if interface
-                           (make-lexenv
-                            :cookie (make-interface-cookie *lexenv*))
-                           *lexenv*)))
-         (ir1-convert-combination-args fun-cont cont
-                                       (list (first aux-vals))))))
+       (ir1-convert-combination-args fun-cont cont
+                                     (list (first aux-vals)))))

   (values))
 
   (values))
 

-;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
-;;; for each Svar to the value of the variable is wrapped around the body. If
-;;; there are no special bindings, we just convert the body, otherwise we do
-;;; one special binding and recurse on the rest.
+;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
+;;; the SPECVAR for each SVAR to the value of the variable is wrapped
+;;; around the body. If there are no special bindings, we just convert
+;;; the body, otherwise we do one special binding and recurse on the
+;;; rest.

 ;;;
 ;;;

-;;; We make a cleanup and introduce it into the lexical environment. If
-;;; there are multiple special bindings, the cleanup for the blocks will end up
-;;; being the innermost one. We force Cont to start a block outside of this
-;;; cleanup, causing cleanup code to be emitted when the scope is exited.
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
-                                          interface svars)
+;;; We make a cleanup and introduce it into the lexical environment.
+;;; If there are multiple special bindings, the cleanup for the blocks
+;;; will end up being the innermost one. We force CONT to start a
+;;; block outside of this cleanup, causing cleanup code to be emitted
+;;; when the scope is exited.
+(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)

   (declare (type continuation start cont)
           (list body aux-vars aux-vals svars))
   (cond
    ((null svars)
   (declare (type continuation start cont)
           (list body aux-vars aux-vals svars))
   (cond
    ((null svars)

-    (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
+    (ir1-convert-aux-bindings start cont body aux-vars aux-vals))

    (t
     (continuation-starts-block cont)
     (let ((cleanup (make-cleanup :kind :special-bind))
    (t
     (continuation-starts-block cont)
     (let ((cleanup (make-cleanup :kind :special-bind))

@@ -1345,30 +1295,27 @@
       (let ((*lexenv* (make-lexenv :cleanup cleanup)))
        (ir1-convert next-cont nnext-cont '(%cleanup-point))
        (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
       (let ((*lexenv* (make-lexenv :cleanup cleanup)))
        (ir1-convert next-cont nnext-cont '(%cleanup-point))
        (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals

-                                     interface (rest svars))))))
+                                     (rest svars))))))

   (values))
 
 ;;; Create a lambda node out of some code, returning the result. The
   (values))
 
 ;;; Create a lambda node out of some code, returning the result. The

-;;; bindings are specified by the list of var structures Vars. We deal
-;;; with adding the names to the Lexenv-Variables for the conversion.
-;;; The result is added to the New-Functions in the
-;;; *Current-Component* and linked to the component head and tail.
+;;; bindings are specified by the list of VAR structures VARS. We deal
+;;; with adding the names to the LEXENV-VARIABLES for the conversion.
+;;; The result is added to the NEW-FUNCTIONS in the
+;;; *CURRENT-COMPONENT* and linked to the component head and tail.

 ;;;
 ;;;

-;;; We detect special bindings here, replacing the original Var in the
+;;; We detect special bindings here, replacing the original VAR in the

 ;;; lambda list with a temporary variable. We then pass a list of the
 ;;; lambda list with a temporary variable. We then pass a list of the

-;;; special vars to IR1-Convert-Special-Bindings, which actually emits
+;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits

 ;;; the special binding code.
 ;;;
 ;;; the special binding code.
 ;;;

-;;; We ignore any Arg-Info in the Vars, trusting that someone else is
+;;; We ignore any ARG-INFO in the VARS, trusting that someone else is

 ;;; dealing with &nonsense.
 ;;;
 ;;; dealing with &nonsense.
 ;;;

-;;; Aux-Vars is a list of Var structures for variables that are to be
-;;; sequentially bound. Each Aux-Val is a form that is to be evaluated
-;;; to get the initial value for the corresponding Aux-Var. Interface
-;;; is a flag as T when there are real aux values (see let* and
-;;; ir1-convert-aux-bindings.)
-(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
-                                    interface result)
+;;; AUX-VARS is a list of VAR structures for variables that are to be
+;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
+;;; to get the initial value for the corresponding AUX-VAR. 
+(defun ir1-convert-lambda-body (body vars &key aux-vars aux-vals result)

   (declare (list body vars aux-vars aux-vals)
           (type (or continuation null) result))
   (let* ((bind (make-bind))
   (declare (list body vars aux-vars aux-vals)
           (type (or continuation null) result))
   (let* ((bind (make-bind))

@@ -1400,7 +1347,7 @@
          (prev-link bind cont1)
          (use-continuation bind cont2)
          (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
          (prev-link bind cont1)
          (use-continuation bind cont2)
          (ir1-convert-special-bindings cont2 result body aux-vars aux-vals

-                                       interface (svars)))
+                                       (svars)))

 
        (let ((block (continuation-block result)))
          (when block
 
        (let ((block (continuation-block result)))
          (when block

@@ -1420,16 +1367,14 @@
     lambda))
 
 ;;; Create the actual entry-point function for an optional entry
     lambda))
 
 ;;; Create the actual entry-point function for an optional entry

-;;; point. The lambda binds copies of each of the Vars, then calls Fun
-;;; with the argument Vals and the Defaults. Presumably the Vals refer
-;;; to the Vars by name. The Vals are passed in in reverse order.
+;;; point. The lambda binds copies of each of the VARS, then calls FUN
+;;; with the argument VALS and the DEFAULTS. Presumably the VALS refer
+;;; to the VARS by name. The VALS are passed in in reverse order.

 ;;;
 ;;; If any of the copies of the vars are referenced more than once,
 ;;;
 ;;; If any of the copies of the vars are referenced more than once,

-;;; then we mark the corresponding var as Ever-Used to inhibit
+;;; then we mark the corresponding var as EVER-USED to inhibit

 ;;; "defined but not read" warnings for arguments that are only used
 ;;; by default forms.
 ;;; "defined but not read" warnings for arguments that are only used
 ;;; by default forms.

-;;;
-;;; We bind *LEXENV* to change the policy to the interface policy.

 (defun convert-optional-entry (fun vars vals defaults)
   (declare (type clambda fun) (list vars vals defaults))
   (let* ((fvars (reverse vars))
 (defun convert-optional-entry (fun vars vals defaults)
   (declare (type clambda fun) (list vars vals defaults))
   (let* ((fvars (reverse vars))

@@ -1442,20 +1387,20 @@
                              :where-from (leaf-where-from var)
                              :specvar (lambda-var-specvar var)))
                           fvars))
                              :where-from (leaf-where-from var)
                              :specvar (lambda-var-specvar var)))
                           fvars))

-        (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))

         (fun
         (fun

-         (ir1-convert-lambda-body
-          `((%funcall ,fun ,@(reverse vals) ,@defaults))
-          arg-vars)))
-    (mapc #'(lambda (var arg-var)
-             (when (cdr (leaf-refs arg-var))
-               (setf (leaf-ever-used var) t)))
+         (ir1-convert-lambda-body `((%funcall ,fun
+                                              ,@(reverse vals)
+                                              ,@defaults))
+                                  arg-vars)))
+    (mapc (lambda (var arg-var)
+           (when (cdr (leaf-refs arg-var))
+             (setf (leaf-ever-used var) t)))

          fvars arg-vars)
     fun))
 
 ;;; This function deals with supplied-p vars in optional arguments. If
 ;;; the there is no supplied-p arg, then we just call
          fvars arg-vars)
     fun))
 
 ;;; This function deals with supplied-p vars in optional arguments. If
 ;;; the there is no supplied-p arg, then we just call

-;;; IR1-Convert-Hairy-Args on the remaining arguments, and generate a
+;;; IR1-CONVERT-HAIRY-ARGS on the remaining arguments, and generate a

 ;;; optional entry that calls the result. If there is a supplied-p
 ;;; var, then we add it into the default vars and throw a T into the
 ;;; entry values. The resulting entry point function is returned.
 ;;; optional entry that calls the result. If there is a supplied-p
 ;;; var, then we add it into the default vars and throw a T into the
 ;;; entry values. The resulting entry point function is returned.

@@ -1492,32 +1437,30 @@
                                (list (arg-info-default info) nil)
                                (list (arg-info-default info))))))
 
                                (list (arg-info-default info) nil)
                                (list (arg-info-default info))))))
 

-;;; Create the More-Entry function for the Optional-Dispatch Res.
-;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
-;;; for any Rest arg. Keys is a list of the keyword arg vars.
+;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
+;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
+;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars.

 ;;;
 ;;;

-;;; The most interesting thing that we do is parse keywords. We create a
-;;; bunch of temporary variables to hold the result of the parse, and then loop
-;;; over the supplied arguments, setting the appropriate temps for the supplied
-;;; keyword. Note that it is significant that we iterate over the keywords in
-;;; reverse order --- this implements the CL requirement that (when a keyword
-;;; appears more than once) the first value is used.
+;;; The most interesting thing that we do is parse keywords. We create
+;;; a bunch of temporary variables to hold the result of the parse,
+;;; and then loop over the supplied arguments, setting the appropriate
+;;; temps for the supplied keyword. Note that it is significant that
+;;; we iterate over the keywords in reverse order --- this implements
+;;; the CL requirement that (when a keyword appears more than once)
+;;; the first value is used.

 ;;;
 ;;; If there is no supplied-p var, then we initialize the temp to the
 ;;;
 ;;; If there is no supplied-p var, then we initialize the temp to the

-;;; default and just pass the temp into the main entry. Since non-constant
-;;; keyword args are forcibly given a supplied-p var, we know that the default
-;;; is constant, and thus safe to evaluate out of order.
-;;;
-;;; If there is a supplied-p var, then we create temps for both the value
-;;; and the supplied-p, and pass them into the main entry, letting it worry
-;;; about defaulting.
+;;; default and just pass the temp into the main entry. Since
+;;; non-constant &KEY args are forcibly given a supplied-p var, we
+;;; know that the default is constant, and thus safe to evaluate out
+;;; of order.

 ;;;
 ;;;

-;;; We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
+;;; If there is a supplied-p var, then we create temps for both the
+;;; value and the supplied-p, and pass them into the main entry,
+;;; letting it worry about defaulting.

 ;;;
 ;;;

-;;; When converting the function, we bind *LEXENV* to change the
-;;; compilation policy over to the interface policy, so that keyword
-;;; args will be checked even when type checking isn't on in general.
+;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
+;;; until we have scanned all the keywords.

 (defun convert-more-entry (res entry-vars entry-vals rest morep keys)
   (declare (type optional-dispatch res) (list entry-vars entry-vals keys))
   (collect ((arg-vars)
 (defun convert-more-entry (res entry-vars entry-vals rest morep keys)
   (declare (type optional-dispatch res) (list entry-vars entry-vals keys))
   (collect ((arg-vars)

@@ -1534,8 +1477,7 @@
           (context-temp (make-lambda-var :name n-context))
           (n-count (gensym "N-COUNT-"))
           (count-temp (make-lambda-var :name n-count
           (context-temp (make-lambda-var :name n-context))
           (n-count (gensym "N-COUNT-"))
           (count-temp (make-lambda-var :name n-count

-                                       :type (specifier-type 'index)))
-          (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))))
+                                       :type (specifier-type 'index))))

 
       (arg-vars context-temp count-temp)
 
 
       (arg-vars context-temp count-temp)
 

@@ -1552,7 +1494,7 @@
              (n-allowp (gensym "N-ALLOWP-"))
              (n-losep (gensym "N-LOSEP-"))
              (allowp (or (optional-dispatch-allowp res)
              (n-allowp (gensym "N-ALLOWP-"))
              (n-losep (gensym "N-LOSEP-"))
              (allowp (or (optional-dispatch-allowp res)

-                         (policy nil (zerop safety)))))
+                         (policy *lexenv* (zerop safety)))))

 
          (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
          (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
 
          (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
          (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))

@@ -1561,7 +1503,7 @@
            (dolist (key keys)
              (let* ((info (lambda-var-arg-info key))
                     (default (arg-info-default info))
            (dolist (key keys)
              (let* ((info (lambda-var-arg-info key))
                     (default (arg-info-default info))

-                    (keyword (arg-info-keyword info))
+                    (keyword (arg-info-key info))

                     (supplied-p (arg-info-supplied-p info))
                     (n-value (gensym "N-VALUE-")))
                (temps `(,n-value ,default))
                     (supplied-p (arg-info-supplied-p info))
                     (n-value (gensym "N-VALUE-")))
                (temps `(,n-value ,default))

@@ -1569,12 +1511,12 @@
                       (let ((n-supplied (gensym "N-SUPPLIED-")))
                         (temps n-supplied)
                         (arg-vals n-value n-supplied)
                       (let ((n-supplied (gensym "N-SUPPLIED-")))
                         (temps n-supplied)
                         (arg-vals n-value n-supplied)

-                        (tests `((eq ,n-key ,keyword)
+                        (tests `((eq ,n-key ',keyword)

                                  (setq ,n-supplied t)
                                  (setq ,n-value ,n-value-temp)))))
                      (t
                       (arg-vals n-value)
                                  (setq ,n-supplied t)
                                  (setq ,n-value ,n-value-temp)))))
                      (t
                       (arg-vals n-value)

-                      (tests `((eq ,n-key ,keyword)
+                      (tests `((eq ,n-key ',keyword)

                                (setq ,n-value ,n-value-temp)))))))
 
            (unless allowp
                                (setq ,n-value ,n-value-temp)))))))
 
            (unless allowp

@@ -1586,7 +1528,7 @@
 
            (body
             `(when (oddp ,n-count)
 
            (body
             `(when (oddp ,n-count)

-               (%odd-keyword-arguments-error)))
+               (%odd-key-arguments-error)))

 
            (body
             `(locally
 
            (body
             `(locally

@@ -1601,7 +1543,7 @@
 
            (unless allowp
              (body `(when (and ,n-losep (not ,n-allowp))
 
            (unless allowp
              (body `(when (and ,n-losep (not ,n-allowp))

-                      (%unknown-keyword-argument-error ,n-losep)))))))
+                      (%unknown-key-argument-error ,n-losep)))))))

 
       (let ((ep (ir1-convert-lambda-body
                 `((let ,(temps)
 
       (let ((ep (ir1-convert-lambda-body
                 `((let ,(temps)

@@ -1613,17 +1555,17 @@
 
   (values))
 
 
   (values))
 

-;;; Called by IR1-Convert-Hairy-Args when we run into a rest or
-;;; keyword arg. The arguments are similar to that function, but we
-;;; split off any rest arg and pass it in separately. Rest is the rest
-;;; arg var, or NIL if there is no rest arg. Keys is a list of the
-;;; keyword argument vars.
+;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST
+;;; or &KEY arg. The arguments are similar to that function, but we
+;;; split off any &REST arg and pass it in separately. REST is the
+;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of
+;;; the &KEY argument vars.

 ;;;
 ;;;

-;;; When there are keyword arguments, we introduce temporary gensym
+;;; When there are &KEY arguments, we introduce temporary gensym

 ;;; variables to hold the values while keyword defaulting is in
 ;;; progress to get the required sequential binding semantics.
 ;;;
 ;;; variables to hold the values while keyword defaulting is in
 ;;; progress to get the required sequential binding semantics.
 ;;;

-;;; This gets interesting mainly when there are keyword arguments with
+;;; This gets interesting mainly when there are &KEY arguments with

 ;;; supplied-p vars or non-constant defaults. In either case, pass in
 ;;; a supplied-p var. If the default is non-constant, we introduce an
 ;;; IF in the main entry that tests the supplied-p var and decides
 ;;; supplied-p vars or non-constant defaults. In either case, pass in
 ;;; a supplied-p var. If the default is non-constant, we introduce an
 ;;; IF in the main entry that tests the supplied-p var and decides

@@ -1687,11 +1629,11 @@
               (main-vals (arg-info-default info))
               (bind-vals n-val)))))
 
               (main-vals (arg-info-default info))
               (bind-vals n-val)))))
 

-    (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
-                                               (append (bind-vars) aux-vars)
-                                               (append (bind-vals) aux-vals)
-                                               t
-                                               cont))
+    (let* ((main-entry (ir1-convert-lambda-body
+                       body (main-vars)
+                       :aux-vars (append (bind-vars) aux-vars)
+                       :aux-vals (append (bind-vals) aux-vals)
+                       :result cont))

           (last-entry (convert-optional-entry main-entry default-vars
                                               (main-vals) ())))
       (setf (optional-dispatch-main-entry res) main-entry)
           (last-entry (convert-optional-entry main-entry default-vars
                                               (main-vals) ())))
       (setf (optional-dispatch-main-entry res) main-entry)

@@ -1708,32 +1650,33 @@
 ;;; arguments, analyzing the arglist on the way down and generating entry
 ;;; points on the way up.
 ;;;
 ;;; arguments, analyzing the arglist on the way down and generating entry
 ;;; points on the way up.
 ;;;

-;;; Default-Vars is a reversed list of all the argument vars processed so
-;;; far, including supplied-p vars. Default-Vals is a list of the names of the
-;;; Default-Vars.
+;;; Default-Vars is a reversed list of all the argument vars processed
+;;; so far, including supplied-p vars. Default-Vals is a list of the
+;;; names of the Default-Vars.

 ;;;
 ;;;

-;;; Entry-Vars is a reversed list of processed argument vars, excluding
-;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get
-;;; the values for all the vars from the Entry-Vars. It has the var name for
-;;; each required or optional arg, and has T for each supplied-p arg.
+;;; Entry-Vars is a reversed list of processed argument vars,
+;;; excluding supplied-p vars. Entry-Vals is a list things that can be
+;;; evaluated to get the values for all the vars from the Entry-Vars.
+;;; It has the var name for each required or optional arg, and has T
+;;; for each supplied-p arg.

 ;;;
 ;;;

-;;; Vars is a list of the Lambda-Var structures for arguments that haven't
-;;; been processed yet. Supplied-p-p is true if a supplied-p argument has
-;;; already been processed; only in this case are the Default-XXX and Entry-XXX
-;;; different.
+;;; Vars is a list of the Lambda-Var structures for arguments that
+;;; haven't been processed yet. Supplied-p-p is true if a supplied-p
+;;; argument has already been processed; only in this case are the
+;;; Default-XXX and Entry-XXX different.

 ;;;
 ;;;

-;;; The result at each point is a lambda which should be called by the above
-;;; level to default the remaining arguments and evaluate the body. We cause
-;;; the body to be evaluated by converting it and returning it as the result
-;;; when the recursion bottoms out.
+;;; The result at each point is a lambda which should be called by the
+;;; above level to default the remaining arguments and evaluate the
+;;; body. We cause the body to be evaluated by converting it and
+;;; returning it as the result when the recursion bottoms out.

 ;;;
 ;;;

-;;; Each level in the recursion also adds its entry point function to the
-;;; result Optional-Dispatch. For most arguments, the defaulting function and
-;;; the entry point function will be the same, but when supplied-p args are
-;;; present they may be different.
+;;; Each level in the recursion also adds its entry point function to
+;;; the result Optional-Dispatch. For most arguments, the defaulting
+;;; function and the entry point function will be the same, but when
+;;; supplied-p args are present they may be different.

 ;;;
 ;;;

-;;; When we run into a rest or keyword arg, we punt out to
-;;; IR1-Convert-More, which finishes for us in this case.
+;;; When we run into a &REST or &KEY arg, we punt out to
+;;; IR1-CONVERT-MORE, which finishes for us in this case.

 (defun ir1-convert-hairy-args (res default-vars default-vals
                                   entry-vars entry-vals
                                   vars supplied-p-p body aux-vars
 (defun ir1-convert-hairy-args (res default-vars default-vals
                                   entry-vars entry-vals
                                   vars supplied-p-p body aux-vars

@@ -1750,7 +1693,9 @@
                               nil nil nil vars supplied-p-p body aux-vars
                               aux-vals cont)
             (let ((fun (ir1-convert-lambda-body body (reverse default-vars)
                               nil nil nil vars supplied-p-p body aux-vars
                               aux-vals cont)
             (let ((fun (ir1-convert-lambda-body body (reverse default-vars)

-                                                aux-vars aux-vals t cont)))
+                                                :aux-vars aux-vars
+                                                :aux-vals aux-vals
+                                                :result cont)))

               (setf (optional-dispatch-main-entry res) fun)
               (push (if supplied-p-p
                         (convert-optional-entry fun entry-vars entry-vals ())
               (setf (optional-dispatch-main-entry res) fun)
               (push (if supplied-p-p
                         (convert-optional-entry fun entry-vars entry-vals ())

@@ -1796,9 +1741,9 @@
                                aux-vals cont)))))))
 
 ;;; This function deals with the case where we have to make an
                                aux-vals cont)))))))
 
 ;;; This function deals with the case where we have to make an

-;;; Optional-Dispatch to represent a lambda. We cons up the result and call
-;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
-;;; min-args and max-args.
+;;; Optional-Dispatch to represent a lambda. We cons up the result and
+;;; call IR1-CONVERT-HAIRY-ARGS to do the work. When it is done, we
+;;; figure out the min-args and max-args.

 (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
   (declare (list body vars aux-vars aux-vals) (type continuation cont))
   (let ((res (make-optional-dispatch :arglist vars
 (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
   (declare (list body vars aux-vars aux-vals) (type continuation cont))
   (let ((res (make-optional-dispatch :arglist vars

@@ -1823,7 +1768,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"

@@ -1850,8 +1795,10 @@
                      (ir1-convert-hairy-lambda forms vars keyp
                                                allow-other-keys
                                                aux-vars aux-vals cont)
                      (ir1-convert-hairy-lambda forms vars keyp
                                                allow-other-keys
                                                aux-vars aux-vals cont)

-                     (ir1-convert-lambda-body forms vars aux-vars aux-vals
-                                              t cont))))
+                     (ir1-convert-lambda-body forms vars
+                                              :aux-vars aux-vars
+                                              :aux-vals aux-vals
+                                              :result cont))))

        (setf (functional-inline-expansion res) form)
        (setf (functional-arg-documentation res) (cadr form))
        (setf (leaf-name res) name)
        (setf (functional-inline-expansion res) form)
        (setf (functional-arg-documentation res) (cadr form))
        (setf (leaf-name res) name)

@@ -1927,10 +1874,14 @@
     (setf (entry-cleanup entry) cleanup)
     (prev-link entry start)
     (use-continuation entry dummy)
     (setf (entry-cleanup entry) cleanup)
     (prev-link entry start)
     (use-continuation entry dummy)

-    (let ((*lexenv* (make-lexenv :blocks (list (cons name (list entry cont)))
-                                :cleanup cleanup)))
+    
+    (let* ((env-entry (list entry cont))
+           (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
+                                 :cleanup cleanup)))
+      (push env-entry (continuation-lexenv-uses cont))

       (ir1-convert-progn-body dummy cont forms))))
 
       (ir1-convert-progn-body dummy cont forms))))
 

+

 ;;; We make Cont start a block just so that it will have a block
 ;;; assigned. People assume that when they pass a continuation into
 ;;; IR1-Convert as Cont, it will have a block when it is done.
 ;;; We make Cont start a block just so that it will have a block
 ;;; assigned. People assume that when they pass a continuation into
 ;;; IR1-Convert as Cont, it will have a block when it is done.

@@ -1954,7 +1905,7 @@
     (prev-link exit value-cont)
     (use-continuation exit (second found))))
 
     (prev-link exit value-cont)
     (use-continuation exit (second found))))
 

-;;; Return a list of the segments of a tagbody. Each segment looks
+;;; Return a list of the segments of a TAGBODY. Each segment looks

 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a

@@ -1966,7 +1917,7 @@
   (collect ((segments))
     (let ((current (cons nil body)))
       (loop
   (collect ((segments))
     (let ((current (cons nil body)))
       (loop

-       (let ((tag-pos (position-if-not #'listp current :start 1)))
+       (let ((tag-pos (position-if (complement #'listp) current :start 1)))

          (unless tag-pos
            (segments `(,@current nil))
            (return))
          (unless tag-pos
            (segments `(,@current nil))
            (return))

@@ -2010,19 +1961,21 @@
              (conts))
       (starts dummy)
       (dolist (segment (rest segments))
              (conts))
       (starts dummy)
       (dolist (segment (rest segments))

-       (let ((tag-cont (make-continuation)))
+       (let* ((tag-cont (make-continuation))
+               (tag (list (car segment) entry tag-cont)))          

          (conts tag-cont)
          (starts tag-cont)
          (continuation-starts-block tag-cont)
          (conts tag-cont)
          (starts tag-cont)
          (continuation-starts-block tag-cont)

-         (tags (list (car segment) entry tag-cont))))
+          (tags tag)
+          (push (cdr tag) (continuation-lexenv-uses tag-cont))))

       (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

@@ -2039,89 +1992,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
-      (eval `(progn ,@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."
-  (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*

@@ -2129,9 +2069,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)

@@ -2155,9 +2120,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

@@ -2168,60 +2130,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
 

@@ -2289,63 +2244,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
-;;; *FREE-FUNCTIONS* to keep things in synch. %%COMPILER-DEFSTRUCT is also
-;;; called at load-time.
-(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
-  (let* ((info (eval info)))
-    (%%compiler-defstruct info)
-    (dolist (slot (dd-slots info))
-      (let ((fun (dsd-accessor slot)))
-       (remhash fun *free-functions*)
-       (unless (dsd-read-only slot)
-         (remhash `(setf ,fun) *free-functions*))))
-    (remhash (dd-predicate info) *free-functions*)
-    (remhash (dd-copier info) *free-functions*)
-    (ir1-convert start cont `(%%compiler-defstruct ',info))))
-
-;;; Return the contents of a quoted form.
-(defun unquote (x)
-  (if (and (consp x)
-          (= 2 (length x))
-          (eq 'quote (first x)))
-    (second x)
-    (error "not a quoted form")))
-
-;;; Don't actually compile anything, instead call the function now.
-(def-ir1-translator %compiler-only-defstruct
-                   ((info inherits) start cont :kind :function)
-  (function-%compiler-only-defstruct (unquote info) (unquote inherits))
-  (reference-constant start cont nil))
-\f

 ;;;; LET and LET*
 ;;;;
 ;;;; (LET and LET* can't be implemented as macros due to the fact that
 ;;;; LET and LET*
 ;;;;
 ;;;; (LET and LET* can't be implemented as macros due to the fact that

@@ -2413,31 +2311,36 @@
   (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
     (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
       (let ((*lexenv* (process-decls decls vars nil cont)))
   (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
     (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
       (let ((*lexenv* (process-decls decls vars nil cont)))

-       (ir1-convert-aux-bindings start cont forms vars values nil)))))
-
-;;; 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)
+       (ir1-convert-aux-bindings start cont forms vars values)))))
+
+;;; 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 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))

@@ -2510,9 +2413,9 @@
 \f
 ;;;; THE
 
 \f
 ;;;; THE
 

-;;; Do stuff to recognize a THE or VALUES declaration. Cont is the
-;;; continuation that the assertion applies to, Type is the type
-;;; specifier and Lexenv is the current lexical environment. Name is
+;;; Do stuff to recognize a THE or VALUES declaration. CONT is the
+;;; continuation that the assertion applies to, TYPE is the type
+;;; specifier and Lexenv is the current lexical environment. NAME is

 ;;; the name of the declaration we are doing, for use in error
 ;;; messages.
 ;;;
 ;;; the name of the declaration we are doing, for use in error
 ;;; messages.
 ;;;

@@ -2531,8 +2434,8 @@
 ;;; we union) and nested ones (which we intersect).
 ;;;
 ;;; We represent the scoping by throwing our innermost (intersected)
 ;;; we union) and nested ones (which we intersect).
 ;;;
 ;;; We represent the scoping by throwing our innermost (intersected)

-;;; assertion on Cont into the TYPE-RESTRICTIONS. As we go down, we
-;;; intersect our assertions together. If Cont has no uses yet, we
+;;; assertion on CONT into the TYPE-RESTRICTIONS. As we go down, we
+;;; intersect our assertions together. If CONT has no uses yet, we

 ;;; have not yet bottomed out on the first COND branch; in this case
 ;;; we optimistically assume that this type will be the one we end up
 ;;; with, and set the ASSERTED-TYPE to it. We can never get better
 ;;; have not yet bottomed out on the first COND branch; in this case
 ;;; we optimistically assume that this type will be the one we end up
 ;;; with, and set the ASSERTED-TYPE to it. We can never get better

@@ -2547,13 +2450,14 @@
   (let* ((ctype (values-specifier-type type))
         (old-type (or (lexenv-find cont type-restrictions)
                       *wild-type*))
   (let* ((ctype (values-specifier-type type))
         (old-type (or (lexenv-find cont type-restrictions)
                       *wild-type*))

-        (intersects (values-types-intersect old-type ctype))
+        (intersects (values-types-equal-or-intersect old-type ctype))

         (int (values-type-intersection old-type ctype))
         (new (if intersects int old-type)))
     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new))
     (when (and (not intersects)
         (int (values-type-intersection old-type ctype))
         (new (if intersects int old-type)))
     (when (null (find-uses cont))
       (setf (continuation-asserted-type cont) new))
     (when (and (not intersects)

-              (not (policy nil (= brevity 3)))) ;FIXME: really OK to suppress?
+              (not (policy *lexenv*
+                           (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?

       (compiler-warning
        "The type ~S in ~S declaration conflicts with an enclosing assertion:~%   ~S"
        (type-specifier ctype)
       (compiler-warning
        "The type ~S in ~S declaration conflicts with an enclosing assertion:~%   ~S"
        (type-specifier ctype)

@@ -2562,26 +2466,26 @@
     (make-lexenv :type-restrictions `((,cont . ,new))
                 :default lexenv)))
 
     (make-lexenv :type-restrictions `((,cont . ,new))
                 :default lexenv)))
 

+;;; Assert that FORM evaluates to the specified type (which may be a
+;;; VALUES type).
+;;;

 ;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)
 ;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
 ;;; this didn't seem to expand into an assertion, at least for ALIEN
 ;;; values. Check that SBCL doesn't have this problem.
 (def-ir1-translator the ((type value) start cont)

-  #!+sb-doc
-  "THE Type Form
-  Assert that Form evaluates to the specified type (which may be a VALUES
-  type.)"

   (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
     (ir1-convert start cont value)))
 
   (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
     (ir1-convert start cont value)))
 

+;;; This is like the THE special form, except that it believes
+;;; whatever you tell it. It will never generate a type check, but
+;;; will cause a warning if the compiler can prove the assertion is
+;;; wrong.
+;;;

 ;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
 ;;; its uses's types, setting it won't work. Instead we must intersect
 ;;; the type with the uses's DERIVED-TYPE.
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc
 ;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
 ;;; its uses's types, setting it won't work. Instead we must intersect
 ;;; the type with the uses's DERIVED-TYPE.
 (def-ir1-translator truly-the ((type value) start cont)
   #!+sb-doc

-  "Truly-The Type Value
-  Like the THE special form, except that it believes whatever you tell it. It
-  will never generate a type check, but will cause a warning if the compiler
-  can prove the assertion is wrong."

   (declare (inline member))
   (let ((type (values-specifier-type type))
        (old (find-uses cont)))
   (declare (inline member))
   (let ((type (values-specifier-type type))
        (old (find-uses cont)))

@@ -2596,11 +2500,6 @@
 ;;; otherwise look at the global information. If the name is for a
 ;;; constant, then error out.
 (def-ir1-translator setq ((&whole source &rest things) start cont)
 ;;; otherwise look at the global information. If the name is for a
 ;;; constant, then error out.
 (def-ir1-translator setq ((&whole source &rest things) start cont)

-  #!+sb-doc
-  "SETQ {Var Value}*
-  Set the variables to the values. If more than one pair is supplied, the
-  assignments are done sequentially. If Var names a symbol macro, SETF the
-  expansion."

   (let ((len (length things)))
     (when (oddp len)
       (compiler-error "odd number of args to SETQ: ~S" source))
   (let ((len (length things)))
     (when (oddp len)
       (compiler-error "odd number of args to SETQ: ~S" source))

@@ -2623,7 +2522,7 @@
                name))
             (set-variable start cont leaf (second things)))
            (cons
                name))
             (set-variable start cont leaf (second things)))
            (cons

-            (assert (eq (car leaf) 'MACRO))
+            (aver (eq (car leaf) 'MACRO))

             (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
            (heap-alien-info
             (ir1-convert start cont
             (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
            (heap-alien-info
             (ir1-convert start cont

@@ -2634,8 +2533,8 @@
               (ir1-convert-progn-body start cont (sets)))
            (sets `(setq ,(first thing) ,(second thing))))))))
 
               (ir1-convert-progn-body start cont (sets)))
            (sets `(setq ,(first thing) ,(second thing))))))))
 

-;;; Kind of like Reference-Leaf, but we generate a Set node. This
-;;; should only need to be called in Setq.
+;;; This is kind of like REFERENCE-LEAF, but we generate a SET node.
+;;; This should only need to be called in SETQ.

 (defun set-variable (start cont var value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
 (defun set-variable (start cont var value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))

@@ -2662,11 +2561,11 @@
               `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as
               `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as

-;;; the current cleanup within the body. Kind is a the kind of cleanup
-;;; to make, and Mess-Up is a form that does the mess-up action. We
-;;; make the MESS-UP be the USE of the Mess-Up form's continuation,
+;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; to make, and MESS-UP is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the MESS-UP form's continuation,

 ;;; and introduce the cleanup into the lexical environment. We
 ;;; and introduce the cleanup into the lexical environment. We

-;;; back-patch the Entry-Cleanup for the current cleanup to be the new
+;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new

 ;;; cleanup, since this inner cleanup is the interesting one.
 (def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
   (let ((dummy (make-continuation))
 ;;; cleanup, since this inner cleanup is the interesting one.
 (def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
   (let ((dummy (make-continuation))

@@ -2683,13 +2582,13 @@
 
 ;;; This is a special special form that makes an "escape function"
 ;;; which returns unknown values from named block. We convert the
 
 ;;; This is a special special form that makes an "escape function"
 ;;; which returns unknown values from named block. We convert the

-;;; function, set its kind to :Escape, and then reference it. The
+;;; function, set its kind to :ESCAPE, and then reference it. The

 ;;; :Escape kind indicates that this function's purpose is to
 ;;; represent a non-local control transfer, and that it might not
 ;;; actually have to be compiled.
 ;;;
 ;;; Note that environment analysis replaces references to escape
 ;;; :Escape kind indicates that this function's purpose is to
 ;;; represent a non-local control transfer, and that it might not
 ;;; actually have to be compiled.
 ;;;
 ;;; Note that environment analysis replaces references to escape

-;;; functions with references to the corresponding NLX-Info structure.
+;;; functions with references to the corresponding NLX-INFO structure.

 (def-ir1-translator %escape-function ((tag) start cont)
   (let ((fun (ir1-convert-lambda
              `(lambda ()
 (def-ir1-translator %escape-function ((tag) start cont)
   (let ((fun (ir1-convert-lambda
              `(lambda ()

@@ -2698,17 +2597,17 @@
     (reference-leaf start cont fun)))
 
 ;;; Yet another special special form. This one looks up a local
     (reference-leaf start cont fun)))
 
 ;;; Yet another special special form. This one looks up a local

-;;; function and smashes it to a :Cleanup function, as well as
+;;; function and smashes it to a :CLEANUP function, as well as

 ;;; referencing it.
 (def-ir1-translator %cleanup-function ((name) start cont)
   (let ((fun (lexenv-find name functions)))
 ;;; referencing it.
 (def-ir1-translator %cleanup-function ((name) start cont)
   (let ((fun (lexenv-find name functions)))

-    (assert (lambda-p fun))
+    (aver (lambda-p fun))

     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 
 ;;; We represent the possibility of the control transfer by making an
 ;;; "escape function" that does a lexical exit, and instantiate the
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 
 ;;; We represent the possibility of the control transfer by making an
 ;;; "escape function" that does a lexical exit, and instantiate the

-;;; cleanup using %within-cleanup.
+;;; cleanup using %WITHIN-CLEANUP.

 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*
 (def-ir1-translator catch ((tag &body body) start cont)
   #!+sb-doc
   "Catch Tag Form*

@@ -2728,8 +2627,8 @@
 ;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
 ;;; cleanup forms into a local function so that they can be referenced
 ;;; both in the case where we are unwound and in any local exits. We
 ;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
 ;;; cleanup forms into a local function so that they can be referenced
 ;;; both in the case where we are unwound and in any local exits. We

-;;; use %Cleanup-Function on this to indicate that reference by
-;;; %Unwind-Protect isn't "real", and thus doesn't cause creation of
+;;; use %CLEANUP-FUNCTION on this to indicate that reference by
+;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of

 ;;; an XEP.
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
 ;;; an XEP.
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc

@@ -2764,12 +2663,12 @@
 ;;;; multiple-value stuff
 
 ;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
 ;;;; multiple-value stuff
 
 ;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an

-;;; MV-Combination.
+;;; MV-COMBINATION.

 ;;;
 ;;; If there are no arguments, then we convert to a normal
 ;;;
 ;;; If there are no arguments, then we convert to a normal

-;;; combination, ensuring that a MV-Combination always has at least
+;;; combination, ensuring that a MV-COMBINATION always has at least

 ;;; one argument. This can be regarded as an optimization, but it is
 ;;; one argument. This can be regarded as an optimization, but it is

-;;; more important for simplifying compilation of MV-Combinations.
+;;; more important for simplifying compilation of MV-COMBINATIONS.

 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*
 (def-ir1-translator multiple-value-call ((fun &rest args) start cont)
   #!+sb-doc
   "MULTIPLE-VALUE-CALL Function Values-Form*

@@ -2797,16 +2696,16 @@
        (use-continuation node cont)
        (setf (basic-combination-args node) (arg-conts))))))
 
        (use-continuation node cont)
        (setf (basic-combination-args node) (arg-conts))))))
 

-;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a
+;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a

 ;;; the result code use result continuation (CONT), but transfer
 ;;; control to the evaluation of the body. In other words, the result
 ;;; the result code use result continuation (CONT), but transfer
 ;;; control to the evaluation of the body. In other words, the result

-;;; continuation isn't Immediately-Used-P by the nodes that compute
+;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute

 ;;; the result.
 ;;;
 ;;; In order to get the control flow right, we convert the result with
 ;;; a dummy result continuation, then convert all the uses of the
 ;;; the result.
 ;;;
 ;;; In order to get the control flow right, we convert the result with
 ;;; a dummy result continuation, then convert all the uses of the

-;;; dummy to be uses of CONT. If a use is an Exit, then we also
-;;; substitute CONT for the dummy in the corresponding Entry node so
+;;; dummy to be uses of CONT. If a use is an EXIT, then we also
+;;; substitute CONT for the dummy in the corresponding ENTRY node so

 ;;; that they are consistent. Note that this doesn't amount to
 ;;; changing the exit target, since the control destination of an exit
 ;;; is determined by the block successor; we are just indicating the
 ;;; that they are consistent. Note that this doesn't amount to
 ;;; changing the exit target, since the control destination of an exit
 ;;; is determined by the block successor; we are just indicating the

@@ -2819,7 +2718,7 @@
 ;;; Note that we both exploit and maintain the invariant that the CONT
 ;;; to an IR1 convert method either has no block or starts the block
 ;;; that control should transfer to after completion for the form.
 ;;; Note that we both exploit and maintain the invariant that the CONT
 ;;; to an IR1 convert method either has no block or starts the block
 ;;; that control should transfer to after completion for the form.

-;;; Nested MV-Prog1's work because during conversion of the result
+;;; Nested MV-PROG1's work because during conversion of the result

 ;;; form, we use dummy continuation whose block is the true control
 ;;; destination.
 (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
 ;;; form, we use dummy continuation whose block is the true control
 ;;; destination.
 (def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)

@@ -2842,19 +2741,24 @@
       (dolist (pred (block-pred end-block))
        (unlink-blocks pred end-block)
        (link-blocks pred cont-block))
       (dolist (pred (block-pred end-block))
        (unlink-blocks pred end-block)
        (link-blocks pred cont-block))

-      (assert (not (continuation-dest dummy-result)))
+      (aver (not (continuation-dest dummy-result)))

       (delete-continuation dummy-result)
       (remove-from-dfo end-block))))
 \f
 ;;;; interface to defining macros
 
       (delete-continuation dummy-result)
       (remove-from-dfo end-block))))
 \f
 ;;;; interface to defining macros
 

-;;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx
-;;;; functions so that we get a chance to see what is going on. We
-;;;; define IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
+;;;; FIXME:
+;;;;   classic CMU CL comment:
+;;;;     DEFMACRO and DEFUN expand into calls to %DEFxxx functions
+;;;;     so that we get a chance to see what is going on. We define
+;;;;     IR1 translators for these functions which look at the
+;;;;     definition and then generate a call to the %%DEFxxx function.
+;;;; Alas, this implementation doesn't do the right thing for
+;;;; non-toplevel uses of these forms, so this should probably
+;;;; be changed to use EVAL-WHEN instead.

 
 ;;; Return a new source path with any stuff intervening between the
 
 ;;; Return a new source path with any stuff intervening between the

-;;; current path and the first form beginning with Name stripped off.
+;;; current path and the first form beginning with NAME stripped off.

 ;;; This is used to hide the guts of DEFmumble macros to prevent
 ;;; annoying error messages.
 (defun revert-source-path (name)
 ;;; This is used to hide the guts of DEFmumble macros to prevent
 ;;; annoying error messages.
 (defun revert-source-path (name)

@@ -2880,10 +2784,12 @@
        ;; QDEF should be a sharp-quoted definition. We don't want to make a
        ;; function of it just yet, so we just drop the sharp-quote.
        (def (progn
        ;; QDEF should be a sharp-quoted definition. We don't want to make a
        ;; function of it just yet, so we just drop the sharp-quote.
        (def (progn

-              (assert (eq 'function (first qdef)))
-              (assert (proper-list-of-length-p qdef 2))
+              (aver (eq 'function (first qdef)))
+              (aver (proper-list-of-length-p qdef 2))

               (second qdef))))
 
               (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))
 

@@ -2893,7 +2799,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)

@@ -2901,12 +2808,9 @@
        (compiler-error "The special form ~S can't be redefined as a macro."
                       name)))
 
        (compiler-error "The special form ~S can't be redefined as a macro."
                       name)))
 

-    (setf (info :function :kind name) :macro)
-    (setf (info :function :where-from name) :defined)
-
-    (when *compile-time-define-macros*
-      (setf (info :function :macro-function name)
-           (coerce def 'function)))
+    (setf (info :function :kind name) :macro
+         (info :function :where-from name) :defined
+         (info :function :macro-function name) (coerce def 'function))

 
     (let* ((*current-path* (revert-source-path 'defmacro))
           (fun (ir1-convert-lambda def name)))
 
     (let* ((*current-path* (revert-source-path 'defmacro))
           (fun (ir1-convert-lambda def name)))

@@ -2917,21 +2821,37 @@
       (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
 
     (when sb!xc:*compile-print*
       (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
 
     (when sb!xc:*compile-print*

-      (compiler-mumble "converted ~S~%" name))))
+      ;; FIXME: It would be nice to convert this, and the other places
+      ;; which create compiler diagnostic output prefixed by
+      ;; semicolons, to use some common utility which automatically
+      ;; prefixes all its output with semicolons. (The addition of
+      ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
+      ;; "MNA compiler message patch", and implemented by modifying a
+      ;; bunch of output statements on a case-by-case basis, which
+      ;; seems unnecessarily error-prone and unclear, scattering
+      ;; implicit information about output style throughout the
+      ;; system.) Starting by rewriting COMPILER-MUMBLE to add
+      ;; semicolon prefixes would be a good start, and perhaps also:
+      ;;   * Add semicolon prefixes for "FOO assembled" messages emitted 
+      ;;     when e.g. src/assembly/x86/assem-rtns.lisp is processed.
+      ;;   * At least some debugger output messages deserve semicolon
+      ;;     prefixes too:
+      ;;     ** restarts table
+      ;;     ** "Within the debugger, you can type HELP for help."
+      (compiler-mumble "~&; converted ~S~%" name))))

 
 (def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
                                            start cont
                                            :kind :function)
   (let ((name (eval name))
 
 (def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
                                            start cont
                                            :kind :function)
   (let ((name (eval name))

-       (def (second def))) ; Don't want to make a function just yet...
+       (def (second def))) ; We don't want to make a function just yet...

 
     (when (eq (info :function :kind name) :special-form)
       (compiler-error "attempt to define a compiler-macro for special form ~S"
                      name))
 
 
     (when (eq (info :function :kind name) :special-form)
       (compiler-error "attempt to define a compiler-macro for special form ~S"
                      name))
 

-    (when *compile-time-define-macros*
-      (setf (info :function :compiler-macro-function name)
-           (coerce def 'function)))
+    (setf (info :function :compiler-macro-function name)
+         (coerce def 'function))

 
     (let* ((*current-path* (revert-source-path 'define-compiler-macro))
           (fun (ir1-convert-lambda def name)))
 
     (let* ((*current-path* (revert-source-path 'define-compiler-macro))
           (fun (ir1-convert-lambda def name)))

@@ -2943,42 +2863,7 @@
       (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
 
     (when sb!xc:*compile-print*
       (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
 
     (when sb!xc:*compile-print*

-      (compiler-mumble "converted ~S~%" name))))
-
-;;; Update the global environment to correspond to the new definition.
-(def-ir1-translator %defconstant ((name value doc) start cont
-                                 :kind :function)
-  (let ((name (eval name))
-       (newval (eval value)))
-    (unless (symbolp name)
-      (compiler-error "constant name not a symbol: ~S" name))
-    (when (eq name t)
-      (compiler-error "The value of T can't be changed."))
-    (when (eq name nil)
-      (compiler-error "Nihil ex nihil. (can't change NIL)"))
-    (when (keywordp name)
-      (compiler-error "Keyword values can't be changed."))
-
-    (let ((kind (info :variable :kind name)))
-      (case kind
-       (:constant
-        ;; FIXME: ANSI says EQL, not EQUALP. Perhaps make a special
-        ;; variant of this warning for the case where they're EQUALP,
-        ;; since people seem to be confused about this.
-        (unless (equalp newval (info :variable :constant-value name))
-          (compiler-warning "redefining constant ~S as:~%  ~S" name newval)))
-       (:global)
-       (t
-        (compiler-warning "redefining ~(~A~) ~S to be a constant"
-                          kind
-                          name))))
-
-    (setf (info :variable :kind name) :constant)
-    (setf (info :variable :where-from name) :defined)
-    (setf (info :variable :constant-value name) newval)
-    (remhash name *free-variables*))
-
-  (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
+      (compiler-mumble "~&; converted ~S~%" name))))

 \f
 ;;;; defining global functions
 
 \f
 ;;;; defining global functions
 

@@ -2997,12 +2882,11 @@
                                             (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)
                             macros)

-                    :cookie (lexenv-cookie *lexenv*)
-                    :interface-cookie (lexenv-interface-cookie *lexenv*))))
+                    :policy (lexenv-policy *lexenv*))))

       (ir1-convert-lambda `(lambda ,@body) name))))
 
 ;;; Return a lambda that has been "closed" with respect to ENV,
       (ir1-convert-lambda `(lambda ,@body) name))))
 
 ;;; Return a lambda that has been "closed" with respect to ENV,

@@ -3024,10 +2908,10 @@
               (when (eq x (assoc name variables :test #'eq))
                 (typecase what
                   (cons
               (when (eq x (assoc name variables :test #'eq))
                 (typecase what
                   (cons

-                   (assert (eq (car what) 'macro))
+                   (aver (eq (car what) 'macro))

                    (push x symmacs))
                   (global-var
                    (push x symmacs))
                   (global-var

-                   (assert (eq (global-var-kind what) :special))
+                   (aver (eq (global-var-kind what) :special))

                    (push `(special ,name) decls))
                   (t (return t))))))
           nil)
                    (push `(special ,name) decls))
                   (t (return t))))))
           nil)

@@ -3043,7 +2927,7 @@
                   (global-var
                    (when (defined-function-p what)
                      (push `(,(car (rassoc (defined-function-inlinep what)
                   (global-var
                    (when (defined-function-p what)
                      (push `(,(car (rassoc (defined-function-inlinep what)

-                                           inlinep-translations))
+                                           *inlinep-translations*))

                              ,name)
                            decls)))
                   (t (return t))))))
                              ,name)
                            decls)))
                   (t (return t))))))

@@ -3062,7 +2946,7 @@
         (found (find-free-function name "Eh?")))
     (note-name-defined name :function)
     (cond ((not (defined-function-p found))
         (found (find-free-function name "Eh?")))
     (note-name-defined name :function)
     (cond ((not (defined-function-p found))

-          (assert (not (info :function :inlinep name)))
+          (aver (not (info :function :inlinep name)))

           (let* ((where-from (leaf-where-from found))
                  (res (make-defined-function
                        :name name
           (let* ((where-from (leaf-where-from found))
                  (res (make-defined-function
                        :name name

@@ -3080,7 +2964,7 @@
 
 ;;; Check a new global function definition for consistency with
 ;;; previous declaration or definition, and assert argument/result
 
 ;;; Check a new global function definition for consistency with
 ;;; previous declaration or definition, and assert argument/result

-;;; types if appropriate. This this assertion is suppressed by the
+;;; types if appropriate. This assertion is suppressed by the

 ;;; EXPLICIT-CHECK attribute, which is specified on functions that
 ;;; check their argument types as a consequence of type dispatching.
 ;;; This avoids redundant checks such as NUMBERP on the args to +,
 ;;; EXPLICIT-CHECK attribute, which is specified on functions that
 ;;; check their argument types as a consequence of type dispatching.
 ;;; This avoids redundant checks such as NUMBERP on the args to +,

@@ -3091,8 +2975,15 @@
        (info (info :function :info (leaf-name var))))
     (assert-definition-type
      fun type
        (info (info :function :info (leaf-name var))))
     (assert-definition-type
      fun type

-     :error-function #'compiler-warning
-     :warning-function (cond (info #'compiler-warning)
+     ;; KLUDGE: Common Lisp is such a dynamic language that in general
+     ;; all we can do here in general is issue a STYLE-WARNING. It
+     ;; would be nice to issue a full WARNING in the special case of
+     ;; of type mismatches within a compilation unit (as in section
+     ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't
+     ;; keep track of whether the mismatched data came from the same
+     ;; compilation unit, so we can't do that. -- WHN 2001-02-11
+     :error-function #'compiler-style-warning
+     :warning-function (cond (info #'compiler-style-warning)

                             (for-real #'compiler-note)
                             (t nil))
      :really-assert
                             (for-real #'compiler-note)
                             (t nil))
      :really-assert

@@ -3158,8 +3049,8 @@
         (*current-path* (revert-source-path 'defun))
         (expansion (unless (eq (info :function :inlinep name) :notinline)
                      (inline-syntactic-closure-lambda lambda))))
         (*current-path* (revert-source-path 'defun))
         (expansion (unless (eq (info :function :inlinep name) :notinline)
                      (inline-syntactic-closure-lambda lambda))))

-    ;; If not in a simple environment or NOTINLINE, then discard any forward
-    ;; references to this function.
+    ;; If not in a simple environment or NOTINLINE, then discard any
+    ;; forward references to this function.

     (unless expansion (remhash name *free-functions*))
 
     (let* ((var (get-defined-function name))
     (unless expansion (remhash name *free-functions*))
 
     (let* ((var (get-defined-function name))

@@ -3168,8 +3059,8 @@
                                expansion)))
       (setf (defined-function-inline-expansion var) expansion)
       (setf (info :function :inline-expansion name) save-expansion)
                                expansion)))
       (setf (defined-function-inline-expansion var) expansion)
       (setf (info :function :inline-expansion name) save-expansion)

-      ;; If there is a type from a previous definition, blast it, since it is
-      ;; obsolete.
+      ;; If there is a type from a previous definition, blast it,
+      ;; since it is obsolete.

       (when (eq (leaf-where-from var) :defined)
        (setf (leaf-type var) (specifier-type 'function)))
 
       (when (eq (leaf-where-from var) :defined)
        (setf (leaf-type var) (specifier-type 'function)))
 

@@ -3186,4 +3077,4 @@
                       ,@(when save-expansion `(',save-expansion)))))
 
        (when sb!xc:*compile-print*
                       ,@(when save-expansion `(',save-expansion)))))
 
        (when sb!xc:*compile-print*

-         (compiler-mumble "converted ~S~%" name))))))
+         (compiler-mumble "~&; converted ~S~%" name))))))