0.8.21.12: compiler message fixes

* print "caught FOO" messages and error summaries to *ERROR-OUTPUT*,
   not to *STANDARD-OUTPUT*.
 * wrap EVAL guts in WITH-COMPILATION-UNIT so that multiple subforms
   requiring compilation have their output condenced.
 * clean up compilation summary newline handling.

NEWS

@@ -9,6 +9,8 @@ changes in sbcl-0.8.22 relative to sbcl-0.8.21:
   * optimization: REPLACE on declared (UNSIGNED-BYTE 8) vectors, as well
     as other specialized array types, is much faster.  SUBSEQ and
     COPY-SEQ on such arrays have also been sped up.
+  * fixed bug: compiler error messages and summaries are now printed to 
+    *ERROR-OUTPUT*, not *STANDARD-OUTPUT*.
   * fixed inference of the upper bound of an iteration variable.
     (reported by Rajat Datta).
   * fixed bug 376: CONJUGATE type deriver.

src/code/eval.lisp

@@ -77,7 +77,8 @@
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
   result or results."
-  (eval-in-lexenv original-exp (make-null-lexenv)))
+  (with-compilation-unit ()
+    (eval-in-lexenv original-exp (make-null-lexenv))))
 
 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
 ;;; magical cases, and call %EVAL for the rest.

src/compiler/ir1report.lisp

@@ -245,11 +245,12 @@
 ;;; 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 *standard-output*)))
+	 (when terpri 
+	   (terpri stream)))
 	((> *last-message-count* 1)
-          (format *standard-output* "~&; [Last message occurs ~W times.]~2%"
+	 (format stream "~&; [Last message occurs ~W times.]~2%"
 		 *last-message-count*)))
   (setq *last-message-count* 0))
 
@@ -261,88 +262,83 @@
 ;;;
 ;;; We suppress printing of messages identical to the previous, but
 ;;; record the number of times that the message is repeated.
-(defmacro print-compiler-message (format-string format-args)
+(defmacro print-compiler-message (stream format-string format-args)
   `(with-compiler-io-syntax
-     (%print-compiler-message ,format-string ,format-args)))
+     (%print-compiler-message ,stream ,format-string ,format-args)))
 
-(defun %print-compiler-message (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 *standard-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*))
+  (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)
-	    (setq last nil)
-            (format stream "~2&; file: ~A~%" (namestring file))))
+	     (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 "; ")
+		 (format stream "  ~A" form))
+	       (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))
 
-	(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)
-      (format stream "~&")
-      (pprint-logical-block (stream nil :per-line-prefix "; ")
-        (format stream "~&~?" format-string format-args))
-      (format stream "~&")))
+  ;; 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))
@@ -358,9 +354,9 @@
 		(warning 'warning)
 		((or error compiler-error) 'error))))
     (print-compiler-message
+     *error-output*
      (format nil "caught ~S:~%~~@<  ~~@;~~A~~:>" what)
-     (list (with-output-to-string (s) (princ condition s)))))
-  (values))
+     (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
@@ -380,56 +376,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*
+(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)))
-    (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*)
-      (print-compiler-message 
-       (format nil "note: ~~A")
-       (list (with-output-to-string (s) (princ condition s))))))
-  (values))
+      (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 (&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 *standard-output*))
+  ;; 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)
+	(with-condition (condition (car rest) (cdr rest))
+	  (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))))
+	    (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 *standard-output* format-string format-args)
-  (force-output *standard-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

src/compiler/main.lisp

@@ -243,21 +243,20 @@
 	       (zerop *compiler-warning-count*)
 	       (zerop *compiler-style-warning-count*)
 	       (zerop *compiler-note-count*))
-    (fresh-line *standard-output*)
-    (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
-      (compiler-mumble "compilation unit ~:[finished~;aborted~]~
-                       ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
-                       ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
-                       ~[~:;~:*~&  caught ~W WARNING condition~:P~]~
-                       ~[~:;~:*~&  caught ~W STYLE-WARNING condition~:P~]~
-                       ~[~:;~:*~&  printed ~W note~:P~]"
-		       abort-p
-		       *aborted-compilation-unit-count*
-		       *compiler-error-count*
-		       *compiler-warning-count*
-		       *compiler-style-warning-count*
-		       *compiler-note-count*)))
-  (fresh-line *standard-output*))
+    (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+      (format *error-output* "~&compilation unit ~:[finished~;aborted~]~
+                             ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
+                             ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
+                             ~[~:;~:*~&  caught ~W WARNING condition~:P~]~
+                             ~[~:;~:*~&  caught ~W STYLE-WARNING condition~:P~]~
+                             ~[~:;~:*~&  printed ~W note~:P~]~%"
+	      abort-p
+	      *aborted-compilation-unit-count*
+	      *compiler-error-count*
+	      *compiler-warning-count*
+	      *compiler-style-warning-count*
+	      *compiler-note-count*))
+    (force-output *error-output*)))
 
 ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
 ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and

tests/compiler-output-test.lisp

@@ -0,0 +1,16 @@
+;;; compiled by compiler.impure.lisp
+
+(defun square (x)
+  (declare (optimize speed))
+  (* x x))
+
+(defun unused-var (x)
+  1)
+
+(defun style-thing (&optional x &key y)
+  (cons x y))
+
+(defun (bad name) ())
+
+;; "fatal error" from this one
+)

tests/compiler.impure.lisp

@@ -990,5 +990,13 @@
 	  (grovel-results name))))))
 (identify-suspect-vops)
 
+;;;; tests for compiler output
+(let* ((*error-output* (make-broadcast-stream))
+       (output (with-output-to-string (*standard-output*)
+		 (compile-file "compiler-output-test.lisp" 
+			       :print nil :verbose nil))))
+  (print output)
+  (assert (zerop (length output))))
+
 ;;; success
 (quit :unix-status 104)

tests/eval.impure.lisp

@@ -131,5 +131,10 @@
 (assert (eq (eval '(function function-eq-test))
             (funcall (compile nil '(lambda () (function function-eq-test))))))
 
+;;; No extra output, please
+(assert (equal ".."
+	       (with-output-to-string (*standard-output*)
+		 (eval '(progn (princ ".") (let ((x 42)) t) (princ "."))))))
+
 ;;; success
 (sb-ext:quit :unix-status 104)

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.21.11"
+"0.8.21.12"