From 4099112d8e4687f266922f0e044fba8f17dddcf6 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 1 Apr 2005 16:48:03 +0000 Subject: [PATCH] 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 | 2 + src/code/eval.lisp | 3 +- src/compiler/ir1report.lisp | 237 +++++++++++++++++++-------------------- src/compiler/main.lisp | 29 +++-- tests/compiler-output-test.lisp | 16 +++ tests/compiler.impure.lisp | 8 ++ tests/eval.impure.lisp | 5 + version.lisp-expr | 2 +- 8 files changed, 165 insertions(+), 137 deletions(-) create mode 100644 tests/compiler-output-test.lisp diff --git a/NEWS b/NEWS index c74b7b0..bf21ede 100644 --- a/NEWS +++ b/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. diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 9bd74e2..70bd2ea 100644 --- a/src/code/eval.lisp +++ b/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. diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 6dbedfb..b297eb4 100644 --- a/src/compiler/ir1report.lisp +++ b/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*)) - - (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) - (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 "; ") + (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)) + + ;; 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)) - -;;; 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*)) + (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) + (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 diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 9ecb1bc..6c59dee 100644 --- a/src/compiler/main.lisp +++ b/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 diff --git a/tests/compiler-output-test.lisp b/tests/compiler-output-test.lisp new file mode 100644 index 0000000..b9a2884 --- /dev/null +++ b/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 +) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index d371ea9..cf2a75e 100644 --- a/tests/compiler.impure.lisp +++ b/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) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 3f0ca03..6b22474 100644 --- a/tests/eval.impure.lisp +++ b/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) diff --git a/version.lisp-expr b/version.lisp-expr index 2422444..307173a 100644 --- a/version.lisp-expr +++ b/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" -- 1.7.10.4