(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
;; 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.
;;; 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)))))
-
-;;; 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 <something>" where <something> 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 <something> 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)))
+ (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
(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
;;;
;;; 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 (format-string format-args)
+ `(with-compiler-io-syntax
+ (%print-compiler-message ,format-string ,format-args)))
+(defun %print-compiler-message (format-string format-args)
(declare (type simple-string format-string))
- (declare (type list format-args))
-
+ (declare (type list format-args))
(let ((stream *error-output*)
(context (find-error-context format-args)))
(cond
(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 "~&"))))
-
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "~&~?" format-string format-args))
+ (format stream "~&")))
+
(incf *last-message-count*)
(values))
(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))
projects / sbcl.git / blobdiff