1 ;;;; machinery for reporting errors/warnings/notes/whatnot from
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;;; compiler error context determination
17 (declaim (special *current-path
*))
19 (defvar *enclosing-source-cutoff
* 1
21 "The maximum number of enclosing non-original source forms (i.e. from
22 macroexpansion) that we print in full. For additional enclosing forms, we
24 (declaim (type unsigned-byte
*enclosing-source-cutoff
*))
26 ;;; We separate the determination of compiler error contexts from the
27 ;;; actual signalling of those errors by objectifying the error
28 ;;; context. This allows postponement of the determination of how (and
29 ;;; if) to signal the error.
31 ;;; We take care not to reference any of the IR1 so that pending
32 ;;; potential error messages won't prevent the IR1 from being GC'd. To
33 ;;; this end, we convert source forms to strings so that source forms
34 ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
35 (defstruct (compiler-error-context
36 #-no-ansi-print-object
37 (:print-object
(lambda (x stream
)
38 (print-unreadable-object (x stream
:type t
))))
40 ;; a list of the stringified CARs of the enclosing non-original source forms
41 ;; exceeding the *enclosing-source-cutoff*
42 (enclosing-source nil
:type list
)
43 ;; a list of stringified enclosing non-original source forms
44 (source nil
:type list
)
45 ;; the stringified form in the original source that expanded into SOURCE
46 (original-source (missing-arg) :type simple-string
)
47 ;; a list of prefixes of "interesting" forms that enclose original-source
48 (context nil
:type list
)
49 ;; the FILE-INFO-NAME for the relevant FILE-INFO
50 (file-name (missing-arg) :type
(or pathname
(member :lisp
:stream
)))
51 ;; the file position at which the top level form starts, if applicable
52 (file-position nil
:type
(or index null
))
53 ;; the original source part of the source path
54 (original-source-path nil
:type list
)
55 ;; the lexenv active at the time
56 (lexenv nil
:type
(or null lexenv
)))
58 ;;; If true, this is the node which is used as context in compiler warning
60 (declaim (type (or null compiler-error-context node
) *compiler-error-context
*))
61 (defvar *compiler-error-context
* nil
)
63 ;;; a hashtable mapping macro names to source context parsers. Each parser
64 ;;; function returns the source-context list for that form.
65 (defvar *source-context-methods
* (make-hash-table))
67 ;;; documentation originally from cmu-user.tex:
68 ;;; This macro defines how to extract an abbreviated source context from
69 ;;; the \var{name}d form when it appears in the compiler input.
70 ;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
71 ;;; parse the arguments. The \var{body} should return a list of
72 ;;; subforms that can be printed on about one line. There are
73 ;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
74 ;;; no method is defined, then the first two subforms are returned.
75 ;;; Note that this facility implicitly determines the string name
76 ;;; associated with anonymous functions.
77 ;;; So even though SBCL itself only uses this macro within this file,
78 ;;; it's a reasonable thing to put in SB-EXT in case some dedicated
79 ;;; user wants to do some heavy tweaking to make SBCL give more
80 ;;; informative output about his code.
81 (defmacro define-source-context
(name lambda-list
&body body
)
83 "DEFINE-SOURCE-CONTEXT Name Lambda-List Form*
84 This macro defines how to extract an abbreviated source context from the
85 Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
86 style lambda-list used to parse the arguments. The Body should return a
87 list of subforms suitable for a \"~{~S ~}\" format string."
88 (let ((n-whole (gensym)))
89 `(setf (gethash ',name
*source-context-methods
*)
91 (destructuring-bind ,lambda-list
,n-whole
,@body
)))))
93 (define-source-context defstruct
(name-or-options &rest slots
)
94 (declare (ignore slots
))
95 `(defstruct ,(if (consp name-or-options
)
99 (define-source-context function
(thing)
100 (if (and (consp thing
) (eq (first thing
) 'lambda
) (consp (rest thing
)))
101 `(lambda ,(second thing
))
104 ;;; Return the first two elements of FORM if FORM is a list. Take the
105 ;;; CAR of the second form if appropriate.
106 (defun source-form-context (form)
107 (cond ((atom form
) nil
)
108 ((>= (length form
) 2)
109 (let* ((context-fun-default (lambda (x)
111 (list (first form
) (second form
))))
112 (context-fun (gethash (first form
)
113 *source-context-methods
*
114 context-fun-default
)))
115 (declare (type function context-fun
))
116 (funcall context-fun
(rest form
))))
120 ;;; Given a source path, return the original source form and a
121 ;;; description of the interesting aspects of the context in which it
122 ;;; appeared. The context is a list of lists, one sublist per context
123 ;;; form. The sublist is a list of some of the initial subforms of the
126 ;;; For now, we use the first two subforms of each interesting form. A
127 ;;; form is interesting if the first element is a symbol beginning
128 ;;; with "DEF" and it is not the source form. If there is no
129 ;;; DEF-mumble, then we use the outermost containing form. If the
130 ;;; second subform is a list, then in some cases we return the CAR of
131 ;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
133 (defun find-original-source (path)
134 (declare (list path
))
135 (let* ((rpath (reverse (source-path-original-source path
)))
137 (root (find-source-root tlf
*source-info
*)))
140 (current (rest rpath
)))
143 (aver (null current
))
145 (let ((head (first form
)))
147 (let ((name (symbol-name head
)))
148 (when (and (>= (length name
) 3) (string= name
"DEF" :end1
3))
149 (context (source-form-context form
))))))
150 (when (null current
) (return))
151 (setq form
(nth (pop current
) form
)))
154 (values form
(context)))
156 (let ((c (source-form-context root
)))
157 (values form
(if c
(list c
) nil
))))
159 (values '(unable to locate source
)
160 '((some strange place
)))))))))
162 ;;; Convert a source form to a string, suitably formatted for use in
163 ;;; compiler warnings.
164 (defun stringify-form (form &optional
(pretty t
))
165 (with-standard-io-syntax
166 (with-compiler-io-syntax
167 (let ((*print-pretty
* pretty
))
169 (format nil
"~<~@; ~S~:>" (list form
))
170 (prin1-to-string form
))))))
172 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
173 ;;; error context, or NIL if we can't figure anything out. ARGS is a
174 ;;; list of things that are going to be printed out in the error
175 ;;; message, and can thus be blown off when they appear in the source
177 (defun find-error-context (args)
178 (let ((context *compiler-error-context
*))
179 (if (compiler-error-context-p context
)
181 (let ((path (or (and (boundp '*current-path
*) *current-path
*)
183 (node-source-path context
)
185 (when (and *source-info
* path
)
186 (multiple-value-bind (form src-context
) (find-original-source path
)
187 (collect ((full nil cons
)
189 (let ((forms (source-path-forms path
))
191 (dolist (src (if (member (first forms
) args
)
194 (if (>= n
*enclosing-source-cutoff
*)
195 (short (stringify-form (if (consp src
)
199 (full (stringify-form src
)))
202 (let* ((tlf (source-path-tlf-number path
))
203 (file-info (source-info-file-info *source-info
*)))
204 (make-compiler-error-context
205 :enclosing-source
(short)
207 :original-source
(stringify-form form
)
209 :file-name
(file-info-name file-info
)
211 (multiple-value-bind (ignore pos
)
212 (find-source-root tlf
*source-info
*)
213 (declare (ignore ignore
))
215 :original-source-path
216 (source-path-original-source path
)
218 (node-lexenv context
)
219 (if (boundp '*lexenv
*) *lexenv
* nil
)))))))))))
221 ;;;; printing error messages
223 ;;; We save the context information that we printed out most recently
224 ;;; so that we don't print it out redundantly.
226 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
227 (defvar *last-error-context
* nil
)
228 (declaim (type (or compiler-error-context null
) *last-error-context
*))
230 ;;; The format string and args for the last error we printed.
231 (defvar *last-format-string
* nil
)
232 (defvar *last-format-args
* nil
)
233 (declaim (type (or string null
) *last-format-string
*))
234 (declaim (type list
*last-format-args
*))
236 ;;; The number of times that the last error message has been emitted,
237 ;;; so that we can compress duplicate error messages.
238 (defvar *last-message-count
* 0)
239 (declaim (type index
*last-message-count
*))
241 ;;; If the last message was given more than once, then print out an
242 ;;; indication of how many times it was repeated. We reset the message
243 ;;; count when we are done.
244 (defun note-message-repeats (stream &optional
(terpri t
))
245 (cond ((= *last-message-count
* 1)
248 ((> *last-message-count
* 1)
249 (format stream
"~&; [Last message occurs ~W times.]~2%"
250 *last-message-count
*)))
251 (setq *last-message-count
* 0))
253 ;;; Print out the message, with appropriate context if we can find it.
254 ;;; If the context is different from the context of the last message
255 ;;; we printed, then we print the context. If the original source is
256 ;;; different from the source we are working on, then we print the
257 ;;; current source in addition to the original source.
259 ;;; We suppress printing of messages identical to the previous, but
260 ;;; record the number of times that the message is repeated.
261 (defmacro print-compiler-message
(stream format-string format-args
)
262 `(with-compiler-io-syntax
263 (%print-compiler-message
,stream
,format-string
,format-args
)))
265 (defun %print-compiler-message
(stream format-string format-args
)
266 (declare (type simple-string format-string
))
267 (declare (type list format-args
))
268 (let ((context (find-error-context format-args
)))
270 (let ((file (compiler-error-context-file-name context
))
271 (in (compiler-error-context-context context
))
272 (form (compiler-error-context-original-source context
))
273 (enclosing (compiler-error-context-enclosing-source context
))
274 (source (compiler-error-context-source context
))
275 (last *last-error-context
*))
278 (equal file
(compiler-error-context-file-name last
)))
279 (when (pathnamep file
)
280 (note-message-repeats stream
)
282 (format stream
"~2&; file: ~A~%" (namestring file
))))
285 (equal in
(compiler-error-context-context last
)))
286 (note-message-repeats stream
)
288 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
289 (format stream
"in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in
))
294 (compiler-error-context-original-source last
)))
295 (note-message-repeats stream
)
297 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
303 (compiler-error-context-enclosing-source last
)))
305 (note-message-repeats stream
)
307 (format stream
"~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing
)))
310 (equal source
(compiler-error-context-source last
)))
311 (setq *last-format-string
* nil
)
313 (note-message-repeats stream
)
316 (write-string "; ==>" stream
)
318 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
319 (write-string src stream
)))))))
322 (note-message-repeats stream
)
323 (setq *last-format-string
* nil
)))
325 (setq *last-error-context
* context
))
327 ;; FIXME: this testing for effective equality of compiler messages
328 ;; is ugly, and really ought to be done at a higher level.
329 (unless (and (equal format-string
*last-format-string
*)
330 (tree-equal format-args
*last-format-args
*))
331 (note-message-repeats stream nil
)
332 (setq *last-format-string
* format-string
)
333 (setq *last-format-args
* format-args
)
335 (pprint-logical-block (stream nil
:per-line-prefix
"; ")
336 (format stream
"~&~?" format-string format-args
))
339 (incf *last-message-count
*)
342 (defun print-compiler-condition (condition)
343 (declare (type condition condition
))
344 (let (;; These different classes of conditions have different
345 ;; effects on the return codes of COMPILE-FILE, so it's nice
346 ;; for users to be able to pick them out by lexical search
347 ;; through the output.
348 (what (etypecase condition
349 (style-warning 'style-warning
)
351 ((or error compiler-error
) 'error
))))
352 (print-compiler-message
354 (format nil
"caught ~S:~%~~@< ~~@;~~A~~:>" what
)
355 (list (princ-to-string condition
)))))
357 ;;; The act of signalling one of these beasts must not cause WARNINGSP
358 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
359 ;;; inherit from WARNING or STYLE-WARNING.
361 ;;; FIXME: the handling of compiler-notes could be unified with
362 ;;; warnings and style-warnings (see the various handler functions
364 (define-condition compiler-note
(condition) ()
366 "Root of the hierarchy of conditions representing information discovered
367 by the compiler that the user might wish to know, but which does not merit
368 a STYLE-WARNING (or any more serious condition)."))
369 (define-condition simple-compiler-note
(simple-condition compiler-note
) ())
370 (define-condition code-deletion-note
(simple-compiler-note) ()
372 "A condition type signalled when the compiler deletes code that the user
373 has written, having proved that it is unreachable."))
375 (macrolet ((with-condition ((condition datum args
) &body body
)
376 (with-unique-names (block)
379 (coerce-to-condition ,datum
,args
380 'simple-compiler-note
385 (return-from ,block
(values))))
389 (defun compiler-notify (datum &rest args
)
390 (unless (if *compiler-error-context
*
391 (policy *compiler-error-context
* (= inhibit-warnings
3))
392 (policy *lexenv
* (= inhibit-warnings
3)))
393 (with-condition (condition datum args
)
394 (incf *compiler-note-count
*)
395 (print-compiler-message
397 (format nil
"note: ~~A")
398 (list (princ-to-string condition
)))))
401 ;; Issue a note when we might or might not be in the compiler.
402 (defun maybe-compiler-notify (datum &rest args
)
403 (if (boundp '*lexenv
*) ; if we're in the compiler
404 (apply #'compiler-notify datum args
)
405 (with-condition (condition datum args
)
406 (let ((stream *error-output
*))
407 (pprint-logical-block (stream nil
:per-line-prefix
";")
408 (format stream
" note: ~3I~_")
409 (pprint-logical-block (stream nil
)
410 (format stream
"~A" condition
)))
411 ;; (outside logical block, no per-line-prefix)
412 (fresh-line stream
))))))
414 ;;; The politically correct way to print out progress messages and
415 ;;; such like. We clear the current error context so that we know that
416 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
417 ;;; message gets seen right away.
418 (declaim (ftype (function (string &rest t
) (values)) compiler-mumble
))
419 (defun compiler-mumble (control &rest args
)
420 (let ((stream *standard-output
*))
421 (note-message-repeats stream
)
422 (setq *last-error-context
* nil
)
423 (apply #'format stream control args
)
424 (force-output stream
)
427 ;;; Return a string that somehow names the code in COMPONENT. We use
428 ;;; the source path for the bind node for an arbitrary entry point to
429 ;;; find the source context, then return that as a string.
430 (declaim (ftype (function (component) simple-string
) find-component-name
))
431 (defun find-component-name (component)
432 (let ((ep (first (block-succ (component-head component
)))))
433 (aver ep
) ; else no entry points??
434 (multiple-value-bind (form context
)
435 (find-original-source
436 (node-source-path (block-start-node ep
)))
437 (declare (ignore form
))
438 (let ((*print-level
* 2)
439 (*print-pretty
* nil
))
440 (format nil
"~{~{~S~^ ~}~^ => ~}" context
)))))
442 ;;;; condition system interface
444 ;;; Keep track of how many times each kind of condition happens.
445 (defvar *compiler-error-count
*)
446 (defvar *compiler-warning-count
*)
447 (defvar *compiler-style-warning-count
*)
448 (defvar *compiler-note-count
*)
450 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
451 ;;; should return WARNINGS-P or FAILURE-P.
453 (defvar *warnings-p
*)
455 ;;; condition handlers established by the compiler. We re-signal the
456 ;;; condition, then if it isn't handled, we increment our warning
457 ;;; counter and print the error message.
458 (defun compiler-error-handler (condition)
460 (incf *compiler-error-count
*)
463 (print-compiler-condition condition
)
464 (continue condition
))
465 (defun compiler-warning-handler (condition)
467 (incf *compiler-warning-count
*)
470 (print-compiler-condition condition
)
471 (muffle-warning condition
))
472 (defun compiler-style-warning-handler (condition)
474 (incf *compiler-style-warning-count
*)
475 (setf *warnings-p
* t
)
476 (print-compiler-condition condition
)
477 (muffle-warning condition
))
479 ;;;; undefined warnings
481 (defvar *undefined-warning-limit
* 3
483 "If non-null, then an upper limit on the number of unknown function or type
484 warnings that the compiler will print for any given name in a single
485 compilation. This prevents excessive amounts of output when the real
486 problem is a missing definition (as opposed to a typo in the use.)")
488 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
489 ;;; to NAME of the specified KIND. If we have exceeded the warning
490 ;;; limit, then just increment the count, otherwise note the current
493 ;;; Undefined types are noted by a condition handler in
494 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
495 ;;; the compiler, hence the BOUNDP check.
496 (defun note-undefined-reference (name kind
)
498 ;; Check for boundness so we don't blow up if we're called
499 ;; when IR1 conversion isn't going on.
502 ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
503 ;; isn't a good idea; we should have INHIBIT-WARNINGS
504 ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
505 ;; sure what the BOUNDP '*LEXENV* test above is for; it's
506 ;; likely a good idea, but it probably deserves an
507 ;; explanatory comment.
508 (policy *lexenv
* (= inhibit-warnings
3))
509 ;; KLUDGE: weird decoupling between here and where we're
510 ;; going to signal the condition. I don't think we can
511 ;; rewrite this using SIGNAL and RESTART-CASE (to take
512 ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
513 ;; handler, because if that doesn't handle it the ordinary
514 ;; compiler handlers will trigger.
517 (:variable
(make-condition 'warning
))
518 ((:function
:type
) (make-condition 'style-warning
)))
520 (rassoc 'muffle-warning
521 (lexenv-handled-conditions *lexenv
*))))))
522 (let* ((found (dolist (warning *undefined-warnings
* nil
)
523 (when (and (equal (undefined-warning-name warning
) name
)
524 (eq (undefined-warning-kind warning
) kind
))
527 (make-undefined-warning :name name
:kind kind
))))
528 (unless found
(push res
*undefined-warnings
*))
529 (when (or (not *undefined-warning-limit
*)
530 (< (undefined-warning-count res
) *undefined-warning-limit
*))
531 (push (find-error-context (list name
))
532 (undefined-warning-warnings res
)))
533 (incf (undefined-warning-count res
))))