X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=ea341140ddffcd0b5529e9ed640c290f2a94c4f8;hb=cf4cb9554515c59eddbde38d1cf236339c37f55f;hp=6f18bd4479c453fd80eb7ec6b49ae76ec093d024;hpb=d814ff09969434c1d5225786da1c01d7a959cba0;p=sbcl.git diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 6f18bd4..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 @@ -403,16 +383,9 @@ (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))) + (print-compiler-message + (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what) + (list (with-output-to-string (s) (princ condition s))))) (values)) ;;; The act of signalling one of these beasts must not cause WARNINGSP @@ -445,15 +418,9 @@ has written, having proved that it is unreachable.")) (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)))) + (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. @@ -499,7 +466,7 @@ has written, having proved that it is unreachable.")) (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)) @@ -564,13 +531,27 @@ has written, having proved that it is unreachable.")) ;; 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))