X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=6a6bb12f64f340cdd8754d4a0045fd1dc54f535d;hb=0e8649cf907d26f111864e4e29c7f9787828efbd;hp=6f18bd4479c453fd80eb7ec6b49ae76ec093d024;hpb=d814ff09969434c1d5225786da1c01d7a959cba0;p=sbcl.git

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 6f18bd4..6a6bb12 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -16,27 +16,6 @@
 
 (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
@@ -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
-	    #-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)
@@ -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
-  (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.
@@ -104,41 +85,50 @@
    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*)
-	   (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)
-		   (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)))
       `(lambda ,(second thing))
       `(function ,thing)))
 
+(define-source-context named-lambda (name lambda-list &body forms)
+  (declare (ignore lambda-list forms))
+  (if (and (consp name) (eq 'eval (first name)))
+      (second name)
+      `(named-lambda ,name)))
+
+(defvar *source-form-context-alist* nil)
+
 ;;; Return the first two elements of FORM if FORM is a list. Take the
 ;;; CAR of the second form if appropriate.
 (defun source-form-context (form)
-  (cond ((atom form) nil)
-	((>= (length form) 2)
-         (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 (type function context-fun))
-           (funcall context-fun (rest form))))
-	(t
-	 form)))
+  (flet ((get-it (form)
+           (cond ((atom form) nil)
+                 ((>= (length form) 2)
+                  (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 (type function context-fun))
+                    (funcall context-fun (rest form))))
+                 (t
+                  form))))
+    (get-it (or (cdr (assoc form *source-form-context-alist* :test #'eq))
+                form))))
 
 ;;; Given a source path, return the original source form and a
 ;;; description of the interesting aspects of the context in which it
@@ -156,115 +146,100 @@
 (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)
-	    (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
-   (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
 ;;; 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)
+;;;
+;;; If OLD-CONTEXTS is passed in, and includes a context with the
+;;; same original source path as the new context would have, the old
+;;; context is reused instead, and a secondary value of T is returned.
+(defun find-error-context (args &optional old-contexts)
   (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))))))))))
+        (values context t)
+        (let* ((path (or (and (node-p context) (node-source-path context))
+                         (and (boundp '*current-path*) *current-path*)))
+               (old
+                (find (when path (source-path-original-source path))
+                      (remove-if #'null old-contexts)
+                      :test #'equal
+                      :key #'compiler-error-context-original-source-path)))
+          (if old
+              (values old t)
+              (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*)))
+                      (values
+                       (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)))
+                       nil))))))))))
 
 ;;;; printing error messages
 
@@ -289,12 +264,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.
-(defun note-message-repeats (&optional (terpri t))
+(defun note-message-repeats (stream &optional (terpri t))
   (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.
@@ -305,90 +281,83 @@
 ;;;
 ;;; 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)
+(defun 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))
-  
-  (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))
@@ -396,24 +365,17 @@
 (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
@@ -433,62 +395,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."))
 
-(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))
-(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
@@ -498,12 +455,13 @@ 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)
-	(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)
-	    (*print-pretty* nil))
-	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+            (*print-pretty* nil))
+        (format nil "~{~{~S~^ ~}~^ => ~}"
+                #+sb-xc-host (list (list (caar context)))
+                #-sb-xc-host context)))))
 
 ;;;; condition system interface
 
@@ -525,14 +483,14 @@ has written, having proved that it is unreachable."))
   (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
-	*failure-p* t)
+        *failure-p* t)
   (print-compiler-condition condition)
   (muffle-warning condition))
 (defun compiler-style-warning-handler (condition)
@@ -561,26 +519,42 @@ has written, having proved that it is unreachable."))
 ;;; 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)
-		    (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*)
-		(< (undefined-warning-count res) *undefined-warning-limit*))
-	(push (find-error-context (list name))
-	      (undefined-warning-warnings res)))
-      (incf (undefined-warning-count res))))
+      (multiple-value-bind (context old)
+          (find-error-context (list name) (undefined-warning-warnings res))
+        (unless old
+          (when (or (not *undefined-warning-limit*)
+                    (< (undefined-warning-count res) *undefined-warning-limit*))
+            (push context (undefined-warning-warnings res)))
+          (incf (undefined-warning-count res))))))
   (values))