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 (with-unique-names (whole)
89 `(setf (gethash ',name *source-context-methods*)
91 (destructuring-bind ,lambda-list ,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
178 ;;; If OLD-CONTEXTS is passed in, and includes a context with the
179 ;;; same original source path as the new context would have, the old
180 ;;; context is reused instead, and a secondary value of T is returned.
181 (defun find-error-context (args &optional old-contexts)
182 (let ((context *compiler-error-context*))
183 (if (compiler-error-context-p context)
185 (let* ((path (or (and (boundp '*current-path*) *current-path*)
187 (node-source-path context)
190 (find (when path (source-path-original-source path))
191 (remove-if #'null old-contexts)
193 :key #'compiler-error-context-original-source-path)))
196 (when (and *source-info* path)
197 (multiple-value-bind (form src-context) (find-original-source path)
198 (collect ((full nil cons)
200 (let ((forms (source-path-forms path))
202 (dolist (src (if (member (first forms) args)
205 (if (>= n *enclosing-source-cutoff*)
206 (short (stringify-form (if (consp src)
210 (full (stringify-form src)))
213 (let* ((tlf (source-path-tlf-number path))
214 (file-info (source-info-file-info *source-info*)))
216 (make-compiler-error-context
217 :enclosing-source (short)
219 :original-source (stringify-form form)
221 :file-name (file-info-name file-info)
223 (multiple-value-bind (ignore pos)
224 (find-source-root tlf *source-info*)
225 (declare (ignore ignore))
227 :original-source-path (source-path-original-source path)
229 (node-lexenv context)
230 (if (boundp '*lexenv*) *lexenv* nil)))
233 ;;;; printing error messages
235 ;;; We save the context information that we printed out most recently
236 ;;; so that we don't print it out redundantly.
238 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
239 (defvar *last-error-context* nil)
240 (declaim (type (or compiler-error-context null) *last-error-context*))
242 ;;; The format string and args for the last error we printed.
243 (defvar *last-format-string* nil)
244 (defvar *last-format-args* nil)
245 (declaim (type (or string null) *last-format-string*))
246 (declaim (type list *last-format-args*))
248 ;;; The number of times that the last error message has been emitted,
249 ;;; so that we can compress duplicate error messages.
250 (defvar *last-message-count* 0)
251 (declaim (type index *last-message-count*))
253 ;;; If the last message was given more than once, then print out an
254 ;;; indication of how many times it was repeated. We reset the message
255 ;;; count when we are done.
256 (defun note-message-repeats (stream &optional (terpri t))
257 (cond ((= *last-message-count* 1)
260 ((> *last-message-count* 1)
261 (format stream "~&; [Last message occurs ~W times.]~2%"
262 *last-message-count*)))
263 (setq *last-message-count* 0))
265 ;;; Print out the message, with appropriate context if we can find it.
266 ;;; If the context is different from the context of the last message
267 ;;; we printed, then we print the context. If the original source is
268 ;;; different from the source we are working on, then we print the
269 ;;; current source in addition to the original source.
271 ;;; We suppress printing of messages identical to the previous, but
272 ;;; record the number of times that the message is repeated.
273 (defmacro print-compiler-message (stream format-string format-args)
274 `(with-compiler-io-syntax
275 (%print-compiler-message ,stream ,format-string ,format-args)))
277 (defun %print-compiler-message (stream format-string format-args)
278 (declare (type simple-string format-string))
279 (declare (type list format-args))
280 (let ((context (find-error-context format-args)))
282 (let ((file (compiler-error-context-file-name context))
283 (in (compiler-error-context-context context))
284 (form (compiler-error-context-original-source context))
285 (enclosing (compiler-error-context-enclosing-source context))
286 (source (compiler-error-context-source context))
287 (last *last-error-context*))
290 (equal file (compiler-error-context-file-name last)))
291 (when (pathnamep file)
292 (note-message-repeats stream)
294 (format stream "~2&; file: ~A~%" (namestring file))))
297 (equal in (compiler-error-context-context last)))
298 (note-message-repeats stream)
300 (pprint-logical-block (stream nil :per-line-prefix "; ")
301 (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
306 (compiler-error-context-original-source last)))
307 (note-message-repeats stream)
309 (pprint-logical-block (stream nil :per-line-prefix "; ")
315 (compiler-error-context-enclosing-source last)))
317 (note-message-repeats stream)
319 (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
322 (equal source (compiler-error-context-source last)))
323 (setq *last-format-string* nil)
325 (note-message-repeats stream)
328 (write-string "; ==>" stream)
330 (pprint-logical-block (stream nil :per-line-prefix "; ")
331 (write-string src stream)))))))
334 (note-message-repeats stream)
335 (setq *last-format-string* nil)))
337 (setq *last-error-context* context))
339 ;; FIXME: this testing for effective equality of compiler messages
340 ;; is ugly, and really ought to be done at a higher level.
341 (unless (and (equal format-string *last-format-string*)
342 (tree-equal format-args *last-format-args*))
343 (note-message-repeats stream nil)
344 (setq *last-format-string* format-string)
345 (setq *last-format-args* format-args)
347 (pprint-logical-block (stream nil :per-line-prefix "; ")
348 (format stream "~&~?" format-string format-args))
351 (incf *last-message-count*)
354 (defun print-compiler-condition (condition)
355 (declare (type condition condition))
356 (let (;; These different classes of conditions have different
357 ;; effects on the return codes of COMPILE-FILE, so it's nice
358 ;; for users to be able to pick them out by lexical search
359 ;; through the output.
360 (what (etypecase condition
361 (style-warning 'style-warning)
363 ((or error compiler-error) 'error))))
364 (print-compiler-message
366 (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what)
367 (list (princ-to-string condition)))))
369 ;;; The act of signalling one of these beasts must not cause WARNINGSP
370 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
371 ;;; inherit from WARNING or STYLE-WARNING.
373 ;;; FIXME: the handling of compiler-notes could be unified with
374 ;;; warnings and style-warnings (see the various handler functions
376 (define-condition compiler-note (condition) ()
378 "Root of the hierarchy of conditions representing information discovered
379 by the compiler that the user might wish to know, but which does not merit
380 a STYLE-WARNING (or any more serious condition)."))
381 (define-condition simple-compiler-note (simple-condition compiler-note) ())
382 (define-condition code-deletion-note (simple-compiler-note) ()
384 "A condition type signalled when the compiler deletes code that the user
385 has written, having proved that it is unreachable."))
387 (macrolet ((with-condition ((condition datum args) &body body)
388 (with-unique-names (block)
391 (coerce-to-condition ,datum ,args
392 'simple-compiler-note
397 (return-from ,block (values))))
401 (defun compiler-notify (datum &rest args)
402 (unless (if *compiler-error-context*
403 (policy *compiler-error-context* (= inhibit-warnings 3))
404 (policy *lexenv* (= inhibit-warnings 3)))
405 (with-condition (condition datum args)
406 (incf *compiler-note-count*)
407 (print-compiler-message
409 (format nil "note: ~~A")
410 (list (princ-to-string condition)))))
413 ;; Issue a note when we might or might not be in the compiler.
414 (defun maybe-compiler-notify (datum &rest args)
415 (if (boundp '*lexenv*) ; if we're in the compiler
416 (apply #'compiler-notify datum args)
417 (with-condition (condition datum args)
418 (let ((stream *error-output*))
419 (pprint-logical-block (stream nil :per-line-prefix ";")
420 (format stream " note: ~3I~_")
421 (pprint-logical-block (stream nil)
422 (format stream "~A" condition)))
423 ;; (outside logical block, no per-line-prefix)
424 (fresh-line stream))))))
426 ;;; The politically correct way to print out progress messages and
427 ;;; such like. We clear the current error context so that we know that
428 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
429 ;;; message gets seen right away.
430 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
431 (defun compiler-mumble (control &rest args)
432 (let ((stream *standard-output*))
433 (note-message-repeats stream)
434 (setq *last-error-context* nil)
435 (apply #'format stream control args)
436 (force-output stream)
439 ;;; Return a string that somehow names the code in COMPONENT. We use
440 ;;; the source path for the bind node for an arbitrary entry point to
441 ;;; find the source context, then return that as a string.
442 (declaim (ftype (function (component) simple-string) find-component-name))
443 (defun find-component-name (component)
444 (let ((ep (first (block-succ (component-head component)))))
445 (aver ep) ; else no entry points??
446 (multiple-value-bind (form context)
447 (find-original-source (node-source-path (block-start-node ep)))
448 (declare (ignore form))
449 (let ((*print-level* 2)
450 (*print-pretty* nil))
451 (format nil "~{~{~S~^ ~}~^ => ~}"
452 #+sb-xc-host (list (list (caar context)))
453 #-sb-xc-host context)))))
455 ;;;; condition system interface
457 ;;; Keep track of how many times each kind of condition happens.
458 (defvar *compiler-error-count*)
459 (defvar *compiler-warning-count*)
460 (defvar *compiler-style-warning-count*)
461 (defvar *compiler-note-count*)
463 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
464 ;;; should return WARNINGS-P or FAILURE-P.
466 (defvar *warnings-p*)
468 ;;; condition handlers established by the compiler. We re-signal the
469 ;;; condition, then if it isn't handled, we increment our warning
470 ;;; counter and print the error message.
471 (defun compiler-error-handler (condition)
473 (incf *compiler-error-count*)
476 (print-compiler-condition condition)
477 (continue condition))
478 (defun compiler-warning-handler (condition)
480 (incf *compiler-warning-count*)
483 (print-compiler-condition condition)
484 (muffle-warning condition))
485 (defun compiler-style-warning-handler (condition)
487 (incf *compiler-style-warning-count*)
488 (setf *warnings-p* t)
489 (print-compiler-condition condition)
490 (muffle-warning condition))
492 ;;;; undefined warnings
494 (defvar *undefined-warning-limit* 3
496 "If non-null, then an upper limit on the number of unknown function or type
497 warnings that the compiler will print for any given name in a single
498 compilation. This prevents excessive amounts of output when the real
499 problem is a missing definition (as opposed to a typo in the use.)")
501 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
502 ;;; to NAME of the specified KIND. If we have exceeded the warning
503 ;;; limit, then just increment the count, otherwise note the current
506 ;;; Undefined types are noted by a condition handler in
507 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
508 ;;; the compiler, hence the BOUNDP check.
509 (defun note-undefined-reference (name kind)
511 ;; Check for boundness so we don't blow up if we're called
512 ;; when IR1 conversion isn't going on.
515 ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
516 ;; isn't a good idea; we should have INHIBIT-WARNINGS
517 ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
518 ;; sure what the BOUNDP '*LEXENV* test above is for; it's
519 ;; likely a good idea, but it probably deserves an
520 ;; explanatory comment.
521 (policy *lexenv* (= inhibit-warnings 3))
522 ;; KLUDGE: weird decoupling between here and where we're
523 ;; going to signal the condition. I don't think we can
524 ;; rewrite this using SIGNAL and RESTART-CASE (to take
525 ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
526 ;; handler, because if that doesn't handle it the ordinary
527 ;; compiler handlers will trigger.
530 (:variable (make-condition 'warning))
531 ((:function :type) (make-condition 'style-warning)))
533 (rassoc 'muffle-warning
534 (lexenv-handled-conditions *lexenv*))))))
535 (let* ((found (dolist (warning *undefined-warnings* nil)
536 (when (and (equal (undefined-warning-name warning) name)
537 (eq (undefined-warning-kind warning) kind))
540 (make-undefined-warning :name name :kind kind))))
541 (unless found (push res *undefined-warnings*))
542 (multiple-value-bind (context old)
543 (find-error-context (list name) (undefined-warning-warnings res))
545 (when (or (not *undefined-warning-limit*)
546 (< (undefined-warning-count res) *undefined-warning-limit*))
547 (push context (undefined-warning-warnings res)))
548 (incf (undefined-warning-count res))))))