X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=ea341140ddffcd0b5529e9ed640c290f2a94c4f8;hb=ace140856e6b3f92bb06597092a59753f1e59142;hp=c8dced28c4e11de16e0c6ff41c659bbcfd55b459;hpb=148e3820ad314a9b59d0133c1d60eaac4af9118b;p=sbcl.git diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index c8dced2..ea34114 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -72,7 +72,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. @@ -195,31 +197,6 @@ (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 " where 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 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))) - ;;; 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 @@ -264,7 +241,10 @@ (declare (ignore ignore)) pos) :original-source-path - (source-path-original-source path)))))))))) + (source-path-original-source path) + :lexenv (if context + (node-lexenv context) + (if (boundp '*lexenv*) *lexenv* nil))))))))))) ;;;; printing error messages @@ -375,6 +355,8 @@ (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) @@ -400,48 +382,68 @@ (what (etypecase condition (style-warning 'style-warning) (warning 'warning) - (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))) + ((or error compiler-error) 'error)))) + (print-compiler-message + (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what) + (list (with-output-to-string (s) (princ condition s))))) (values)) -;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output -;;; instead of signalling. (In CMU CL, it did signal a condition, but -;;; this didn't seem to work all that well; it was weird to have -;;; COMPILE-FILE return with WARNINGS-P set when the only problem was -;;; that the compiler couldn't figure out how to compile something as -;;; efficiently as it liked.) -(defun compiler-note (format-string &rest format-args) +;;; 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 +;;; inherit from WARNING or STYLE-WARNING. +;;; +;;; FIXME: the handling of compiler-notes could be unified with +;;; warnings and style-warnings (see the various handler functions +;;; below). +(define-condition compiler-note (condition) () + (:documentation + "Root of the hierarchy of conditions representing information discovered +by the compiler that the user might wish to know, but which does not merit +a STYLE-WARNING (or any more serious condition).")) +(define-condition simple-compiler-note (simple-condition compiler-note) ()) +(define-condition code-deletion-note (simple-compiler-note) () + (:documentation + "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))) - (incf *compiler-note-count*) - (print-compiler-message (format nil "note: ~A" format-string) - format-args)) + (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-note (&rest rest) +(defun maybe-compiler-notify (&rest rest) (if (boundp '*lexenv*) ; if we're in the compiler - (apply #'compiler-note rest) - (let ((stream *error-output*)) - (pprint-logical-block (stream nil :per-line-prefix ";") - - (format stream " note: ~3I~_") - (pprint-logical-block (stream nil) - (apply #'format stream rest))) - (fresh-line stream)))) ; (outside logical block, no per-line-prefix) + (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)))) ;;; The politically correct way to print out progress messages and ;;; such like. We clear the current error context so that we know that @@ -464,7 +466,7 @@ (aver ep) ; else no entry points?? (multiple-value-bind (form context) (find-original-source - (node-source-path (continuation-next (block-start ep)))) + (node-source-path (block-start-node ep))) (declare (ignore form)) (let ((*print-level* 2) (*print-pretty* nil)) @@ -529,13 +531,27 @@ ;; 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))) + (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))