0.pre7.31:

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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 268afc5..bd62c93 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -42,25 +42,12 @@
 (declaim (list *current-path*))
 (defvar *current-path* nil)
 
 (declaim (list *current-path*))
 (defvar *current-path* nil)
 

-;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to
-;;; be interpreted rather than compiled. This inhibits source
-;;; tranformations and stuff.
-(defvar *converting-for-interpreter* nil)
-;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-
-;;; FIXME: This nastiness was one of my original motivations to start
-;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
-;;; be made not the default, and perhaps should be controlled by
-;;; DECLAIM instead of a variable like this. And whether or not this
-;;; kind of checking is on, declarations should be assertions to the
-;;; extent practical, and code which can't be compiled efficiently
-;;; while adhering to that principle should give warnings.
-(defvar *derive-function-types* t
-  #!+sb-doc
-  "(Caution: Soon, this might change its semantics somewhat, or even go away.)
-  If true, argument and result type information derived from compilation of
-  DEFUNs is used when compiling calls to that function. If false, only
-  information from FTYPE proclamations will be used.")
+(defvar *derive-function-types* nil
+  "Should the compiler assume that function types will never change,
+  so that it can use type information inferred from current definitions
+  to optimize code which uses those definitions? Setting this true
+  gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
+  the efficiency of stable code.")

 \f
 ;;;; namespace management utilities
 
 \f
 ;;;; namespace management utilities
 

@@ -72,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

@@ -93,7 +86,8 @@
         (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
         (type (dd-name info))
         (slot-type (dsd-type slot)))
         (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
         (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

@@ -155,7 +149,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

@@ -197,7 +191,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))

@@ -273,7 +270,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))
 

@@ -304,15 +301,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*)

@@ -372,7 +369,7 @@
 
 ;;; This function is called on freshly read forms to record the
 ;;; initial location of each form (and subform.) Form is the form to
 
 ;;; This function is called on freshly read forms to record the
 ;;; initial location of each form (and subform.) Form is the form to

-;;; find the paths in, and TLF-Num is the top-level form number of the
+;;; find the paths in, and TLF-NUM is the top-level form number of the

 ;;; truly top-level form.
 ;;;
 ;;; This gets a bit interesting when the source code is circular. This
 ;;; truly top-level form.
 ;;;
 ;;; This gets a bit interesting when the source code is circular. This

@@ -420,8 +417,8 @@
                                `(block ,skip
                                   (catch 'ir1-error-abort
                                     (let ((*compiler-error-bailout*
                                `(block ,skip
                                   (catch 'ir1-error-abort
                                     (let ((*compiler-error-bailout*

-                                           #'(lambda ()
-                                               (throw 'ir1-error-abort nil))))
+                                           (lambda ()
+                                             (throw 'ir1-error-abort nil))))

                                       ,@body
                                       (return-from ,skip nil)))
                                   (ir1-convert ,start ,cont ,proxy)))))
                                       ,@body
                                       (return-from ,skip nil)))
                                   (ir1-convert ,start ,cont ,proxy)))))

@@ -462,8 +459,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))))))

@@ -477,7 +474,7 @@
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf
     (values))
 
   ;; Generate a reference to a manifest constant, creating a new leaf

-  ;; if necessary. If we are producing a fasl-file, make sure that
+  ;; if necessary. If we are producing a fasl file, make sure that

   ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
   ;; needs to be.
   (defun reference-constant (start cont value)
   ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
   ;; needs to be.
   (defun reference-constant (start cont value)

@@ -538,7 +535,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)))))

@@ -552,8 +549,9 @@
         (translator (info :function :ir1-convert fun))
         (cmacro (info :function :compiler-macro-function fun)))
     (cond (translator (funcall translator start cont form))
         (translator (info :function :ir1-convert fun))
         (cmacro (info :function :compiler-macro-function fun)))
     (cond (translator (funcall translator start cont form))

-         ((and cmacro (not *converting-for-interpreter*)
-               (not (eq (info :function :inlinep fun) :notinline)))
+         ((and cmacro
+               (not (eq (info :function :inlinep fun)
+                        :notinline)))

           (let ((res (careful-expand-macro cmacro form)))
             (if (eq res form)
                 (ir1-convert-global-functoid-no-cmacro start cont form fun)
           (let ((res (careful-expand-macro cmacro form)))
             (if (eq res form)
                 (ir1-convert-global-functoid-no-cmacro start cont form fun)

@@ -582,7 +580,8 @@
   (muffle-warning)
   (error "internal error -- no MUFFLE-WARNING restart"))
 
   (muffle-warning)
   (error "internal error -- no MUFFLE-WARNING restart"))
 

-;;; Trap errors during the macroexpansion.
+;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
+;;; errors which occur during the macroexpansion.

 (defun careful-expand-macro (fun form)
   (handler-bind (;; When cross-compiling, we can get style warnings
                 ;; about e.g. undefined functions. An unhandled
 (defun careful-expand-macro (fun form)
   (handler-bind (;; When cross-compiling, we can get style warnings
                 ;; about e.g. undefined functions. An unhandled

@@ -698,32 +697,26 @@
 
 ;;; Convert a call to a global function. If not :NOTINLINE, then we do
 ;;; source transforms and try out any inline expansion. If there is no
 
 ;;; Convert a call to a global function. If not :NOTINLINE, then we do
 ;;; source transforms and try out any inline expansion. If there is no

-;;; expansion, but is :INLINE, then give an efficiency note (unless a known
-;;; function which will quite possibly be open-coded.)   Next, we go to
-;;; ok-combination conversion.
+;;; expansion, but is :INLINE, then give an efficiency note (unless a
+;;; known function which will quite possibly be open-coded.) Next, we
+;;; go to ok-combination conversion.

 (defun ir1-convert-srctran (start cont var form)
   (declare (type continuation start cont) (type global-var var))
   (let ((inlinep (when (defined-function-p var)
                   (defined-function-inlinep var))))
 (defun ir1-convert-srctran (start cont var form)
   (declare (type continuation start cont) (type global-var var))
   (let ((inlinep (when (defined-function-p var)
                   (defined-function-inlinep var))))

-    (cond
-     ((eq inlinep :notinline)
-      (ir1-convert-combination start cont form var))
-     (*converting-for-interpreter*
-      (ir1-convert-combination-checking-type start cont form var))
-     (t
-      (let ((transform (info :function :source-transform (leaf-name var))))
-       (cond
-        (transform
-         (multiple-value-bind (result pass) (funcall transform form)
-           (if pass
-               (ir1-convert-maybe-predicate start cont form var)
-               (ir1-convert start cont result))))
-        (t
-         (ir1-convert-maybe-predicate start cont form var))))))))
-
-;;; If the function has the Predicate attribute, and the CONT's DEST isn't
-;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
-;;; appears in a conditional context.
+    (if (eq inlinep :notinline)
+       (ir1-convert-combination start cont form var)
+       (let ((transform (info :function :source-transform (leaf-name var))))
+         (if transform
+             (multiple-value-bind (result pass) (funcall transform form)
+               (if pass
+                   (ir1-convert-maybe-predicate start cont form var)
+                   (ir1-convert start cont result)))
+             (ir1-convert-maybe-predicate start cont form var))))))
+
+;;; If the function has the PREDICATE attribute, and the CONT's DEST
+;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
+;;; predicate always appears in a conditional context.

 ;;;
 ;;; If the function isn't a predicate, then we call
 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
 ;;;
 ;;; If the function isn't a predicate, then we call
 ;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.

@@ -817,9 +810,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 (= inhibit-warnings 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)

@@ -829,7 +822,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

@@ -878,7 +871,7 @@
       (let ((var (find-in-bindings vars name)))
        (etypecase var
          (cons
       (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))

@@ -927,7 +920,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 inhibit-warnings))
+                (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)))

@@ -989,7 +982,9 @@
 ;;; RES and returning it as a result. VARS and FVARS are as described in
 ;;; PROCESS-DECLS.
 (defun process-1-decl (raw-spec res vars fvars cont)
 ;;; RES and returning it as a result. VARS and FVARS are as described in
 ;;; PROCESS-DECLS.
 (defun process-1-decl (raw-spec res vars fvars cont)

-  (declare (list spec vars fvars) (type lexenv res) (type continuation 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))
   (let ((spec (canonized-decl-spec raw-spec)))
     (case (first spec)
       (special (process-special-decl spec res vars))

@@ -1006,12 +1001,6 @@
        (make-lexenv
        :default res
        :policy (process-optimize-decl spec (lexenv-policy res))))
        (make-lexenv
        :default res
        :policy (process-optimize-decl spec (lexenv-policy res))))

-      (optimize-interface
-       (make-lexenv
-       :default res
-       :interface-policy (process-optimize-decl
-                          spec
-                          (lexenv-interface-policy res))))

       (type
        (process-type-decl (cdr spec) res vars))
       (values
       (type
        (process-type-decl (cdr spec) res vars))
       (values

@@ -1023,7 +1012,7 @@
                               `(values ,@types))
                           cont res 'values))))
       (dynamic-extent
                               `(values ,@types))
                           cont res 'values))))
       (dynamic-extent

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

         (compiler-note
          "compiler limitation:~
            ~%  There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
         (compiler-note
          "compiler limitation:~
            ~%  There's no special support for DYNAMIC-EXTENT (so it's ignored)."))

@@ -1108,38 +1097,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)

@@ -1150,9 +1139,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))

@@ -1209,9 +1198,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))

@@ -1219,7 +1208,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)

@@ -1227,14 +1216,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)

@@ -1262,26 +1251,18 @@
 ;;; 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.
 ;;; 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 for 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)
+(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
-                            :policy (make-interface-policy *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))
 
 ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind
   (values))
 
 ;;; This is similar to IR1-CONVERT-PROGN-BODY except that code to bind

@@ -1295,13 +1276,12 @@
 ;;; 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.
 ;;; 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)
+(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))

@@ -1314,7 +1294,7 @@
       (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

@@ -1333,11 +1313,8 @@
 ;;;
 ;;; 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
 ;;;
 ;;; 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)
+;;; 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))

@@ -1369,7 +1346,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

@@ -1397,8 +1374,6 @@
 ;;; 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.
 ;;; 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.

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

@@ -1411,14 +1386,14 @@
                              :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 :policy (make-interface-policy *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))
 
          fvars arg-vars)
     fun))
 

@@ -1461,32 +1436,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.
+;;; 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.

 ;;;
 ;;;

-;;; 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.
+;;; 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.

 ;;;
 ;;;

-;;; We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
-;;;
-;;; 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)

@@ -1503,8 +1476,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 :policy (make-interface-policy *lexenv*))))
+                                       :type (specifier-type 'index))))

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

@@ -1521,7 +1493,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)))

@@ -1530,7 +1502,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))

@@ -1555,7 +1527,7 @@
 
            (body
             `(when (oddp ,n-count)
 
            (body
             `(when (oddp ,n-count)

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

 
            (body
             `(locally
 
            (body
             `(locally

@@ -1570,7 +1542,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)

@@ -1582,17 +1554,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

@@ -1656,11 +1628,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)

@@ -1677,32 +1649,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

@@ -1719,7 +1692,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 ())

@@ -1765,9 +1740,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

@@ -1792,7 +1767,7 @@
 
     res))
 
 
     res))
 

-;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf.
+;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.

 (defun ir1-convert-lambda (form &optional name)
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"
 (defun ir1-convert-lambda (form &optional name)
   (unless (consp form)
     (compiler-error "A ~S was found when expecting a lambda expression:~%  ~S"

@@ -1819,8 +1794,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)

@@ -1993,11 +1970,11 @@
       (conts cont)
 
       (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
       (conts cont)
 
       (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))

-       (mapc #'(lambda (segment start cont)
-                 (ir1-convert-progn-body start cont (rest segment)))
+       (mapc (lambda (segment start cont)
+               (ir1-convert-progn-body start cont (rest segment)))

              segments (starts) (conts))))))
 
              segments (starts) (conts))))))
 

-;;; Emit an Exit node without any value.
+;;; Emit an EXIT node without any value.

 (def-ir1-translator go ((tag) start cont)
   #!+sb-doc
   "Go Tag
 (def-ir1-translator go ((tag) start cont)
   #!+sb-doc
   "Go Tag

@@ -2014,139 +1991,76 @@
 \f
 ;;;; translators for compiler-magic special forms
 
 \f
 ;;;; translators for compiler-magic special forms
 

-;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1
-;;; convert method so that it can be shared by the special-case
-;;; top-level form processing code. We play with the dynamic
-;;; environment and eval stuff, then call Fun with a list of forms to
-;;; be processed at load time.
-;;;
-;;; Note: the EVAL situation is always ignored: this is conceptually a
-;;; compile-only implementation.
-;;;
-;;; We have to interact with the interpreter to ensure that the forms
-;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to
-;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1
-;;; conversion done by EVAL, or by conversion of the body for
-;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do
-;;; not* EVAL since some enclosing EVAL-WHEN already did.
+;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
+;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
+;;; so that they're never seen at this level.)

 ;;;
 ;;;

-;;; We know we are EVAL'ing for LOAD since we wouldn't get called
-;;; otherwise. If LOAD is a situation we call FUN on body. If we
-;;; aren't evaluating for LOAD, then we call FUN on NIL for the result
-;;; of the EVAL-WHEN.
-(defun do-eval-when-stuff (situations body fun)
-
-  (when (or (not (listp situations))
-           (set-difference situations
-                           '(compile load eval
-                             :compile-toplevel :load-toplevel :execute)))
-    (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
-
-  (let ((deprecated-names (intersection situations '(compile load eval))))
-    (when deprecated-names
-      (style-warn "using deprecated EVAL-WHEN situation names ~S"
-                 deprecated-names)))
-
-  (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
-                      (not sb!eval::*already-evaled-this*)))
-        (sb!eval::*already-evaled-this* t))
-    (when do-eval
-
-      ;; This is the natural way to do it.
-      #-(and sb-xc-host (or sbcl cmu))
-      (eval `(progn ,@body))
-
-      ;; This is a disgusting hack to work around bug IR1-3 when using
-      ;; SBCL (or CMU CL, for that matter) as a cross-compilation
-      ;; host. When we go from the cross-compiler (where we bound
-      ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which
-      ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL
-      ;; would go and execute nested EVAL-WHENs even when they're not
-      ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes
-      ;; the cross-compilation host to bind its own
-      ;; *ALREADY-EVALED-THIS* variable, so that the problem is
-      ;; suppressed.
-      ;;
-      ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if
-      ;; CMU CL doesn't fix the bug, then this hack can be made
-      ;; conditional on #+CMU.)
-      #+(and sb-xc-host (or sbcl cmu))
-      (let (#+sbcl (sb-eval::*already-evaled-this* t)
-           #+cmu (common-lisp::*already-evaled-this* t))
-       (eval `(eval-when (:compile-toplevel :load-toplevel :execute)
-                ,@body))))
-
-    (if (or (intersection '(:load-toplevel load) situations)
-           (and *converting-for-interpreter*
-                (intersection '(:execute eval) situations)))
-       (funcall fun body)
-       (funcall fun '(nil)))))
-
-(def-ir1-translator eval-when ((situations &rest body) start cont)
+;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
+;;; of non-top-level EVAL-WHENs is very simple:
+;;;   EVAL-WHEN forms cause compile-time evaluation only at top level.
+;;;   Both :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL situation specifications
+;;;   are ignored for non-top-level forms. For non-top-level forms, an
+;;;   eval-when specifying the :EXECUTE situation is treated as an
+;;;   implicit PROGN including the forms in the body of the EVAL-WHEN
+;;;   form; otherwise, the forms in the body are ignored. 
+(def-ir1-translator eval-when ((situations &rest forms) start cont)

   #!+sb-doc
   "EVAL-WHEN (Situation*) Form*
   #!+sb-doc
   "EVAL-WHEN (Situation*) Form*

-  Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
-  This is conceptually a compile-only implementation, so EVAL is a no-op."
-
-  ;; It's difficult to handle EVAL-WHENs completely correctly in the
-  ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly
-  ;; language..) Since we, the system implementors, control not only
-  ;; the cross-compiler but also the code that it processes, we can
-  ;; handle this either by making the cross-compiler smarter about
-  ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult
-  ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs
-  ;; can be generated by many macro expansions, it's not always easy
-  ;; to detect problems by skimming the source code, so we'll try to
-  ;; add some code here to help out.
-  ;;
-  ;; Nested EVAL-WHENs are tricky.
-  #+sb-xc-host
-  (labels ((contains-toplevel-eval-when-p (body-part)
-            (and (consp body-part)
-                 (or (eq (first body-part) 'eval-when)
-                     (and (member (first body-part)
-                                  '(locally macrolet progn symbol-macrolet))
-                          (some #'contains-toplevel-eval-when-p
-                                (rest body-part)))))))
-    (/show "testing for nested EVAL-WHENs" body)
-    (when (some #'contains-toplevel-eval-when-p body)
-      (compiler-style-warning "nested EVAL-WHENs in cross-compilation")))
-
-  (do-eval-when-stuff situations
-                     body
-                     (lambda (forms)
-                       (ir1-convert-progn-body start cont forms))))
-
-;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any
-;;; arguments.
-(defun do-macrolet-stuff (definitions fun)
-  (declare (list definitions) (type function fun))
-  (let ((whole (gensym "WHOLE"))
-       (environment (gensym "ENVIRONMENT")))
-    (collect ((new-fenv))
-      (dolist (def definitions)
-       (let ((name (first def))
-             (arglist (second def))
-             (body (cddr def)))
-         (unless (symbolp name)
-           (compiler-error "The local macro name ~S is not a symbol." name))
-         (when (< (length def) 2)
-           (compiler-error
-            "The list ~S is too short to be a legal local macro definition."
-            name))
-         (multiple-value-bind (body local-decs)
-             (parse-defmacro arglist whole body name 'macrolet
-                             :environment environment)
-           (new-fenv `(,(first def) macro .
-                       ,(coerce `(lambda (,whole ,environment)
-                                   ,@local-decs (block ,name ,body))
-                                'function))))))
-
-      (let ((*lexenv* (make-lexenv :functions (new-fenv))))
-       (funcall fun))))
-
+  Evaluate the Forms in the specified Situations (any of :COMPILE-TOPLEVEL,
+  :LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
+  (multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
+    (declare (ignore ct lt))
+    (ir1-convert-progn-body start cont (and e forms)))

   (values))
 
   (values))
 

+;;; common logic for MACROLET and SYMBOL-MACROLET
+;;;
+;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
+;;; in-lexenv representation, stuff the results into *LEXENV*, and
+;;; call FUN (with no arguments).
+(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
+                                      definitionize-keyword
+                                      definitions
+                                      fun)
+  (declare (type function definitionize-fun fun))
+  (declare (type (member :variables :functions) definitionize-keyword))
+  (declare (type list definitions))
+  (unless (= (length definitions)
+             (length (remove-duplicates definitions :key #'first)))
+    (compiler-style-warning "duplicate definitions in ~S" definitions))
+  (let* ((processed-definitions (mapcar definitionize-fun definitions))
+         (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+    (funcall fun)))
+
+;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
+;;; call FUN (with no arguments).
+;;;
+;;; This is split off from the IR1 convert method so that it can be
+;;; shared by the special-case top-level MACROLET processing code.
+(defun funcall-in-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (list-of-length-at-least-p definition 2)
+       (compiler-error
+       "The list ~S is too short to be a legal local macro definition."
+       definition))
+     (destructuring-bind (name arglist &body body) definition
+       (unless (symbolp name)
+        (compiler-error "The local macro name ~S is not a symbol." name))
+       (let ((whole (gensym "WHOLE"))
+            (environment (gensym "ENVIRONMENT")))
+        (multiple-value-bind (body local-decls)
+            (parse-defmacro arglist whole body name 'macrolet
+                            :environment environment)
+          `(,name macro .
+                  ,(compile nil
+                            `(lambda (,whole ,environment)
+                               ,@local-decls
+                               (block ,name ,body))))))))
+   :functions
+   definitions
+   fun))
+

 (def-ir1-translator macrolet ((definitions &rest body) start cont)
   #!+sb-doc
   "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
 (def-ir1-translator macrolet ((definitions &rest body) start cont)
   #!+sb-doc
   "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*

@@ -2154,9 +2068,34 @@
   defined. Name is the local macro name, Lambda-List is the DEFMACRO style
   destructuring lambda list, and the Forms evaluate to the expansion. The
   Forms are evaluated in the null environment."
   defined. Name is the local macro name, Lambda-List is the DEFMACRO style
   destructuring lambda list, and the Forms evaluate to the expansion. The
   Forms are evaluated in the null environment."

-  (do-macrolet-stuff definitions
-                    #'(lambda ()
-                        (ir1-convert-progn-body start cont body))))
+  (funcall-in-macrolet-lexenv definitions
+                             (lambda ()
+                               (ir1-translate-locally body start cont))))
+
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+  (%funcall-in-foomacrolet-lexenv
+   (lambda (definition)
+     (unless (proper-list-of-length-p definition 2)
+       (compiler-error "malformed symbol/expansion pair: ~S" definition))
+     (destructuring-bind (name expansion) definition
+       (unless (symbolp name)
+         (compiler-error
+          "The local symbol macro name ~S is not a symbol."
+          name))
+       `(,name . (MACRO . ,expansion))))
+   :variables
+   definitions
+   fun))
+  
+(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
+  #!+sb-doc
+  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+  Define the Names as symbol macros with the given Expansions. Within the
+  body, references to a Name will effectively be replaced with the Expansion."
+  (funcall-in-symbol-macrolet-lexenv
+   macrobindings
+   (lambda ()
+     (ir1-translate-locally body start cont))))

 
 ;;; not really a special form, but..
 (def-ir1-translator declare ((&rest stuff) start cont)
 
 ;;; not really a special form, but..
 (def-ir1-translator declare ((&rest stuff) start cont)

@@ -2180,9 +2119,6 @@
       (compiler-error "Lisp error during evaluation of info args:~%~A"
                      condition))))
 
       (compiler-error "Lisp error during evaluation of info args:~%~A"
                      condition))))
 

-;;; a hashtable that translates from primitive names to translation functions
-(defvar *primitive-translators* (make-hash-table :test 'eq))
-

 ;;; If there is a primitive translator, then we expand the call.
 ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
 ;;; argument is the template, the second is a list of the results of
 ;;; If there is a primitive translator, then we expand the call.
 ;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
 ;;; argument is the template, the second is a list of the results of

@@ -2193,60 +2129,53 @@
 ;;; a fatal error during IR2 conversion.
 ;;;
 ;;; KLUDGE: It's confusing having multiple names floating around for
 ;;; a fatal error during IR2 conversion.
 ;;;
 ;;; KLUDGE: It's confusing having multiple names floating around for

-;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be
-;;; possible to reimplement BYTE-BLT (the only use of
-;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive
-;;; translators altogether, so that there would be no distinction
-;;; between primitives and vops? Then we could call primitives vops,
-;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to
-;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906
-;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I
-;;; think BYTE-BLT could probably just become an inline function.
-(def-ir1-translator %primitive ((&whole form name &rest args) start cont)
-
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Now that CMU
+;;; CL's *PRIMITIVE-TRANSLATORS* stuff is gone, we could call
+;;; primitives VOPs, rename TEMPLATE to VOP-TEMPLATE, rename
+;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
+;;; VOP or %VOP.. -- WHN 2001-06-11
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
+(def-ir1-translator %primitive ((name &rest args) start cont)

   (unless (symbolp name)
     (compiler-error "The primitive name ~S is not a symbol." name))
 
   (unless (symbolp name)
     (compiler-error "The primitive name ~S is not a symbol." name))
 

-  (let* ((translator (gethash name *primitive-translators*)))
-    (if translator
-       (ir1-convert start cont (funcall translator (cdr form)))
-       (let* ((template (or (gethash name *backend-template-names*)
-                            (compiler-error
-                             "The primitive name ~A is not defined."
-                             name)))
-              (required (length (template-arg-types template)))
-              (info (template-info-arg-count template))
-              (min (+ required info))
-              (nargs (length args)))
-         (if (template-more-args-type template)
-             (when (< nargs min)
-               (compiler-error "Primitive ~A was called with ~R argument~:P, ~
-                                but wants at least ~R."
-                               name
-                               nargs
-                               min))
-             (unless (= nargs min)
-               (compiler-error "Primitive ~A was called with ~R argument~:P, ~
-                                but wants exactly ~R."
-                               name
-                               nargs
-                               min)))
-
-         (when (eq (template-result-types template) :conditional)
-           (compiler-error
-            "%PRIMITIVE was used with a conditional template."))
-
-         (when (template-more-results-type template)
-           (compiler-error
-            "%PRIMITIVE was used with an unknown values template."))
-
-         (ir1-convert start
-                      cont
-                     `(%%primitive ',template
-                                   ',(eval-info-args
-                                      (subseq args required min))
-                                   ,@(subseq args 0 required)
-                                   ,@(subseq args min)))))))
+  (let* ((template (or (gethash name *backend-template-names*)
+                      (compiler-error
+                       "The primitive name ~A is not defined."
+                       name)))
+        (required (length (template-arg-types template)))
+        (info (template-info-arg-count template))
+        (min (+ required info))
+        (nargs (length args)))
+    (if (template-more-args-type template)
+       (when (< nargs min)
+         (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+                          but wants at least ~R."
+                         name
+                         nargs
+                         min))
+       (unless (= nargs min)
+         (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+                          but wants exactly ~R."
+                         name
+                         nargs
+                         min)))
+
+    (when (eq (template-result-types template) :conditional)
+      (compiler-error
+       "%PRIMITIVE was used with a conditional template."))
+
+    (when (template-more-results-type template)
+      (compiler-error
+       "%PRIMITIVE was used with an unknown values template."))
+
+    (ir1-convert start
+                cont
+                `(%%primitive ',template
+                              ',(eval-info-args
+                                 (subseq args required min))
+                              ,@(subseq args 0 required)
+                              ,@(subseq args min)))))

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

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

-;;;; symbol macros
-
-(def-ir1-translator symbol-macrolet ((specs &body body) start cont)
-  #!+sb-doc
-  "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
-  Define the Names as symbol macros with the given Expansions. Within the
-  body, references to a Name will effectively be replaced with the Expansion."
-  (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
-    (collect ((res))
-      (dolist (spec specs)
-       (unless (proper-list-of-length-p spec 2)
-         (compiler-error "The symbol macro binding ~S is malformed." spec))
-       (let ((name (first spec))
-             (def (second spec)))
-         (unless (symbolp name)
-           (compiler-error "The symbol macro name ~S is not a symbol." name))
-         (when (assoc name (res) :test #'eq)
-           (compiler-style-warning
-            "The name ~S occurs more than once in SYMBOL-MACROLET."
-            name))
-         (res `(,name . (MACRO . ,def)))))
-
-      (let* ((*lexenv* (make-lexenv :variables (res)))
-            (*lexenv* (process-decls decls (res) nil cont)))
-       (ir1-convert-progn-body start cont forms)))))
-\f

 ;;; This is a frob that DEFSTRUCT expands into to establish the compiler
 ;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do
 ;;; most of the work, we just clear all of the functions out of
 ;;; This is a frob that DEFSTRUCT expands into to establish the compiler
 ;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do
 ;;; most of the work, we just clear all of the functions out of

@@ -2438,31 +2341,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))

@@ -2572,13 +2480,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 (= inhibit-warnings 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)

@@ -2643,7 +2552,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

@@ -2722,7 +2631,7 @@
 ;;; 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)))
 
     (setf (functional-kind fun) :cleanup)
     (reference-leaf start cont fun)))
 

@@ -2862,7 +2771,7 @@
       (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
       (delete-continuation dummy-result)
       (remove-from-dfo end-block))))
 \f

@@ -2905,10 +2814,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))
 

@@ -2918,7 +2829,8 @@
        (remhash name *free-functions*)
        (undefine-function-name name)
        (compiler-warning
        (remhash name *free-functions*)
        (undefine-function-name name)
        (compiler-warning

-       "~S is being redefined as a macro when it was previously ~(~A~) to be a function."
+       "~S is being redefined as a macro when it was ~
+         previously ~(~A~) to be a function."

        name
        (info :function :where-from name)))
       (:macro)
        name
        (info :function :where-from name)))
       (:macro)

@@ -3000,12 +2912,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)

-                    :policy (lexenv-policy *lexenv*)
-                    :interface-policy (lexenv-interface-policy *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,

@@ -3027,10 +2938,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)

@@ -3065,7 +2976,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

@@ -3101,9 +3012,6 @@
      ;; 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
      ;; 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

-     ;;
-     ;; FIXME: Actually, I think we could issue a full WARNING if the
-     ;; new definition contradicts a DECLAIM FTYPE.

      :error-function #'compiler-style-warning
      :warning-function (cond (info #'compiler-style-warning)
                             (for-real #'compiler-note)
      :error-function #'compiler-style-warning
      :warning-function (cond (info #'compiler-style-warning)
                             (for-real #'compiler-note)