0.pre7.31:

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

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 5c292b2..18220b1 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -96,14 +96,14 @@
 ;;; has changed.
 (declaim (ftype (function (node continuation) (values)) add-continuation-use))
 (defun add-continuation-use (node cont)
 ;;; has changed.
 (declaim (ftype (function (node continuation) (values)) add-continuation-use))
 (defun add-continuation-use (node cont)

-  (assert (not (node-cont node)))
+  (aver (not (node-cont node)))

   (let ((block (continuation-block cont)))
     (ecase (continuation-kind cont)
       (:deleted)
       (:unused
   (let ((block (continuation-block cont)))
     (ecase (continuation-kind cont)
       (:deleted)
       (:unused

-       (assert (not block))
+       (aver (not block))

        (let ((block (node-block node)))
        (let ((block (node-block node)))

-        (assert block)
+        (aver block)

         (setf (continuation-block cont) block))
        (setf (continuation-kind cont) :inside-block)
        (setf (continuation-use cont) node))
         (setf (continuation-block cont) block))
        (setf (continuation-kind cont) :inside-block)
        (setf (continuation-use cont) node))

@@ -135,7 +135,7 @@
 ;;; potential optimization opportunities.
 (defun substitute-continuation (new old)
   (declare (type continuation old new))
 ;;; potential optimization opportunities.
 (defun substitute-continuation (new old)
   (declare (type continuation old new))

-  (assert (not (continuation-dest new)))
+  (aver (not (continuation-dest new)))

   (let ((dest (continuation-dest old)))
     (etypecase dest
       ((or ref bind))
   (let ((dest (continuation-dest old)))
     (etypecase dest
       ((or ref bind))

@@ -153,9 +153,10 @@
     (setf (continuation-dest new) dest))
   (values))
 
     (setf (continuation-dest new) dest))
   (values))
 

-;;; Replace all uses of Old with uses of New, where New has an arbitary
-;;; number of uses. If New will end up with more than one use, then we must
-;;; arrange for it to start a block if it doesn't already.
+;;; Replace all uses of OLD with uses of NEW, where NEW has an
+;;; arbitary number of uses. If NEW will end up with more than one
+;;; use, then we must arrange for it to start a block if it doesn't
+;;; already.

 (defun substitute-continuation-uses (new old)
   (declare (type continuation old new))
   (unless (and (eq (continuation-kind new) :unused)
 (defun substitute-continuation-uses (new old)
   (declare (type continuation old new))
   (unless (and (eq (continuation-kind new) :unused)

@@ -165,25 +166,28 @@
   (do-uses (node old)
     (delete-continuation-use node)
     (add-continuation-use node new))
   (do-uses (node old)
     (delete-continuation-use node)
     (add-continuation-use node new))

+  (dolist (lexenv-use (continuation-lexenv-uses old))
+    (setf (cadr lexenv-use) new))

 
   (reoptimize-continuation new)
   (values))
 \f
 ;;;; block starting/creation
 
 
   (reoptimize-continuation new)
   (values))
 \f
 ;;;; block starting/creation
 

-;;; Return the block that Continuation is the start of, making a block if
-;;; necessary. This function is called by IR1 translators which may cause a
-;;; continuation to be used more than once. Every continuation which may be
-;;; used more than once must start a block by the time that anyone does a
-;;; Use-Continuation on it.
+;;; Return the block that CONT is the start of, making a block if
+;;; necessary. This function is called by IR1 translators which may
+;;; cause a continuation to be used more than once. Every continuation
+;;; which may be used more than once must start a block by the time
+;;; that anyone does a USE-CONTINUATION on it.

 ;;;
 ;;; We also throw the block into the next/prev list for the
 ;;;
 ;;; We also throw the block into the next/prev list for the

-;;; *current-component* so that we keep track of which blocks we have made.
+;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
+;;; made.

 (defun continuation-starts-block (cont)
   (declare (type continuation cont))
   (ecase (continuation-kind cont)
     (:unused
 (defun continuation-starts-block (cont)
   (declare (type continuation cont))
   (ecase (continuation-kind cont)
     (:unused

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

      (let* ((head (component-head *current-component*))
            (next (block-next head))
            (new-block (make-block cont)))
      (let* ((head (component-head *current-component*))
            (next (block-next head))
            (new-block (make-block cont)))

@@ -269,28 +273,28 @@
   #!-sb-fluid (declare (inline node-home-lambda))
   (lambda-environment (node-home-lambda (block-last block))))
 
   #!-sb-fluid (declare (inline node-home-lambda))
   (lambda-environment (node-home-lambda (block-last block))))
 

-;;; Return the Top Level Form number of path, i.e. the ordinal number of
-;;; its orignal source's top-level form in its compilation unit.
+;;; Return the Top Level Form number of path, i.e. the ordinal number
+;;; of its original source's top-level form in its compilation unit.

 (defun source-path-tlf-number (path)
   (declare (list path))
   (car (last path)))
 
 (defun source-path-tlf-number (path)
   (declare (list path))
   (car (last path)))
 

-;;; Return the (reversed) list for the path in the orignal source (with the
-;;; TLF number last.)
+;;; Return the (reversed) list for the path in the original source
+;;; (with the Top Level Form number last).

 (defun source-path-original-source (path)
   (declare (list path) (inline member))
   (cddr (member 'original-source-start path :test #'eq)))
 
 (defun source-path-original-source (path)
   (declare (list path) (inline member))
   (cddr (member 'original-source-start path :test #'eq)))
 

-;;; Return the Form Number of Path's orignal source inside the Top Level
-;;; Form that contains it. This is determined by the order that we walk the
-;;; subforms of the top level source form.
+;;; Return the Form Number of Path's original source inside the Top
+;;; Level Form that contains it. This is determined by the order that
+;;; we walk the subforms of the top level source form.

 (defun source-path-form-number (path)
   (declare (list path) (inline member))
   (cadr (member 'original-source-start path :test #'eq)))
 
 (defun source-path-form-number (path)
   (declare (list path) (inline member))
   (cadr (member 'original-source-start path :test #'eq)))
 

-;;; Return a list of all the enclosing forms not in the original source that
-;;; converted to get to this form, with the immediate source for node at the
-;;; start of the list.
+;;; Return a list of all the enclosing forms not in the original
+;;; source that converted to get to this form, with the immediate
+;;; source for node at the start of the list.

 (defun source-path-forms (path)
   (subseq path 0 (position 'original-source-start path)))
 
 (defun source-path-forms (path)
   (subseq path 0 (position 'original-source-start path)))
 

@@ -303,24 +307,23 @@
        (first forms)
        (values (find-original-source path)))))
 
        (first forms)
        (values (find-original-source path)))))
 

-;;; Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise
-;;; NIL, NIL.
+;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
+;;; otherwise NIL, NIL.

 (defun continuation-source (cont)
   (let ((use (continuation-use cont)))
     (if use
        (values (node-source-form use) t)
        (values nil nil))))
 \f
 (defun continuation-source (cont)
   (let ((use (continuation-use cont)))
     (if use
        (values (node-source-form use) t)
        (values nil nil))))
 \f

-;;; Return a new LEXENV just like Default except for the specified slot
-;;; values. Values for the alist slots are NCONC'ed to the beginning of the
-;;; current value, rather than replacing it entirely.
+;;; Return a new LEXENV just like DEFAULT except for the specified
+;;; slot values. Values for the alist slots are NCONCed to the
+;;; beginning of the current value, rather than replacing it entirely.

 (defun make-lexenv (&key (default *lexenv*)
                         functions variables blocks tags type-restrictions
                         options
                         (lambda (lexenv-lambda default))
                         (cleanup (lexenv-cleanup default))
 (defun make-lexenv (&key (default *lexenv*)
                         functions variables blocks tags type-restrictions
                         options
                         (lambda (lexenv-lambda default))
                         (cleanup (lexenv-cleanup default))

-                        (cookie (lexenv-cookie default))
-                        (interface-cookie (lexenv-interface-cookie default)))
+                        (policy (lexenv-policy default)))

   (macrolet ((frob (var slot)
               `(let ((old (,slot default)))
                  (if ,var
   (macrolet ((frob (var slot)
               `(let ((old (,slot default)))
                  (if ,var

@@ -332,26 +335,12 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)

-     lambda cleanup cookie interface-cookie
+     lambda cleanup policy 

      (frob options lexenv-options))))
      (frob options lexenv-options))))

-
-;;; Return a cookie that defaults any unsupplied optimize qualities in the
-;;; Interface-Cookie with the corresponding ones from the Cookie.
-(defun make-interface-cookie (lexenv)
-  (declare (type lexenv lexenv))
-  (let ((icookie (lexenv-interface-cookie lexenv))
-       (cookie (lexenv-cookie lexenv)))
-    (make-cookie
-     :speed (or (cookie-speed icookie) (cookie-speed cookie))
-     :space (or (cookie-space icookie) (cookie-space cookie))
-     :safety (or (cookie-safety icookie) (cookie-safety cookie))
-     :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
-     :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
-     :debug (or (cookie-debug icookie) (cookie-debug cookie)))))

 \f
 ;;;; flow/DFO/component hackery
 
 \f
 ;;;; flow/DFO/component hackery
 

-;;; Join Block1 and Block2.
+;;; Join BLOCK1 and BLOCK2.

 #!-sb-fluid (declaim (inline link-blocks))
 (defun link-blocks (block1 block2)
   (declare (type cblock block1 block2))
 #!-sb-fluid (declaim (inline link-blocks))
 (defun link-blocks (block1 block2)
   (declare (type cblock block1 block2))

@@ -364,7 +353,7 @@
 (defun %link-blocks (block1 block2)
   (declare (type cblock block1 block2) (inline member))
   (let ((succ1 (block-succ block1)))
 (defun %link-blocks (block1 block2)
   (declare (type cblock block1 block2) (inline member))
   (let ((succ1 (block-succ block1)))

-    (assert (not (member block2 succ1 :test #'eq)))
+    (aver (not (member block2 succ1 :test #'eq)))

     (cons block2 succ1)))
 
 ;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a
     (cons block2 succ1)))
 
 ;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a

@@ -380,7 +369,7 @@
             (prev succ1 succ))
            ((eq (car succ) block2)
             (setf (cdr prev) (cdr succ)))
             (prev succ1 succ))
            ((eq (car succ) block2)
             (setf (cdr prev) (cdr succ)))

-         (assert succ))))
+         (aver succ))))

 
   (let ((new-pred (delq block1 (block-pred block2))))
     (setf (block-pred block2) new-pred)
 
   (let ((new-pred (delq block1 (block-pred block2))))
     (setf (block-pred block2) new-pred)

@@ -441,7 +430,7 @@
   (declare (type cblock block after))
   (let ((next (block-next after))
        (comp (block-component after)))
   (declare (type cblock block after))
   (let ((next (block-next after))
        (comp (block-component after)))

-    (assert (not (eq (component-kind comp) :deleted)))
+    (aver (not (eq (component-kind comp) :deleted)))

     (setf (block-component block) comp)
     (setf (block-next after) block)
     (setf (block-prev block) after)
     (setf (block-component block) comp)
     (setf (block-next after) block)
     (setf (block-prev block) after)

@@ -485,7 +474,7 @@
         (last (block-last block))
         (last-cont (node-cont last)))
     (unless (eq last node)
         (last (block-last block))
         (last-cont (node-cont last)))
     (unless (eq last node)

-      (assert (and (eq (continuation-kind start) :inside-block)
+      (aver (and (eq (continuation-kind start) :inside-block)

                   (not (block-delete-p block))))
       (let* ((succ (block-succ block))
             (new-block
                   (not (block-delete-p block))))
       (let* ((succ (block-succ block))
             (new-block

@@ -568,8 +557,8 @@
 ;;; be called on functions that never had any references, since otherwise
 ;;; DELETE-REF will handle the deletion.
 (defun delete-functional (fun)
 ;;; be called on functions that never had any references, since otherwise
 ;;; DELETE-REF will handle the deletion.
 (defun delete-functional (fun)

-  (assert (and (null (leaf-refs fun))
-              (not (functional-entry-function fun))))
+  (aver (and (null (leaf-refs fun))
+            (not (functional-entry-function fun))))

   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))
   (etypecase fun
     (optional-dispatch (delete-optional-dispatch fun))
     (clambda (delete-lambda fun)))

@@ -594,7 +583,7 @@
   (declare (type clambda leaf))
   (let ((kind (functional-kind leaf))
        (bind (lambda-bind leaf)))
   (declare (type clambda leaf))
   (let ((kind (functional-kind leaf))
        (bind (lambda-bind leaf)))

-    (assert (not (member kind '(:deleted :optional :top-level))))
+    (aver (not (member kind '(:deleted :optional :top-level))))

     (setf (functional-kind leaf) :deleted)
     (setf (lambda-bind leaf) nil)
     (dolist (let (lambda-lets leaf))
     (setf (functional-kind leaf) :deleted)
     (setf (lambda-bind leaf) nil)
     (dolist (let (lambda-lets leaf))

@@ -607,7 +596,7 @@
        (let* ((bind-block (node-block bind))
               (component (block-component bind-block))
               (return (lambda-return leaf)))
        (let* ((bind-block (node-block bind))
               (component (block-component bind-block))
               (return (lambda-return leaf)))

-         (assert (null (leaf-refs leaf)))
+         (aver (null (leaf-refs leaf)))

          (unless (leaf-ever-used leaf)
            (let ((*compiler-error-context* bind))
              (compiler-note "deleting unused function~:[.~;~:*~%  ~S~]"
          (unless (leaf-ever-used leaf)
            (let ((*compiler-error-context* bind))
              (compiler-note "deleting unused function~:[.~;~:*~%  ~S~]"

@@ -652,12 +641,12 @@
   (declare (type optional-dispatch leaf))
   (let ((entry (functional-entry-function leaf)))
     (unless (and entry (leaf-refs entry))
   (declare (type optional-dispatch leaf))
   (let ((entry (functional-entry-function leaf)))
     (unless (and entry (leaf-refs entry))

-      (assert (or (not entry) (eq (functional-kind entry) :deleted)))
+      (aver (or (not entry) (eq (functional-kind entry) :deleted)))

       (setf (functional-kind leaf) :deleted)
 
       (flet ((frob (fun)
               (unless (eq (functional-kind fun) :deleted)
       (setf (functional-kind leaf) :deleted)
 
       (flet ((frob (fun)
               (unless (eq (functional-kind fun) :deleted)

-                (assert (eq (functional-kind fun) :optional))
+                (aver (eq (functional-kind fun) :optional))

                 (setf (functional-kind fun) nil)
                 (let ((refs (leaf-refs fun)))
                   (cond ((null refs)
                 (setf (functional-kind fun) nil)
                 (let ((refs (leaf-refs fun)))
                   (cond ((null refs)

@@ -693,7 +682,7 @@
             (clambda
              (ecase (functional-kind leaf)
                ((nil :let :mv-let :assignment :escape :cleanup)
             (clambda
              (ecase (functional-kind leaf)
                ((nil :let :mv-let :assignment :escape :cleanup)

-                (assert (not (functional-entry-function leaf)))
+                (aver (not (functional-entry-function leaf)))

                 (delete-lambda leaf))
                (:external
                 (delete-lambda leaf))
                 (delete-lambda leaf))
                (:external
                 (delete-lambda leaf))

@@ -727,7 +716,7 @@
   (declare (type continuation cont))
 
   (unless (eq (continuation-kind cont) :deleted)
   (declare (type continuation cont))
 
   (unless (eq (continuation-kind cont) :deleted)

-    (assert (continuation-dest cont))
+    (aver (continuation-dest cont))

     (setf (continuation-dest cont) nil)
     (do-uses (use cont)
       (let ((prev (node-prev use)))
     (setf (continuation-dest cont) nil)
     (do-uses (use cont)
       (let ((prev (node-prev use)))

@@ -763,7 +752,7 @@
 ;;; people to ignore them, and to cause them to be deleted eventually.
 (defun delete-continuation (cont)
   (declare (type continuation cont))
 ;;; people to ignore them, and to cause them to be deleted eventually.
 (defun delete-continuation (cont)
   (declare (type continuation cont))

-  (assert (not (eq (continuation-kind cont) :deleted)))
+  (aver (not (eq (continuation-kind cont) :deleted)))

 
   (do-uses (use cont)
     (let ((prev (node-prev use)))
 
   (do-uses (use cont)
     (let ((prev (node-prev use)))

@@ -794,16 +783,17 @@
 
   (values))
 
 
   (values))
 

-;;; This function does what is necessary to eliminate the code in it from
-;;; the IR1 representation. This involves unlinking it from its predecessors
-;;; and successors and deleting various node-specific semantic information.
+;;; This function does what is necessary to eliminate the code in it
+;;; from the IR1 representation. This involves unlinking it from its
+;;; predecessors and successors and deleting various node-specific
+;;; semantic information.

 ;;;
 ;;;

-;;; We mark the Start as has having no next and remove the last node from
-;;; its Cont's uses. We also flush the DEST for all continuations whose values
-;;; are received by nodes in the block.
+;;; We mark the START as has having no next and remove the last node
+;;; from its CONT's uses. We also flush the DEST for all continuations
+;;; whose values are received by nodes in the block.

 (defun delete-block (block)
   (declare (type cblock block))
 (defun delete-block (block)
   (declare (type cblock block))

-  (assert (block-component block) () "Block is already deleted.")
+  (aver (block-component block)) ; else block is already deleted!

   (note-block-deletion block)
   (setf (block-delete-p block) t)
 
   (note-block-deletion block)
   (setf (block-delete-p block) t)
 

@@ -844,8 +834,7 @@
       (bind
        (let ((lambda (bind-lambda node)))
         (unless (eq (functional-kind lambda) :deleted)
       (bind
        (let ((lambda (bind-lambda node)))
         (unless (eq (functional-kind lambda) :deleted)

-          (assert (member (functional-kind lambda)
-                          '(:let :mv-let :assignment)))
+          (aver (member (functional-kind lambda) '(:let :mv-let :assignment)))

           (delete-lambda lambda))))
       (exit
        (let ((value (exit-value node))
           (delete-lambda lambda))))
       (exit
        (let ((value (exit-value node))

@@ -874,7 +863,7 @@
 (defun delete-return (node)
   (declare (type creturn node))
   (let ((fun (return-lambda node)))
 (defun delete-return (node)
   (declare (type creturn node))
   (let ((fun (return-lambda node)))

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

     (setf (lambda-return fun) nil))
   (values))
 
     (setf (lambda-return fun) nil))
   (values))
 

@@ -886,7 +875,7 @@
     (unless (or (leaf-ever-used var)
                (lambda-var-ignorep var))
       (let ((*compiler-error-context* (lambda-bind fun)))
     (unless (or (leaf-ever-used var)
                (lambda-var-ignorep var))
       (let ((*compiler-error-context* (lambda-bind fun)))

-       (unless (policy *compiler-error-context* (= brevity 3))
+       (unless (policy *compiler-error-context* (= inhibit-warnings 3))

          ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
          ;; requires this to be a STYLE-WARNING.
          (compiler-style-warning "The variable ~S is defined but never used."
          ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
          ;; requires this to be a STYLE-WARNING.
          (compiler-style-warning "The variable ~S is defined but never used."

@@ -986,7 +975,7 @@
     (unless (eq (continuation-kind cont) :deleted)
       (delete-continuation-use node)
       (when (eq (continuation-kind cont) :unused)
     (unless (eq (continuation-kind cont) :deleted)
       (delete-continuation-use node)
       (when (eq (continuation-kind cont) :unused)

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

        (delete-continuation cont)))
 
     (setf (block-type-asserted block) t)
        (delete-continuation cont)))
 
     (setf (block-type-asserted block) t)

@@ -1004,11 +993,11 @@
           (setf (node-prev node) nil)
           nil)
          (t
           (setf (node-prev node) nil)
           nil)
          (t

-          (assert (eq prev-kind :block-start))
-          (assert (eq node last))
+          (aver (eq prev-kind :block-start))
+          (aver (eq node last))

           (let* ((succ (block-succ block))
                  (next (first succ)))
           (let* ((succ (block-succ block))
                  (next (first succ)))

-            (assert (and succ (null (cdr succ))))
+            (aver (and succ (null (cdr succ))))

             (cond
              ((member block succ)
               (with-ir1-environment node
             (cond
              ((member block succ)
               (with-ir1-environment node

@@ -1021,8 +1010,8 @@
               (setf (node-prev node) nil)
               nil)
              (t
               (setf (node-prev node) nil)
               nil)
              (t

-              (assert (eq (block-start-cleanup block)
-                          (block-end-cleanup block)))
+              (aver (eq (block-start-cleanup block)
+                        (block-end-cleanup block)))

               (unlink-blocks block next)
               (dolist (pred (block-pred block))
                 (change-block-successor pred block next))
               (unlink-blocks block next)
               (dolist (pred (block-pred block))
                 (change-block-successor pred block next))

@@ -1051,7 +1040,7 @@
 ;;; deletion.
 (defun delete-component (component)
   (declare (type component component))
 ;;; deletion.
 (defun delete-component (component)
   (declare (type component component))

-  (assert (null (component-new-functions component)))
+  (aver (null (component-new-functions component)))

   (setf (component-kind component) :deleted)
   (do-blocks (block component)
     (setf (block-delete-p block) t))
   (setf (component-kind component) :deleted)
   (do-blocks (block component)
     (setf (block-delete-p block) t))

@@ -1084,7 +1073,7 @@
           (type index num-args))
   (let ((outside (continuation-dest cont))
        (inside (continuation-use cont)))
           (type index num-args))
   (let ((outside (continuation-dest cont))
        (inside (continuation-use cont)))

-    (assert (combination-p outside))
+    (aver (combination-p outside))

     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))

@@ -1227,7 +1216,7 @@
 ;;; Return the COMBINATION node that is the call to the let Fun.
 (defun let-combination (fun)
   (declare (type clambda fun))
 ;;; Return the COMBINATION node that is the call to the let Fun.
 (defun let-combination (fun)
   (declare (type clambda fun))

-  (assert (member (functional-kind fun) '(:let :mv-let)))
+  (aver (member (functional-kind fun) '(:let :mv-let)))

   (continuation-dest (node-cont (first (leaf-refs fun)))))
 
 ;;; Return the initial value continuation for a let variable or NIL if none.
   (continuation-dest (node-cont (first (leaf-refs fun)))))
 
 ;;; Return the initial value continuation for a let variable or NIL if none.

@@ -1241,7 +1230,7 @@
 #!-sb-fluid (declaim (inline combination-lambda))
 (defun combination-lambda (call)
   (declare (type basic-combination call))
 #!-sb-fluid (declaim (inline combination-lambda))
 (defun combination-lambda (call)
   (declare (type basic-combination call))

-  (assert (eq (basic-combination-kind call) :local))
+  (aver (eq (basic-combination-kind call) :local))

   (ref-leaf (continuation-use (basic-combination-fun call))))
 
 (defvar *inline-expansion-limit* 200
   (ref-leaf (continuation-use (basic-combination-fun call))))
 
 (defvar *inline-expansion-limit* 200

@@ -1269,21 +1258,26 @@
 
 (declaim (special *current-path*))
 
 
 (declaim (special *current-path*))
 

-;;; We bind print level and length when printing out messages so that we don't
-;;; dump huge amounts of garbage.
+;;; We bind print level and length when printing out messages so that
+;;; we don't dump huge amounts of garbage.
+;;;
+;;; FIXME: It's not possible to get the defaults right for everyone.
+;;; So: Should these variables be in the SB-EXT package? Or should we
+;;; just get rid of them completely and just use the bare
+;;; CL:*PRINT-FOO* variables instead?

 (declaim (type (or unsigned-byte null)
               *compiler-error-print-level*
               *compiler-error-print-length*
               *compiler-error-print-lines*))
 (declaim (type (or unsigned-byte null)
               *compiler-error-print-level*
               *compiler-error-print-length*
               *compiler-error-print-lines*))

-(defvar *compiler-error-print-level* 3
+(defvar *compiler-error-print-level* 5

   #!+sb-doc
   #!+sb-doc

-  "The value for *PRINT-LEVEL* when printing compiler error messages.")
-(defvar *compiler-error-print-length* 5
+  "the value for *PRINT-LEVEL* when printing compiler error messages")
+(defvar *compiler-error-print-length* 10

   #!+sb-doc
   #!+sb-doc

-  "The value for *PRINT-LENGTH* when printing compiler error messages.")
-(defvar *compiler-error-print-lines* 5
+  "the value for *PRINT-LENGTH* when printing compiler error messages")
+(defvar *compiler-error-print-lines* 12

   #!+sb-doc
   #!+sb-doc

-  "The value for *PRINT-LINES* when printing compiler error messages.")
+  "the value for *PRINT-LINES* when printing compiler error messages")

 
 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
 
 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc

@@ -1303,7 +1297,8 @@
 (defstruct (compiler-error-context
            #-no-ansi-print-object
            (:print-object (lambda (x stream)
 (defstruct (compiler-error-context
            #-no-ansi-print-object
            (:print-object (lambda (x stream)

-                            (print-unreadable-object (x stream :type t)))))
+                            (print-unreadable-object (x stream :type t))))
+           (:copier nil))

   ;; A list of the stringified CARs of the enclosing non-original source forms
   ;; exceeding the *enclosing-source-cutoff*.
   (enclosing-source nil :type list)
   ;; A list of the stringified CARs of the enclosing non-original source forms
   ;; exceeding the *enclosing-source-cutoff*.
   (enclosing-source nil :type list)

@@ -1401,7 +1396,7 @@
            (current (rest rpath)))
        (loop
          (when (atom form)
            (current (rest rpath)))
        (loop
          (when (atom form)

-           (assert (null current))
+           (aver (null current))

            (return))
          (let ((head (first form)))
            (when (symbolp head)
            (return))
          (let ((head (first form)))
            (when (symbolp head)

@@ -1420,7 +1415,7 @@
               (values '(unable to locate source)
                       '((some strange place)))))))))
 
               (values '(unable to locate source)
                       '((some strange place)))))))))
 

-;;; Convert a source form to a string, formatted suitably for use in
+;;; Convert a source form to a string, suitably formatted for use in

 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (let ((*print-level* *compiler-error-print-level*)
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (let ((*print-level* *compiler-error-print-level*)

@@ -1428,13 +1423,14 @@
        (*print-lines* *compiler-error-print-lines*)
        (*print-pretty* pretty))
     (if pretty
        (*print-lines* *compiler-error-print-lines*)
        (*print-pretty* pretty))
     (if pretty

-       (format nil "  ~S~%" form)
+       (format nil "~<~@;  ~S~:>" (list form))

        (prin1-to-string form))))
 
        (prin1-to-string form))))
 

-;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error
-;;; context, or NIL if we can't figure anything out. ARGS is a list of things
-;;; that are going to be printed out in the error message, and can thus be
-;;; blown off when they appear in the source context.
+;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
+;;; error context, or NIL if we can't figure anything out. ARGS is a
+;;; list of things that are going to be printed out in the error
+;;; message, and can thus be blown off when they appear in the source
+;;; context.

 (defun find-error-context (args)
   (let ((context *compiler-error-context*))
     (if (compiler-error-context-p context)
 (defun find-error-context (args)
   (let ((context *compiler-error-context*))
     (if (compiler-error-context-p context)

@@ -1461,13 +1457,13 @@
                    (incf n)))
 
                (let* ((tlf (source-path-tlf-number path))
                    (incf n)))
 
                (let* ((tlf (source-path-tlf-number path))

-                      (file (find-file-info tlf *source-info*)))
+                      (file-info (source-info-file-info *source-info*)))

                  (make-compiler-error-context
                   :enclosing-source (short)
                   :source (full)
                   :original-source (stringify-form form)
                   :context src-context
                  (make-compiler-error-context
                   :enclosing-source (short)
                   :source (full)
                   :original-source (stringify-form form)
                   :context src-context

-                  :file-name (file-info-name file)
+                  :file-name (file-info-name file-info)

                   :file-position
                   (multiple-value-bind (ignore pos)
                       (find-source-root tlf *source-info*)
                   :file-position
                   (multiple-value-bind (ignore pos)
                       (find-source-root tlf *source-info*)

@@ -1478,8 +1474,8 @@
 \f
 ;;;; printing error messages
 
 \f
 ;;;; printing error messages
 

-;;; We save the context information that we printed out most recently so that
-;;; we don't print it out redundantly.
+;;; We save the context information that we printed out most recently
+;;; so that we don't print it out redundantly.

 
 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
 (defvar *last-error-context* nil)
 
 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
 (defvar *last-error-context* nil)

@@ -1491,8 +1487,8 @@
 (declaim (type (or string null) *last-format-string*))
 (declaim (type list *last-format-args*))
 
 (declaim (type (or string null) *last-format-string*))
 (declaim (type list *last-format-args*))
 

-;;; The number of times that the last error message has been emitted, so that
-;;; we can compress duplicate error messages.
+;;; The number of times that the last error message has been emitted,
+;;; so that we can compress duplicate error messages.

 (defvar *last-message-count* 0)
 (declaim (type index *last-message-count*))
 
 (defvar *last-message-count* 0)
 (declaim (type index *last-message-count*))
 

@@ -1503,18 +1499,18 @@
   (cond ((= *last-message-count* 1)
         (when terpri (terpri *error-output*)))
        ((> *last-message-count* 1)
   (cond ((= *last-message-count* 1)
         (when terpri (terpri *error-output*)))
        ((> *last-message-count* 1)

-        (format *error-output* "[Last message occurs ~D times.]~2%"
+          (format *error-output* "~&; [Last message occurs ~D times.]~2%"

                 *last-message-count*)))
   (setq *last-message-count* 0))
 
                 *last-message-count*)))
   (setq *last-message-count* 0))
 

-;;; Print out the message, with appropriate context if we can find it. If
-;;; If the context is different from the context of the last message we
-;;; printed, then we print the context. If the original source is different
-;;; from the source we are working on, then we print the current source in
-;;; addition to the original source.
+;;; Print out the message, with appropriate context if we can find it.
+;;; If the context is different from the context of the last message
+;;; we printed, then we print the context. If the original source is
+;;; different from the source we are working on, then we print the
+;;; current source in addition to the original source.

 ;;;
 ;;;

-;;; We suppress printing of messages identical to the previous, but record
-;;; the number of times that the message is repeated.
+;;; We suppress printing of messages identical to the previous, but
+;;; record the number of times that the message is repeated.

 (defun print-compiler-message (format-string format-args)
 
   (declare (type simple-string format-string))
 (defun print-compiler-message (format-string format-args)
 
   (declare (type simple-string format-string))

@@ -1536,20 +1532,27 @@
          (when (pathnamep file)
            (note-message-repeats)
            (setq last nil)
          (when (pathnamep file)
            (note-message-repeats)
            (setq last nil)

-           (format stream "~2&file: ~A~%" (namestring file))))
+            (format stream "~2&; file: ~A~%" (namestring file))))

 
        (unless (and last
                     (equal in (compiler-error-context-context last)))
          (note-message-repeats)
          (setq last nil)
 
        (unless (and last
                     (equal in (compiler-error-context-context last)))
          (note-message-repeats)
          (setq last nil)

-         (format stream "~2&in:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" in))
+          (format stream "~&")
+          (pprint-logical-block (stream nil :per-line-prefix "; ")
+            (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+          (format stream "~%"))
+

 
        (unless (and last
                     (string= form
                              (compiler-error-context-original-source last)))
          (note-message-repeats)
          (setq last nil)
 
        (unless (and last
                     (string= form
                              (compiler-error-context-original-source last)))
          (note-message-repeats)
          (setq last nil)

-         (write-string form stream))
+          (format stream "~&")
+          (pprint-logical-block (stream nil :per-line-prefix "; ")
+            (format stream "  ~A" form))
+          (format stream "~&"))

 
        (unless (and last
                     (equal enclosing
 
        (unless (and last
                     (equal enclosing

@@ -1557,7 +1560,7 @@
          (when enclosing
            (note-message-repeats)
            (setq last nil)
          (when enclosing
            (note-message-repeats)
            (setq last nil)

-           (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
+           (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))

 
        (unless (and last
                     (equal source (compiler-error-context-source last)))
 
        (unless (and last
                     (equal source (compiler-error-context-source last)))

@@ -1565,12 +1568,16 @@
          (when source
            (note-message-repeats)
            (dolist (src source)
          (when source
            (note-message-repeats)
            (dolist (src source)

-             (write-line "==>" stream)
-             (write-string src stream))))))
+              (format stream "~&")
+              (write-string "; ==>" stream)
+              (format stream "~&")
+              (pprint-logical-block (stream nil :per-line-prefix "; ")
+                (write-string src stream)))))))

      (t
      (t

+       (format stream "~&")

       (note-message-repeats)
       (setq *last-format-string* nil)
       (note-message-repeats)
       (setq *last-format-string* nil)

-      (format stream "~2&")))
+       (format stream "~&")))

 
     (setq *last-error-context* context)
 
 
     (setq *last-error-context* context)
 

@@ -1582,16 +1589,20 @@
       (let ((*print-level*  *compiler-error-print-level*)
            (*print-length* *compiler-error-print-length*)
            (*print-lines*  *compiler-error-print-lines*))
       (let ((*print-level*  *compiler-error-print-level*)
            (*print-length* *compiler-error-print-length*)
            (*print-lines*  *compiler-error-print-lines*))

-       (format stream "~&~?~&" format-string format-args))))
+        (format stream "~&")
+        (pprint-logical-block (stream nil :per-line-prefix "; ")
+          (format stream "~&~?" format-string format-args))
+        (format stream "~&"))))

 
   (incf *last-message-count*)
   (values))
 
 (defun print-compiler-condition (condition)
   (declare (type condition condition))
 
   (incf *last-message-count*)
   (values))
 
 (defun print-compiler-condition (condition)
   (declare (type condition condition))

-  (let (;; These different classes of conditions have different effects
-       ;; on the return codes of COMPILE-FILE, so it's nice for users to be
-       ;; able to pick them out by lexical search through the output.
+  (let (;; These different classes of conditions have different
+       ;; effects on the return codes of COMPILE-FILE, so it's nice
+       ;; for users to be able to pick them out by lexical search
+       ;; through the output.

        (what (etypecase condition
                (style-warning 'style-warning)
                (warning 'warning)
        (what (etypecase condition
                (style-warning 'style-warning)
                (warning 'warning)

@@ -1618,13 +1629,25 @@
 ;;; out how to compile something as efficiently as it liked.)
 (defun compiler-note (format-string &rest format-args)
   (unless (if *compiler-error-context*
 ;;; out how to compile something as efficiently as it liked.)
 (defun compiler-note (format-string &rest format-args)
   (unless (if *compiler-error-context*

-             (policy *compiler-error-context* (= brevity 3))
-             (policy nil (= brevity 3)))
+             (policy *compiler-error-context* (= inhibit-warnings 3))
+             (policy *lexenv* (= inhibit-warnings 3)))

     (incf *compiler-note-count*)
     (print-compiler-message (format nil "note: ~A" format-string)
                            format-args))
   (values))
 
     (incf *compiler-note-count*)
     (print-compiler-message (format nil "note: ~A" format-string)
                            format-args))
   (values))
 

+;;; Issue a note when we might or might not be in the compiler.
+(defun maybe-compiler-note (&rest rest)
+  (if (boundp '*lexenv*) ; if we're in the compiler
+      (apply #'compiler-note rest)
+      (let ((stream *error-output*))
+       (pprint-logical-block (stream nil :per-line-prefix ";")
+         
+         (format stream " note: ~3I~_")
+         (pprint-logical-block (stream nil)
+           (apply #'format stream rest)))
+       (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
+

 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
 ;;; it needs to be reprinted, and we also Force-Output so that the
 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
 ;;; it needs to be reprinted, and we also Force-Output so that the

@@ -1637,13 +1660,13 @@
   (force-output *error-output*)
   (values))
 
   (force-output *error-output*)
   (values))
 

-;;; Return a string that somehow names the code in Component. We use
+;;; Return a string that somehow names the code in COMPONENT. We use

 ;;; the source path for the bind node for an arbitrary entry point to
 ;;; find the source context, then return that as a string.
 (declaim (ftype (function (component) simple-string) find-component-name))
 (defun find-component-name (component)
   (let ((ep (first (block-succ (component-head component)))))
 ;;; the source path for the bind node for an arbitrary entry point to
 ;;; find the source context, then return that as a string.
 (declaim (ftype (function (component) simple-string) find-component-name))
 (defun find-component-name (component)
   (let ((ep (first (block-succ (component-head component)))))

-    (assert ep () "no entry points?")
+    (aver ep) ; else no entry points??

     (multiple-value-bind (form context)
        (find-original-source
         (node-source-path (continuation-next (block-start ep))))
     (multiple-value-bind (form context)
        (find-original-source
         (node-source-path (continuation-next (block-start ep))))

@@ -1666,8 +1689,8 @@
 (defvar *warnings-p*)
 
 ;;; condition handlers established by the compiler. We re-signal the
 (defvar *warnings-p*)
 
 ;;; condition handlers established by the compiler. We re-signal the

-;;; condition, if it is not handled, we increment our warning counter
-;;; and print the error message.
+;;; condition, then if it isn't handled, we increment our warning
+;;; counter and print the error message.

 (defun compiler-error-handler (condition)
   (signal condition)
   (incf *compiler-error-count*)
 (defun compiler-error-handler (condition)
   (signal condition)
   (incf *compiler-error-count*)

@@ -1699,7 +1722,7 @@
   problem is a missing definition (as opposed to a typo in the use.)")
 
 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
   problem is a missing definition (as opposed to a typo in the use.)")
 
 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference

-;;; to Name of the specified Kind. If we have exceeded the warning
+;;; to NAME of the specified KIND. If we have exceeded the warning

 ;;; limit, then just increment the count, otherwise note the current
 ;;; error context.
 ;;;
 ;;; limit, then just increment the count, otherwise note the current
 ;;; error context.
 ;;;

@@ -1707,14 +1730,17 @@
 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
 ;;; the compiler, hence the BOUNDP check.
 (defun note-undefined-reference (name kind)
 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
 ;;; the compiler, hence the BOUNDP check.
 (defun note-undefined-reference (name kind)

-  (unless (and (boundp '*lexenv*)
-              ;; FIXME: I'm pretty sure the BREVITY test below isn't
-              ;; a good idea; we should have BREVITY affect compiler
-              ;; notes, not STYLE-WARNINGs. And I'm not sure what the
-              ;; BOUNDP '*LEXENV* test above is for; it's likely
-              ;; a good idea, but it probably deserves an explanatory
-              ;; comment.
-              (policy nil (= brevity 3)))
+  (unless (and
+          ;; Check for boundness so we don't blow up if we're called
+          ;; when IR1 conversion isn't going on.
+          (boundp '*lexenv*)
+          ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+          ;; isn't a good idea; we should have INHIBIT-WARNINGS
+          ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+          ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+          ;; likely a good idea, but it probably deserves an
+          ;; explanatory comment.
+          (policy *lexenv* (= inhibit-warnings 3)))

     (let* ((found (dolist (warning *undefined-warnings* nil)
                    (when (and (equal (undefined-warning-name warning) name)
                               (eq (undefined-warning-kind warning) kind))
     (let* ((found (dolist (warning *undefined-warnings* nil)
                    (when (and (equal (undefined-warning-name warning) name)
                               (eq (undefined-warning-kind warning) kind))

@@ -1750,11 +1776,11 @@
          (return-from careful-call (values nil nil))))))
    t))
 \f
          (return-from careful-call (values nil nil))))))
    t))
 \f

-;;;; utilities used at run-time for parsing keyword args in IR1
+;;;; utilities used at run-time for parsing &KEY args in IR1

 
 

-;;; This function is used by the result of Parse-Deftransform to find
-;;; the continuation for the value of the keyword argument Key in the
-;;; list of continuations Args. It returns the continuation if the
+;;; This function is used by the result of PARSE-DEFTRANSFORM to find
+;;; the continuation for the value of the &KEY argument KEY in the
+;;; list of continuations ARGS. It returns the continuation if the

 ;;; keyword is present, or NIL otherwise. The legality and
 ;;; constantness of the keywords should already have been checked.
 (declaim (ftype (function (list keyword) (or continuation null))
 ;;; keyword is present, or NIL otherwise. The legality and
 ;;; constantness of the keywords should already have been checked.
 (declaim (ftype (function (list keyword) (or continuation null))

@@ -1765,24 +1791,24 @@
     (when (eq (continuation-value (first arg)) key)
       (return (second arg)))))
 
     (when (eq (continuation-value (first arg)) key)
       (return (second arg)))))
 

-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that alternating continuations in Args are constant and
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that alternating continuations in ARGS are constant and

 ;;; that there is an even number of args.
 ;;; that there is an even number of args.

-(declaim (ftype (function (list) boolean) check-keywords-constant))
-(defun check-keywords-constant (args)
+(declaim (ftype (function (list) boolean) check-key-args-constant))
+(defun check-key-args-constant (args)

   (do ((arg args (cddr arg)))
       ((null arg) t)
     (unless (and (rest arg)
                 (constant-continuation-p (first arg)))
       (return nil))))
 
   (do ((arg args (cddr arg)))
       ((null arg) t)
     (unless (and (rest arg)
                 (constant-continuation-p (first arg)))
       (return nil))))
 

-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that the list of continuations Args is a well-formed
-;;; keyword arglist and that only keywords present in the list Keys
-;;; are supplied.
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that the list of continuations ARGS is a well-formed &KEY
+;;; arglist and that only keywords present in the list KEYS are
+;;; supplied.

 (declaim (ftype (function (list list) boolean) check-transform-keys))
 (defun check-transform-keys (args keys)
 (declaim (ftype (function (list list) boolean) check-transform-keys))
 (defun check-transform-keys (args keys)

-  (and (check-keywords-constant args)
+  (and (check-key-args-constant args)

        (do ((arg args (cddr arg)))
           ((null arg) t)
         (unless (member (continuation-value (first arg)) keys)
        (do ((arg args (cddr arg)))
           ((null arg) t)
         (unless (member (continuation-value (first arg)) keys)

@@ -1795,9 +1821,8 @@
 (defun %event (info node)
   (incf (event-info-count info))
   (when (and (>= (event-info-level info) *event-note-threshold*)
 (defun %event (info node)
   (incf (event-info-count info))
   (when (and (>= (event-info-level info) *event-note-threshold*)

-            (if node
-                (policy node (= brevity 0))
-                (policy nil (= brevity 0))))
+            (policy (or node *lexenv*)
+                    (= inhibit-warnings 0)))

     (let ((*compiler-error-context* node))
       (compiler-note (event-info-description info))))
 
     (let ((*compiler-error-context* node))
       (compiler-note (event-info-description info))))