1.0.27.32: implement and use SB!XC:GENSYM

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

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 6f18bd4..14a2121 100644 (file)
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -16,27 +16,6 @@
 
 (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.
-;;;
-;;; 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*))
-(defvar *compiler-error-print-level* 5
-  #!+sb-doc
-  "the value for *PRINT-LEVEL* when printing compiler error messages")
-(defvar *compiler-error-print-length* 10
-  #!+sb-doc
-  "the value for *PRINT-LENGTH* when printing compiler error messages")
-(defvar *compiler-error-print-lines* 12
-  #!+sb-doc
-  "the value for *PRINT-LINES* when printing compiler error messages")
-

 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
   "The maximum number of enclosing non-original source forms (i.e. from
 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
   "The maximum number of enclosing non-original source forms (i.e. from

@@ -54,10 +33,10 @@
 ;;; this end, we convert source forms to strings so that source forms
 ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
 (defstruct (compiler-error-context
 ;;; this end, we convert source forms to strings so that source forms
 ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
 (defstruct (compiler-error-context

-           #-no-ansi-print-object
-           (:print-object (lambda (x stream)
-                            (print-unreadable-object (x stream :type t))))
-           (:copier nil))
+            #-no-ansi-print-object
+            (:print-object (lambda (x stream)
+                             (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)

@@ -72,7 +51,9 @@
   ;; the file position at which the top level form starts, if applicable
   (file-position nil :type (or index null))
   ;; the original source part of the source path
   ;; the file position at which the top level form starts, if applicable
   (file-position nil :type (or index null))
   ;; the original source part of the source path

-  (original-source-path nil :type list))
+  (original-source-path nil :type list)
+  ;; the lexenv active at the time
+  (lexenv nil :type (or null lexenv)))

 
 ;;; If true, this is the node which is used as context in compiler warning
 ;;; messages.
 
 ;;; If true, this is the node which is used as context in compiler warning
 ;;; messages.

@@ -104,20 +85,16 @@
    Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
    style lambda-list used to parse the arguments. The Body should return a
    list of subforms suitable for a \"~{~S ~}\" format string."
    Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
    style lambda-list used to parse the arguments. The Body should return a
    list of subforms suitable for a \"~{~S ~}\" format string."

-  (let ((n-whole (gensym)))
+  (with-unique-names (whole)

     `(setf (gethash ',name *source-context-methods*)
     `(setf (gethash ',name *source-context-methods*)

-          (lambda (,n-whole)
-            (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(defmacro def-source-context (&rest rest)
-  (deprecation-warning 'def-source-context 'define-source-context)
-  `(define-source-context ,@rest))
+           (lambda (,whole)
+             (destructuring-bind ,lambda-list ,whole ,@body)))))

 
 (define-source-context defstruct (name-or-options &rest slots)
   (declare (ignore slots))
   `(defstruct ,(if (consp name-or-options)
 
 (define-source-context defstruct (name-or-options &rest slots)
   (declare (ignore slots))
   `(defstruct ,(if (consp name-or-options)

-                  (car name-or-options)
-                  name-or-options)))
+                   (car name-or-options)
+                   name-or-options)))

 
 (define-source-context function (thing)
   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
 
 (define-source-context function (thing)
   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))

@@ -128,17 +105,17 @@
 ;;; CAR of the second form if appropriate.
 (defun source-form-context (form)
   (cond ((atom form) nil)
 ;;; CAR of the second form if appropriate.
 (defun source-form-context (form)
   (cond ((atom form) nil)

-       ((>= (length form) 2)
+        ((>= (length form) 2)

          (let* ((context-fun-default (lambda (x)
          (let* ((context-fun-default (lambda (x)

-                                      (declare (ignore x))
-                                      (list (first form) (second form))))
-               (context-fun (gethash (first form)
-                                     *source-context-methods*
-                                     context-fun-default)))
+                                       (declare (ignore x))
+                                       (list (first form) (second form))))
+                (context-fun (gethash (first form)
+                                      *source-context-methods*
+                                      context-fun-default)))

            (declare (type function context-fun))
            (funcall context-fun (rest form))))
            (declare (type function context-fun))
            (funcall context-fun (rest form))))

-       (t
-        form)))
+        (t
+         form)))

 
 ;;; Given a source path, return the original source form and a
 ;;; description of the interesting aspects of the context in which it
 
 ;;; Given a source path, return the original source form and a
 ;;; description of the interesting aspects of the context in which it

@@ -156,69 +133,41 @@
 (defun find-original-source (path)
   (declare (list path))
   (let* ((rpath (reverse (source-path-original-source path)))
 (defun find-original-source (path)
   (declare (list path))
   (let* ((rpath (reverse (source-path-original-source path)))

-        (tlf (first rpath))
-        (root (find-source-root tlf *source-info*)))
+         (tlf (first rpath))
+         (root (find-source-root tlf *source-info*)))

     (collect ((context))
       (let ((form root)
     (collect ((context))
       (let ((form root)

-           (current (rest rpath)))
-       (loop
-         (when (atom form)
-           (aver (null current))
-           (return))
-         (let ((head (first form)))
-           (when (symbolp head)
-             (let ((name (symbol-name head)))
-               (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
-                 (context (source-form-context form))))))
-         (when (null current) (return))
-         (setq form (nth (pop current) form)))
-       
-       (cond ((context)
-              (values form (context)))
-             ((and path root)
-              (let ((c (source-form-context root)))
-                (values form (if c (list c) nil))))
-             (t
-              (values '(unable to locate source)
-                      '((some strange place)))))))))
+            (current (rest rpath)))
+        (loop
+          (when (atom form)
+            (aver (null current))
+            (return))
+          (let ((head (first form)))
+            (when (symbolp head)
+              (let ((name (symbol-name head)))
+                (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+                  (context (source-form-context form))))))
+          (when (null current) (return))
+          (setq form (nth (pop current) form)))
+
+        (cond ((context)
+               (values form (context)))
+              ((and path root)
+               (let ((c (source-form-context root)))
+                 (values form (if c (list c) nil))))
+              (t
+               (values '(unable to locate source)
+                       '((some strange place)))))))))

 
 ;;; Convert a source form to a string, suitably formatted for use in
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (with-standard-io-syntax
 
 ;;; Convert a source form to a string, suitably formatted for use in
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (with-standard-io-syntax

-   (let ((*print-readably* nil)
-         (*print-pretty* pretty)
-         (*print-level* *compiler-error-print-level*)
-         (*print-length* *compiler-error-print-length*)
-         (*print-lines* *compiler-error-print-lines*))
-     (if pretty
-         (format nil "~<~@;  ~S~:>" (list form))
-         (prin1-to-string form)))))
-
-;;; shorthand for a repeated idiom in creating debug names
-;;;
-;;; the problem, part I: We want to create debug names that look like
-;;; "&MORE processor for <something>" where <something> might be
-;;; either a source-name value (typically a symbol) or a non-symbol
-;;; debug-name value (typically a string). It's awkward to handle this
-;;; with FORMAT because we'd like to splice a source-name value using
-;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
-;;; (to avoid irrelevant quotes at string splice boundaries).
-;;;
-;;; the problem, part II: The <something> is represented as a pair
-;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
-;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily
-;;; we don't use a value if it's NIL, instead defaulting it. But we
-;;; can't safely/comfortably use NIL for that in this context, since
-;;; the app programmer can use NIL as a name, so we use the private
-;;; symbol .ANONYMOUS. instead.)
-;;;
-;;; the solution: Use this function to convert whatever it is to a
-;;; string, which FORMAT can then splice using "~A".
-(defun as-debug-name (source-name debug-name)
-  (if (eql source-name '.anonymous.)
-      debug-name
-      (debug-namify "~S" source-name)))
+    (with-compiler-io-syntax
+        (let ((*print-pretty* pretty))
+          (if pretty
+              (format nil "~<~@;  ~S~:>" (list 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
 
 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
 ;;; error context, or NIL if we can't figure anything out. ARGS is a

@@ -228,43 +177,46 @@
 (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)

-       context
-       (let ((path (or (and (boundp '*current-path*) *current-path*)
-                       (if context
-                           (node-source-path context)
-                           nil))))
-         (when (and *source-info* path)
-           (multiple-value-bind (form src-context) (find-original-source path)
-             (collect ((full nil cons)
-                       (short nil cons))
-               (let ((forms (source-path-forms path))
-                     (n 0))
-                 (dolist (src (if (member (first forms) args)
-                                  (rest forms)
-                                  forms))
-                   (if (>= n *enclosing-source-cutoff*)
-                       (short (stringify-form (if (consp src)
-                                                  (car src)
-                                                  src)
-                                              nil))
-                       (full (stringify-form src)))
-                   (incf n)))
-
-               (let* ((tlf (source-path-tlf-number path))
-                      (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
-                  :file-name (file-info-name file-info)
-                  :file-position
-                  (multiple-value-bind (ignore pos)
-                      (find-source-root tlf *source-info*)
-                    (declare (ignore ignore))
-                    pos)
-                  :original-source-path
-                  (source-path-original-source path))))))))))
+        context
+        (let ((path (or (and (boundp '*current-path*) *current-path*)
+                        (if context
+                            (node-source-path context)
+                            nil))))
+          (when (and *source-info* path)
+            (multiple-value-bind (form src-context) (find-original-source path)
+              (collect ((full nil cons)
+                        (short nil cons))
+                (let ((forms (source-path-forms path))
+                      (n 0))
+                  (dolist (src (if (member (first forms) args)
+                                   (rest forms)
+                                   forms))
+                    (if (>= n *enclosing-source-cutoff*)
+                        (short (stringify-form (if (consp src)
+                                                   (car src)
+                                                   src)
+                                               nil))
+                        (full (stringify-form src)))
+                    (incf n)))
+
+                (let* ((tlf (source-path-tlf-number path))
+                       (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
+                   :file-name (file-info-name file-info)
+                   :file-position
+                   (multiple-value-bind (ignore pos)
+                       (find-source-root tlf *source-info*)
+                     (declare (ignore ignore))
+                     pos)
+                   :original-source-path
+                   (source-path-original-source path)
+                   :lexenv (if context
+                               (node-lexenv context)
+                               (if (boundp '*lexenv*) *lexenv* nil)))))))))))

 \f
 ;;;; printing error messages
 
 \f
 ;;;; printing error messages
 

@@ -289,12 +241,13 @@
 ;;; If the last message was given more than once, then print out an
 ;;; indication of how many times it was repeated. We reset the message
 ;;; count when we are done.
 ;;; If the last message was given more than once, then print out an
 ;;; indication of how many times it was repeated. We reset the message
 ;;; count when we are done.

-(defun note-message-repeats (&optional (terpri t))
+(defun note-message-repeats (stream &optional (terpri t))

   (cond ((= *last-message-count* 1)
   (cond ((= *last-message-count* 1)

-        (when terpri (terpri *error-output*)))
-       ((> *last-message-count* 1)
-          (format *error-output* "~&; [Last message occurs ~W times.]~2%"
-                *last-message-count*)))
+         (when terpri
+           (terpri stream)))
+        ((> *last-message-count* 1)
+         (format stream "~&; [Last message occurs ~W times.]~2%"
+                 *last-message-count*)))

   (setq *last-message-count* 0))
 
 ;;; Print out the message, with appropriate context if we can find it.
   (setq *last-message-count* 0))
 
 ;;; Print out the message, with appropriate context if we can find it.

@@ -305,90 +258,83 @@
 ;;;
 ;;; 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)
+(defmacro print-compiler-message (stream format-string format-args)
+  `(with-compiler-io-syntax
+     (%print-compiler-message ,stream ,format-string ,format-args)))

 
 

+(defun %print-compiler-message (stream format-string format-args)

   (declare (type simple-string format-string))
   (declare (type list format-args))
   (declare (type simple-string format-string))
   (declare (type list format-args))

-  
-  (let ((stream *error-output*)
-       (context (find-error-context format-args)))
-    (cond
-     (context
-      (let ((file (compiler-error-context-file-name context))
-           (in (compiler-error-context-context context))
-           (form (compiler-error-context-original-source context))
-           (enclosing (compiler-error-context-enclosing-source context))
-           (source (compiler-error-context-source context))
-           (last *last-error-context*))
-
-       (unless (and last
-                    (equal file (compiler-error-context-file-name last)))
-         (when (pathnamep file)
-           (note-message-repeats)
-           (setq last nil)
-            (format stream "~2&; file: ~A~%" (namestring file))))
-
-       (unless (and last
-                    (equal in (compiler-error-context-context last)))
-         (note-message-repeats)
-         (setq last nil)
-          (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)
-          (format stream "~&")
-          (pprint-logical-block (stream nil :per-line-prefix "; ")
-            (format stream "  ~A" form))
-          (format stream "~&"))
-
-       (unless (and last
-                    (equal enclosing
-                           (compiler-error-context-enclosing-source last)))
-         (when enclosing
-           (note-message-repeats)
-           (setq last nil)
-           (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
-       (unless (and last
-                    (equal source (compiler-error-context-source last)))
-         (setq *last-format-string* nil)
-         (when source
-           (note-message-repeats)
-           (dolist (src source)
-              (format stream "~&")
-              (write-string "; ==>" stream)
-              (format stream "~&")
-              (pprint-logical-block (stream nil :per-line-prefix "; ")
-                (write-string src stream)))))))
-     (t
-       (format stream "~&")
-      (note-message-repeats)
-      (setq *last-format-string* nil)
-       (format stream "~&")))
-
-    (setq *last-error-context* context)
-
-    ;; FIXME: this testing for effective equality of compiler messages
-    ;; is ugly, and really ought to be done at a higher level.
-    (unless (and (equal format-string *last-format-string*)
-                (tree-equal format-args *last-format-args*))
-      (note-message-repeats nil)
-      (setq *last-format-string* format-string)
-      (setq *last-format-args* format-args)
-      (let ((*print-level*  *compiler-error-print-level*)
-           (*print-length* *compiler-error-print-length*)
-           (*print-lines*  *compiler-error-print-lines*))
-        (format stream "~&")
-        (pprint-logical-block (stream nil :per-line-prefix "; ")
-          (format stream "~&~?" format-string format-args))
-        (format stream "~&"))))
+  (let ((context (find-error-context format-args)))
+    (cond (context
+           (let ((file (compiler-error-context-file-name context))
+                 (in (compiler-error-context-context context))
+                 (form (compiler-error-context-original-source context))
+                 (enclosing (compiler-error-context-enclosing-source context))
+                 (source (compiler-error-context-source context))
+                 (last *last-error-context*))
+
+             (unless  (and last
+                           (equal file (compiler-error-context-file-name last)))
+               (when (pathnamep file)
+                 (note-message-repeats stream)
+                 (setq last nil)
+                 (format stream "~2&; file: ~A~%" (namestring file))))
+
+             (unless (and last
+                          (equal in (compiler-error-context-context last)))
+               (note-message-repeats stream)
+               (setq last nil)
+               (pprint-logical-block (stream nil :per-line-prefix "; ")
+                 (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+               (terpri stream))
+
+             (unless (and last
+                          (string= form
+                                   (compiler-error-context-original-source last)))
+               (note-message-repeats stream)
+               (setq last nil)
+               (pprint-logical-block (stream nil :per-line-prefix ";   ")
+                 (princ form stream))
+               (fresh-line stream))
+
+             (unless (and last
+                          (equal enclosing
+                                 (compiler-error-context-enclosing-source last)))
+               (when enclosing
+                 (note-message-repeats stream)
+                 (setq last nil)
+                 (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
+
+             (unless (and last
+                          (equal source (compiler-error-context-source last)))
+               (setq *last-format-string* nil)
+               (when source
+                 (note-message-repeats stream)
+                 (dolist (src source)
+                   (fresh-line stream)
+                   (write-string "; ==>" stream)
+                   (terpri stream)
+                   (pprint-logical-block (stream nil :per-line-prefix "; ")
+                     (write-string src stream)))))))
+          (t
+           (fresh-line stream)
+           (note-message-repeats stream)
+           (setq *last-format-string* nil)))
+
+    (setq *last-error-context* context))
+
+  ;; FIXME: this testing for effective equality of compiler messages
+  ;; is ugly, and really ought to be done at a higher level.
+  (unless (and (equal format-string *last-format-string*)
+               (tree-equal format-args *last-format-args*))
+    (note-message-repeats stream nil)
+    (setq *last-format-string* format-string)
+    (setq *last-format-args* format-args)
+    (fresh-line stream)
+    (pprint-logical-block (stream nil :per-line-prefix "; ")
+      (format stream "~&~?" format-string format-args))
+    (fresh-line stream))

 
   (incf *last-message-count*)
   (values))
 
   (incf *last-message-count*)
   (values))

@@ -396,24 +342,17 @@
 (defun print-compiler-condition (condition)
   (declare (type condition condition))
   (let (;; These different classes of conditions have different
 (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.
-       (what (etypecase condition
-               (style-warning 'style-warning)
-               (warning 'warning)
-               ((or error compiler-error) 'error))))
-    (multiple-value-bind (format-string format-args)
-       (if (typep condition 'simple-condition)
-           (values (simple-condition-format-control condition)
-                   (simple-condition-format-arguments condition))
-           (values "~A"
-                   (list (with-output-to-string (s)
-                           (princ condition s)))))
-      (print-compiler-message
-       (format nil "caught ~S:~%  ~A" what format-string)
-       format-args)))
-  (values))
+        ;; 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)
+                ((or error compiler-error) 'error))))
+    (print-compiler-message
+     *error-output*
+     (format nil "caught ~S:~%~~@<  ~~@;~~A~~:>" what)
+     (list (princ-to-string condition)))))

 
 ;;; The act of signalling one of these beasts must not cause WARNINGSP
 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
 
 ;;; The act of signalling one of these beasts must not cause WARNINGSP
 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't

@@ -433,62 +372,57 @@ a STYLE-WARNING (or any more serious condition)."))
    "A condition type signalled when the compiler deletes code that the user
 has written, having proved that it is unreachable."))
 
    "A condition type signalled when the compiler deletes code that the user
 has written, having proved that it is unreachable."))
 

-(defun compiler-notify (datum &rest args)
-  (unless (if *compiler-error-context*
-             (policy *compiler-error-context* (= inhibit-warnings 3))
-             (policy *lexenv* (= inhibit-warnings 3)))
-    (let ((condition
-          (coerce-to-condition datum args
-                               'simple-compiler-note 'compiler-notify)))
-      (restart-case
-         (signal condition)
-       (muffle-warning ()
-         (return-from compiler-notify (values))))
-      (incf *compiler-note-count*)
-      (multiple-value-bind (format-string format-args)
-         (if (typep condition 'simple-condition)
-             (values (simple-condition-format-control condition)
-                     (simple-condition-format-arguments condition))
-             (values "~A"
-                     (list (with-output-to-string (s)
-                             (princ condition s)))))
-       (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-notify (&rest rest)
-  (if (boundp '*lexenv*) ; if we're in the compiler
-      (apply #'compiler-notify rest)
-      (progn
-       (let ((condition
-              (coerce-to-condition (car rest) (cdr rest)
-                                   'simple-compiler-note
-                                   'maybe-compiler-notify)))
-         (restart-case
-             (signal condition)
-           (muffle-warning ()
-             (return-from maybe-compiler-notify (values))))
-         (let ((stream *error-output*))
-           (pprint-logical-block (stream nil :per-line-prefix ";")
-             (format stream " note: ~3I~_")
-             (pprint-logical-block (stream nil)
-               (format stream "~A" condition)))
-           ;; (outside logical block, no per-line-prefix)
-           (fresh-line stream)))
-       (values))))
+(macrolet ((with-condition ((condition datum args) &body body)
+             (with-unique-names (block)
+               `(block ,block
+                  (let ((,condition
+                         (coerce-to-condition ,datum ,args
+                                              'simple-compiler-note
+                                              'with-condition)))
+                    (restart-case
+                        (signal ,condition)
+                      (muffle-warning ()
+                        (return-from ,block (values))))
+                    ,@body
+                    (values))))))
+
+  (defun compiler-notify (datum &rest args)
+    (unless (if *compiler-error-context*
+              (policy *compiler-error-context* (= inhibit-warnings 3))
+              (policy *lexenv* (= inhibit-warnings 3)))
+      (with-condition (condition datum args)
+        (incf *compiler-note-count*)
+        (print-compiler-message
+         *error-output*
+         (format nil "note: ~~A")
+         (list (princ-to-string condition)))))
+    (values))
+
+  ;; Issue a note when we might or might not be in the compiler.
+  (defun maybe-compiler-notify (datum &rest args)
+    (if (boundp '*lexenv*) ; if we're in the compiler
+        (apply #'compiler-notify datum args)
+        (with-condition (condition datum args)
+          (let ((stream *error-output*))
+            (pprint-logical-block (stream nil :per-line-prefix ";")
+              (format stream " note: ~3I~_")
+              (pprint-logical-block (stream nil)
+                (format stream "~A" condition)))
+            ;; (outside logical block, no per-line-prefix)
+            (fresh-line stream))))))

 
 ;;; 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
 ;;; message gets seen right away.
 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
 
 ;;; 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
 ;;; message gets seen right away.
 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))

-(defun compiler-mumble (format-string &rest format-args)
-  (note-message-repeats)
-  (setq *last-error-context* nil)
-  (apply #'format *error-output* format-string format-args)
-  (force-output *error-output*)
-  (values))
+(defun compiler-mumble (control &rest args)
+  (let ((stream *standard-output*))
+    (note-message-repeats stream)
+    (setq *last-error-context* nil)
+    (apply #'format stream control args)
+    (force-output stream)
+    (values)))

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

@@ -498,12 +432,12 @@ has written, having proved that it is unreachable."))
   (let ((ep (first (block-succ (component-head component)))))
     (aver ep) ; else no entry points??
     (multiple-value-bind (form context)
   (let ((ep (first (block-succ (component-head component)))))
     (aver ep) ; else no entry points??
     (multiple-value-bind (form context)

-       (find-original-source
-        (node-source-path (continuation-next (block-start ep))))
+        (find-original-source
+         (node-source-path (block-start-node ep)))

       (declare (ignore form))
       (let ((*print-level* 2)
       (declare (ignore form))
       (let ((*print-level* 2)

-           (*print-pretty* nil))
-       (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+            (*print-pretty* nil))
+        (format nil "~{~{~S~^ ~}~^ => ~}" context)))))

 \f
 ;;;; condition system interface
 
 \f
 ;;;; condition system interface
 

@@ -525,14 +459,14 @@ has written, having proved that it is unreachable."))
   (signal condition)
   (incf *compiler-error-count*)
   (setf *warnings-p* t
   (signal condition)
   (incf *compiler-error-count*)
   (setf *warnings-p* t

-       *failure-p* t)
+        *failure-p* t)

   (print-compiler-condition condition)
   (continue condition))
 (defun compiler-warning-handler (condition)
   (signal condition)
   (incf *compiler-warning-count*)
   (setf *warnings-p* t
   (print-compiler-condition condition)
   (continue condition))
 (defun compiler-warning-handler (condition)
   (signal condition)
   (incf *compiler-warning-count*)
   (setf *warnings-p* t

-       *failure-p* t)
+        *failure-p* t)

   (print-compiler-condition condition)
   (muffle-warning condition))
 (defun compiler-style-warning-handler (condition)
   (print-compiler-condition condition)
   (muffle-warning condition))
 (defun compiler-style-warning-handler (condition)

@@ -561,26 +495,40 @@ has written, having proved that it is unreachable."))
 ;;; the compiler, hence the BOUNDP check.
 (defun note-undefined-reference (name kind)
   (unless (and
 ;;; the compiler, hence the BOUNDP check.
 (defun note-undefined-reference (name kind)
   (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)))
+           ;; Check for boundness so we don't blow up if we're called
+           ;; when IR1 conversion isn't going on.
+           (boundp '*lexenv*)
+           (or
+            ;; 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))
+            ;; KLUDGE: weird decoupling between here and where we're
+            ;; going to signal the condition.  I don't think we can
+            ;; rewrite this using SIGNAL and RESTART-CASE (to take
+            ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
+            ;; handler, because if that doesn't handle it the ordinary
+            ;; compiler handlers will trigger.
+            (typep
+             (ecase kind
+               (:variable (make-condition 'warning))
+               ((:function :type) (make-condition 'style-warning)))
+             (car
+              (rassoc 'muffle-warning
+                      (lexenv-handled-conditions *lexenv*))))))

     (let* ((found (dolist (warning *undefined-warnings* nil)
     (let* ((found (dolist (warning *undefined-warnings* nil)

-                   (when (and (equal (undefined-warning-name warning) name)
-                              (eq (undefined-warning-kind warning) kind))
-                     (return warning))))
-          (res (or found
-                   (make-undefined-warning :name name :kind kind))))
+                    (when (and (equal (undefined-warning-name warning) name)
+                               (eq (undefined-warning-kind warning) kind))
+                      (return warning))))
+           (res (or found
+                    (make-undefined-warning :name name :kind kind))))

       (unless found (push res *undefined-warnings*))
       (when (or (not *undefined-warning-limit*)
       (unless found (push res *undefined-warnings*))
       (when (or (not *undefined-warning-limit*)

-               (< (undefined-warning-count res) *undefined-warning-limit*))
-       (push (find-error-context (list name))
-             (undefined-warning-warnings res)))
+                (< (undefined-warning-count res) *undefined-warning-limit*))
+        (push (find-error-context (list name))
+              (undefined-warning-warnings res)))

       (incf (undefined-warning-count res))))
   (values))
       (incf (undefined-warning-count res))))
   (values))