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 ;;; We bind print level and length when printing out messages so that
20 ;;; we don't dump huge amounts of garbage.
22 ;;; FIXME: It's not possible to get the defaults right for everyone.
23 ;;; So: Should these variables be in the SB-EXT package? Or should we
24 ;;; just get rid of them completely and just use the bare
25 ;;; CL:*PRINT-FOO* variables instead?
26 (declaim (type (or unsigned-byte null)
27 *compiler-error-print-level*
28 *compiler-error-print-length*
29 *compiler-error-print-lines*))
30 (defvar *compiler-error-print-level* 5
32 "the value for *PRINT-LEVEL* when printing compiler error messages")
33 (defvar *compiler-error-print-length* 10
35 "the value for *PRINT-LENGTH* when printing compiler error messages")
36 (defvar *compiler-error-print-lines* 12
38 "the value for *PRINT-LINES* when printing compiler error messages")
40 (defvar *enclosing-source-cutoff* 1
42 "The maximum number of enclosing non-original source forms (i.e. from
43 macroexpansion) that we print in full. For additional enclosing forms, we
45 (declaim (type unsigned-byte *enclosing-source-cutoff*))
47 ;;; We separate the determination of compiler error contexts from the
48 ;;; actual signalling of those errors by objectifying the error
49 ;;; context. This allows postponement of the determination of how (and
50 ;;; if) to signal the error.
52 ;;; We take care not to reference any of the IR1 so that pending
53 ;;; potential error messages won't prevent the IR1 from being GC'd. To
54 ;;; this end, we convert source forms to strings so that source forms
55 ;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR.
56 (defstruct (compiler-error-context
57 #-no-ansi-print-object
58 (:print-object (lambda (x stream)
59 (print-unreadable-object (x stream :type t))))
61 ;; a list of the stringified CARs of the enclosing non-original source forms
62 ;; exceeding the *enclosing-source-cutoff*
63 (enclosing-source nil :type list)
64 ;; a list of stringified enclosing non-original source forms
65 (source nil :type list)
66 ;; the stringified form in the original source that expanded into SOURCE
67 (original-source (missing-arg) :type simple-string)
68 ;; a list of prefixes of "interesting" forms that enclose original-source
69 (context nil :type list)
70 ;; the FILE-INFO-NAME for the relevant FILE-INFO
71 (file-name (missing-arg) :type (or pathname (member :lisp :stream)))
72 ;; the file position at which the top level form starts, if applicable
73 (file-position nil :type (or index null))
74 ;; the original source part of the source path
75 (original-source-path nil :type list))
77 ;;; If true, this is the node which is used as context in compiler warning
79 (declaim (type (or null compiler-error-context node) *compiler-error-context*))
80 (defvar *compiler-error-context* nil)
82 ;;; a hashtable mapping macro names to source context parsers. Each parser
83 ;;; function returns the source-context list for that form.
84 (defvar *source-context-methods* (make-hash-table))
86 ;;; documentation originally from cmu-user.tex:
87 ;;; This macro defines how to extract an abbreviated source context from
88 ;;; the \var{name}d form when it appears in the compiler input.
89 ;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
90 ;;; parse the arguments. The \var{body} should return a list of
91 ;;; subforms that can be printed on about one line. There are
92 ;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
93 ;;; no method is defined, then the first two subforms are returned.
94 ;;; Note that this facility implicitly determines the string name
95 ;;; associated with anonymous functions.
96 ;;; So even though SBCL itself only uses this macro within this file,
97 ;;; it's a reasonable thing to put in SB-EXT in case some dedicated
98 ;;; user wants to do some heavy tweaking to make SBCL give more
99 ;;; informative output about his code.
100 (defmacro define-source-context (name lambda-list &body body)
102 "DEFINE-SOURCE-CONTEXT Name Lambda-List Form*
103 This macro defines how to extract an abbreviated source context from the
104 Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
105 style lambda-list used to parse the arguments. The Body should return a
106 list of subforms suitable for a \"~{~S ~}\" format string."
107 (let ((n-whole (gensym)))
108 `(setf (gethash ',name *source-context-methods*)
110 (destructuring-bind ,lambda-list ,n-whole ,@body)))))
112 (defmacro def-source-context (&rest rest)
113 (deprecation-warning 'def-source-context 'define-source-context)
114 `(define-source-context ,@rest))
116 (define-source-context defstruct (name-or-options &rest slots)
117 (declare (ignore slots))
118 `(defstruct ,(if (consp name-or-options)
119 (car name-or-options)
122 (define-source-context function (thing)
123 (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
124 `(lambda ,(second thing))
127 ;;; Return the first two elements of FORM if FORM is a list. Take the
128 ;;; CAR of the second form if appropriate.
129 (defun source-form-context (form)
130 (cond ((atom form) nil)
131 ((>= (length form) 2)
132 (funcall (gethash (first form) *source-context-methods*
135 (list (first form) (second form))))
140 ;;; Given a source path, return the original source form and a
141 ;;; description of the interesting aspects of the context in which it
142 ;;; appeared. The context is a list of lists, one sublist per context
143 ;;; form. The sublist is a list of some of the initial subforms of the
146 ;;; For now, we use the first two subforms of each interesting form. A
147 ;;; form is interesting if the first element is a symbol beginning
148 ;;; with "DEF" and it is not the source form. If there is no
149 ;;; DEF-mumble, then we use the outermost containing form. If the
150 ;;; second subform is a list, then in some cases we return the CAR of
151 ;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
153 (defun find-original-source (path)
154 (declare (list path))
155 (let* ((rpath (reverse (source-path-original-source path)))
157 (root (find-source-root tlf *source-info*)))
160 (current (rest rpath)))
163 (aver (null current))
165 (let ((head (first form)))
167 (let ((name (symbol-name head)))
168 (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
169 (context (source-form-context form))))))
170 (when (null current) (return))
171 (setq form (nth (pop current) form)))
174 (values form (context)))
176 (let ((c (source-form-context root)))
177 (values form (if c (list c) nil))))
179 (values '(unable to locate source)
180 '((some strange place)))))))))
182 ;;; Convert a source form to a string, suitably formatted for use in
183 ;;; compiler warnings.
184 (defun stringify-form (form &optional (pretty t))
185 (with-standard-io-syntax
186 (let ((*print-readably* nil)
187 (*print-pretty* pretty)
188 (*print-level* *compiler-error-print-level*)
189 (*print-length* *compiler-error-print-length*)
190 (*print-lines* *compiler-error-print-lines*))
192 (format nil "~<~@; ~S~:>" (list form))
193 (prin1-to-string form)))))
195 ;;; shorthand for creating debug names from source names or other
197 ;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
198 ;;; (DEBUG-NAMIFY "top level form ~S" FORM)
200 ;;; FIXME: This function seems to have a lot in common with
201 ;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
203 (defun debug-namify (format-string &rest format-arguments)
204 (with-standard-io-syntax
205 (let ((*print-readably* nil)
206 (*package* *cl-package*)
209 (apply #'format nil format-string format-arguments))))
211 ;;; shorthand for a repeated idiom in creating debug names
213 ;;; the problem, part I: We want to create debug names that look like
214 ;;; "&MORE processor for <something>" where <something> might be
215 ;;; either a source-name value (typically a symbol) or a non-symbol
216 ;;; debug-name value (typically a string). It's awkward to handle this
217 ;;; with FORMAT because we'd like to splice a source-name value using
218 ;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
219 ;;; (to avoid irrelevant quotes at string splice boundaries).
221 ;;; the problem, part II: The <something> is represented as a pair
222 ;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
223 ;;; if it's not null.
225 ;;; the solution: Use this function to convert whatever it is to a
226 ;;; string, which FORMAT can then splice using "~A".
227 (defun as-debug-name (source-name debug-name)
229 (debug-namify "~S" source-name)
232 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
233 ;;; error context, or NIL if we can't figure anything out. ARGS is a
234 ;;; list of things that are going to be printed out in the error
235 ;;; message, and can thus be blown off when they appear in the source
237 (defun find-error-context (args)
238 (let ((context *compiler-error-context*))
239 (if (compiler-error-context-p context)
241 (let ((path (or (and (boundp '*current-path*) *current-path*)
243 (node-source-path context)
245 (when (and *source-info* path)
246 (multiple-value-bind (form src-context) (find-original-source path)
247 (collect ((full nil cons)
249 (let ((forms (source-path-forms path))
251 (dolist (src (if (member (first forms) args)
254 (if (>= n *enclosing-source-cutoff*)
255 (short (stringify-form (if (consp src)
259 (full (stringify-form src)))
262 (let* ((tlf (source-path-tlf-number path))
263 (file-info (source-info-file-info *source-info*)))
264 (make-compiler-error-context
265 :enclosing-source (short)
267 :original-source (stringify-form form)
269 :file-name (file-info-name file-info)
271 (multiple-value-bind (ignore pos)
272 (find-source-root tlf *source-info*)
273 (declare (ignore ignore))
275 :original-source-path
276 (source-path-original-source path))))))))))
278 ;;;; printing error messages
280 ;;; We save the context information that we printed out most recently
281 ;;; so that we don't print it out redundantly.
283 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
284 (defvar *last-error-context* nil)
285 (declaim (type (or compiler-error-context null) *last-error-context*))
287 ;;; The format string and args for the last error we printed.
288 (defvar *last-format-string* nil)
289 (defvar *last-format-args* nil)
290 (declaim (type (or string null) *last-format-string*))
291 (declaim (type list *last-format-args*))
293 ;;; The number of times that the last error message has been emitted,
294 ;;; so that we can compress duplicate error messages.
295 (defvar *last-message-count* 0)
296 (declaim (type index *last-message-count*))
298 ;;; If the last message was given more than once, then print out an
299 ;;; indication of how many times it was repeated. We reset the message
300 ;;; count when we are done.
301 (defun note-message-repeats (&optional (terpri t))
302 (cond ((= *last-message-count* 1)
303 (when terpri (terpri *error-output*)))
304 ((> *last-message-count* 1)
305 (format *error-output* "~&; [Last message occurs ~W times.]~2%"
306 *last-message-count*)))
307 (setq *last-message-count* 0))
309 ;;; Print out the message, with appropriate context if we can find it.
310 ;;; If the context is different from the context of the last message
311 ;;; we printed, then we print the context. If the original source is
312 ;;; different from the source we are working on, then we print the
313 ;;; current source in addition to the original source.
315 ;;; We suppress printing of messages identical to the previous, but
316 ;;; record the number of times that the message is repeated.
317 (defun print-compiler-message (format-string format-args)
319 (declare (type simple-string format-string))
320 (declare (type list format-args))
322 (let ((stream *error-output*)
323 (context (find-error-context format-args)))
326 (let ((file (compiler-error-context-file-name context))
327 (in (compiler-error-context-context context))
328 (form (compiler-error-context-original-source context))
329 (enclosing (compiler-error-context-enclosing-source context))
330 (source (compiler-error-context-source context))
331 (last *last-error-context*))
334 (equal file (compiler-error-context-file-name last)))
335 (when (pathnamep file)
336 (note-message-repeats)
338 (format stream "~2&; file: ~A~%" (namestring file))))
341 (equal in (compiler-error-context-context last)))
342 (note-message-repeats)
345 (pprint-logical-block (stream nil :per-line-prefix "; ")
346 (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
347 (format stream "~%"))
352 (compiler-error-context-original-source last)))
353 (note-message-repeats)
356 (pprint-logical-block (stream nil :per-line-prefix "; ")
357 (format stream " ~A" form))
358 (format stream "~&"))
362 (compiler-error-context-enclosing-source last)))
364 (note-message-repeats)
366 (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
369 (equal source (compiler-error-context-source last)))
370 (setq *last-format-string* nil)
372 (note-message-repeats)
375 (write-string "; ==>" stream)
377 (pprint-logical-block (stream nil :per-line-prefix "; ")
378 (write-string src stream)))))))
381 (note-message-repeats)
382 (setq *last-format-string* nil)
383 (format stream "~&")))
385 (setq *last-error-context* context)
387 (unless (and (equal format-string *last-format-string*)
388 (tree-equal format-args *last-format-args*))
389 (note-message-repeats nil)
390 (setq *last-format-string* format-string)
391 (setq *last-format-args* format-args)
392 (let ((*print-level* *compiler-error-print-level*)
393 (*print-length* *compiler-error-print-length*)
394 (*print-lines* *compiler-error-print-lines*))
396 (pprint-logical-block (stream nil :per-line-prefix "; ")
397 (format stream "~&~?" format-string format-args))
398 (format stream "~&"))))
400 (incf *last-message-count*)
403 (defun print-compiler-condition (condition)
404 (declare (type condition condition))
405 (let (;; These different classes of conditions have different
406 ;; effects on the return codes of COMPILE-FILE, so it's nice
407 ;; for users to be able to pick them out by lexical search
408 ;; through the output.
409 (what (etypecase condition
410 (style-warning 'style-warning)
413 (multiple-value-bind (format-string format-args)
414 (if (typep condition 'simple-condition)
415 (values (simple-condition-format-control condition)
416 (simple-condition-format-arguments condition))
418 (list (with-output-to-string (s)
419 (princ condition s)))))
420 (print-compiler-message (format nil
427 ;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
428 ;;; condition-signalling functions, but it just writes some output
429 ;;; instead of signalling. (In CMU CL, it did signal a condition, but
430 ;;; this didn't seem to work all that well; it was weird to have
431 ;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
432 ;;; that the compiler couldn't figure out how to compile something as
433 ;;; efficiently as it liked.)
434 (defun compiler-note (format-string &rest format-args)
435 (unless (if *compiler-error-context*
436 (policy *compiler-error-context* (= inhibit-warnings 3))
437 (policy *lexenv* (= inhibit-warnings 3)))
438 (incf *compiler-note-count*)
439 (print-compiler-message (format nil "note: ~A" format-string)
443 ;;; Issue a note when we might or might not be in the compiler.
444 (defun maybe-compiler-note (&rest rest)
445 (if (boundp '*lexenv*) ; if we're in the compiler
446 (apply #'compiler-note rest)
447 (let ((stream *error-output*))
448 (pprint-logical-block (stream nil :per-line-prefix ";")
450 (format stream " note: ~3I~_")
451 (pprint-logical-block (stream nil)
452 (apply #'format stream rest)))
453 (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
455 ;;; The politically correct way to print out progress messages and
456 ;;; such like. We clear the current error context so that we know that
457 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
458 ;;; message gets seen right away.
459 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
460 (defun compiler-mumble (format-string &rest format-args)
461 (note-message-repeats)
462 (setq *last-error-context* nil)
463 (apply #'format *error-output* format-string format-args)
464 (force-output *error-output*)
467 ;;; Return a string that somehow names the code in COMPONENT. We use
468 ;;; the source path for the bind node for an arbitrary entry point to
469 ;;; find the source context, then return that as a string.
470 (declaim (ftype (function (component) simple-string) find-component-name))
471 (defun find-component-name (component)
472 (let ((ep (first (block-succ (component-head component)))))
473 (aver ep) ; else no entry points??
474 (multiple-value-bind (form context)
475 (find-original-source
476 (node-source-path (continuation-next (block-start ep))))
477 (declare (ignore form))
478 (let ((*print-level* 2)
479 (*print-pretty* nil))
480 (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
482 ;;;; condition system interface
484 ;;; Keep track of how many times each kind of condition happens.
485 (defvar *compiler-error-count*)
486 (defvar *compiler-warning-count*)
487 (defvar *compiler-style-warning-count*)
488 (defvar *compiler-note-count*)
490 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
491 ;;; should return WARNINGS-P or FAILURE-P.
493 (defvar *warnings-p*)
495 ;;; condition handlers established by the compiler. We re-signal the
496 ;;; condition, then if it isn't handled, we increment our warning
497 ;;; counter and print the error message.
498 (defun compiler-error-handler (condition)
500 (incf *compiler-error-count*)
503 (print-compiler-condition condition)
504 (continue condition))
505 (defun compiler-warning-handler (condition)
507 (incf *compiler-warning-count*)
510 (print-compiler-condition condition)
511 (muffle-warning condition))
512 (defun compiler-style-warning-handler (condition)
514 (incf *compiler-style-warning-count*)
515 (setf *warnings-p* t)
516 (print-compiler-condition condition)
517 (muffle-warning condition))
519 ;;;; undefined warnings
521 (defvar *undefined-warning-limit* 3
523 "If non-null, then an upper limit on the number of unknown function or type
524 warnings that the compiler will print for any given name in a single
525 compilation. This prevents excessive amounts of output when the real
526 problem is a missing definition (as opposed to a typo in the use.)")
528 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
529 ;;; to NAME of the specified KIND. If we have exceeded the warning
530 ;;; limit, then just increment the count, otherwise note the current
533 ;;; Undefined types are noted by a condition handler in
534 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
535 ;;; the compiler, hence the BOUNDP check.
536 (defun note-undefined-reference (name kind)
538 ;; Check for boundness so we don't blow up if we're called
539 ;; when IR1 conversion isn't going on.
541 ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
542 ;; isn't a good idea; we should have INHIBIT-WARNINGS
543 ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
544 ;; sure what the BOUNDP '*LEXENV* test above is for; it's
545 ;; likely a good idea, but it probably deserves an
546 ;; explanatory comment.
547 (policy *lexenv* (= inhibit-warnings 3)))
548 (let* ((found (dolist (warning *undefined-warnings* nil)
549 (when (and (equal (undefined-warning-name warning) name)
550 (eq (undefined-warning-kind warning) kind))
553 (make-undefined-warning :name name :kind kind))))
554 (unless found (push res *undefined-warnings*))
555 (when (or (not *undefined-warning-limit*)
556 (< (undefined-warning-count res) *undefined-warning-limit*))
557 (push (find-error-context (list name))
558 (undefined-warning-warnings res)))
559 (incf (undefined-warning-count res))))