X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=b297eb4dc7e50620c4ea95fcb862dd0054c7adc6;hb=5ecef987f3847ed5de8c03f66ef9d8ab468af993;hp=6828f90e1c9995df803a3cf5f8060391d613be7e;hpb=0794cd3908a441222f430ba0cf3bb7c3e1a96c63;p=sbcl.git diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 6828f90..b297eb4 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 @@ -188,14 +167,11 @@ ;;; 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))))) + (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 @@ -269,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 *error-output*))) + (when terpri + (terpri stream))) ((> *last-message-count* 1) - (format *error-output* "~&; [Last message occurs ~W times.]~2%" + (format stream "~&; [Last message occurs ~W times.]~2%" *last-message-count*))) (setq *last-message-count* 0)) @@ -285,91 +262,84 @@ ;;; ;;; 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 list format-args)) + (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)) - (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 "~&")))) - (incf *last-message-count*) (values)) @@ -383,17 +353,10 @@ (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)) + (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 @@ -413,62 +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*) - (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)))) + (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 *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