;; 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.
(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)))))))))))
\f
;;;; printing error messages
(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
(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.
;; 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))