inhibit &REST -> &MORE conversion when DEBUG is 3
[sbcl.git] / src / compiler / ir1report.lisp
1 ;;;; machinery for reporting errors/warnings/notes/whatnot from
2 ;;;; the compiler
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
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.
12
13 (in-package "SB!C")
14 \f
15 ;;;; compiler error context determination
16
17 (declaim (special *current-path*))
18
19 (defvar *enclosing-source-cutoff* 1
20   #!+sb-doc
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
23   print only the CAR.")
24 (declaim (type unsigned-byte *enclosing-source-cutoff*))
25
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.
30 ;;;
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))))
39             (:copier nil))
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)))
57
58 ;;; If true, this is the node which is used as context in compiler warning
59 ;;; messages.
60 (declaim (type (or null compiler-error-context node) *compiler-error-context*))
61 (defvar *compiler-error-context* nil)
62
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))
66
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)
82   #!+sb-doc
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*)
90            (lambda (,whole)
91              (destructuring-bind ,lambda-list ,whole ,@body)))))
92
93 (define-source-context defstruct (name-or-options &rest slots)
94   (declare (ignore slots))
95   `(defstruct ,(if (consp name-or-options)
96                    (car name-or-options)
97                    name-or-options)))
98
99 (define-source-context function (thing)
100   (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
101       `(lambda ,(second thing))
102       `(function ,thing)))
103
104 (define-source-context named-lambda (name lambda-list &body forms)
105   (declare (ignore lambda-list forms))
106   (if (and (consp name) (eq 'eval (first name)))
107       (second name)
108       `(named-lambda ,name)))
109
110 ;;; Return the first two elements of FORM if FORM is a list. Take the
111 ;;; CAR of the second form if appropriate.
112 (defun source-form-context (form)
113   (cond ((atom form) nil)
114         ((>= (length form) 2)
115          (let* ((context-fun-default (lambda (x)
116                                        (declare (ignore x))
117                                        (list (first form) (second form))))
118                 (context-fun (gethash (first form)
119                                       *source-context-methods*
120                                       context-fun-default)))
121            (declare (type function context-fun))
122            (funcall context-fun (rest form))))
123         (t
124          form)))
125
126 ;;; Given a source path, return the original source form and a
127 ;;; description of the interesting aspects of the context in which it
128 ;;; appeared. The context is a list of lists, one sublist per context
129 ;;; form. The sublist is a list of some of the initial subforms of the
130 ;;; context form.
131 ;;;
132 ;;; For now, we use the first two subforms of each interesting form. A
133 ;;; form is interesting if the first element is a symbol beginning
134 ;;; with "DEF" and it is not the source form. If there is no
135 ;;; DEF-mumble, then we use the outermost containing form. If the
136 ;;; second subform is a list, then in some cases we return the CAR of
137 ;;; that form rather than the whole form (i.e. don't show DEFSTRUCT
138 ;;; options, etc.)
139 (defun find-original-source (path)
140   (declare (list path))
141   (let* ((rpath (reverse (source-path-original-source path)))
142          (tlf (first rpath))
143          (root (find-source-root tlf *source-info*)))
144     (collect ((context))
145       (let ((form root)
146             (current (rest rpath)))
147         (loop
148           (when (atom form)
149             (aver (null current))
150             (return))
151           (let ((head (first form)))
152             (when (symbolp head)
153               (let ((name (symbol-name head)))
154                 (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
155                   (context (source-form-context form))))))
156           (when (null current) (return))
157           (setq form (nth (pop current) form)))
158
159         (cond ((context)
160                (values form (context)))
161               ((and path root)
162                (let ((c (source-form-context root)))
163                  (values form (if c (list c) nil))))
164               (t
165                (values '(unable to locate source)
166                        '((some strange place)))))))))
167
168 ;;; Convert a source form to a string, suitably formatted for use in
169 ;;; compiler warnings.
170 (defun stringify-form (form &optional (pretty t))
171   (with-standard-io-syntax
172     (with-compiler-io-syntax
173         (let ((*print-pretty* pretty))
174           (if pretty
175               (format nil "~<~@;  ~S~:>" (list form))
176               (prin1-to-string form))))))
177
178 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
179 ;;; error context, or NIL if we can't figure anything out. ARGS is a
180 ;;; list of things that are going to be printed out in the error
181 ;;; message, and can thus be blown off when they appear in the source
182 ;;; context.
183 ;;;
184 ;;; If OLD-CONTEXTS is passed in, and includes a context with the
185 ;;; same original source path as the new context would have, the old
186 ;;; context is reused instead, and a secondary value of T is returned.
187 (defun find-error-context (args &optional old-contexts)
188   (let ((context *compiler-error-context*))
189     (if (compiler-error-context-p context)
190         (values context t)
191         (let* ((path (or (and (node-p context) (node-source-path context))
192                          (and (boundp '*current-path*) *current-path*)))
193                (old
194                 (find (when path (source-path-original-source path))
195                       (remove-if #'null old-contexts)
196                       :test #'equal
197                       :key #'compiler-error-context-original-source-path)))
198           (if old
199               (values old t)
200               (when (and *source-info* path)
201                 (multiple-value-bind (form src-context) (find-original-source path)
202                   (collect ((full nil cons)
203                             (short nil cons))
204                     (let ((forms (source-path-forms path))
205                           (n 0))
206                       (dolist (src (if (member (first forms) args)
207                                        (rest forms)
208                                        forms))
209                         (if (>= n *enclosing-source-cutoff*)
210                             (short (stringify-form (if (consp src)
211                                                        (car src)
212                                                        src)
213                                                    nil))
214                             (full (stringify-form src)))
215                         (incf n)))
216
217                     (let* ((tlf (source-path-tlf-number path))
218                            (file-info (source-info-file-info *source-info*)))
219                       (values
220                        (make-compiler-error-context
221                         :enclosing-source (short)
222                         :source (full)
223                         :original-source (stringify-form form)
224                         :context src-context
225                         :file-name (file-info-name file-info)
226                         :file-position
227                         (multiple-value-bind (ignore pos)
228                             (find-source-root tlf *source-info*)
229                           (declare (ignore ignore))
230                           pos)
231                         :original-source-path (source-path-original-source path)
232                         :lexenv (if context
233                                     (node-lexenv context)
234                                     (if (boundp '*lexenv*) *lexenv* nil)))
235                        nil))))))))))
236 \f
237 ;;;; printing error messages
238
239 ;;; We save the context information that we printed out most recently
240 ;;; so that we don't print it out redundantly.
241
242 ;;; The last COMPILER-ERROR-CONTEXT that we printed.
243 (defvar *last-error-context* nil)
244 (declaim (type (or compiler-error-context null) *last-error-context*))
245
246 ;;; The format string and args for the last error we printed.
247 (defvar *last-format-string* nil)
248 (defvar *last-format-args* nil)
249 (declaim (type (or string null) *last-format-string*))
250 (declaim (type list *last-format-args*))
251
252 ;;; The number of times that the last error message has been emitted,
253 ;;; so that we can compress duplicate error messages.
254 (defvar *last-message-count* 0)
255 (declaim (type index *last-message-count*))
256
257 ;;; If the last message was given more than once, then print out an
258 ;;; indication of how many times it was repeated. We reset the message
259 ;;; count when we are done.
260 (defun note-message-repeats (stream &optional (terpri t))
261   (cond ((= *last-message-count* 1)
262          (when terpri
263            (terpri stream)))
264         ((> *last-message-count* 1)
265          (format stream "~&; [Last message occurs ~W times.]~2%"
266                  *last-message-count*)))
267   (setq *last-message-count* 0))
268
269 ;;; Print out the message, with appropriate context if we can find it.
270 ;;; If the context is different from the context of the last message
271 ;;; we printed, then we print the context. If the original source is
272 ;;; different from the source we are working on, then we print the
273 ;;; current source in addition to the original source.
274 ;;;
275 ;;; We suppress printing of messages identical to the previous, but
276 ;;; record the number of times that the message is repeated.
277 (defmacro print-compiler-message (stream format-string format-args)
278   `(with-compiler-io-syntax
279      (%print-compiler-message ,stream ,format-string ,format-args)))
280
281 (defun %print-compiler-message (stream format-string format-args)
282   (declare (type simple-string format-string))
283   (declare (type list format-args))
284   (let ((context (find-error-context format-args)))
285     (cond (context
286            (let ((file (compiler-error-context-file-name context))
287                  (in (compiler-error-context-context context))
288                  (form (compiler-error-context-original-source context))
289                  (enclosing (compiler-error-context-enclosing-source context))
290                  (source (compiler-error-context-source context))
291                  (last *last-error-context*))
292
293              (unless  (and last
294                            (equal file (compiler-error-context-file-name last)))
295                (when (pathnamep file)
296                  (note-message-repeats stream)
297                  (setq last nil)
298                  (format stream "~2&; file: ~A~%" (namestring file))))
299
300              (unless (and last
301                           (equal in (compiler-error-context-context last)))
302                (note-message-repeats stream)
303                (setq last nil)
304                (pprint-logical-block (stream nil :per-line-prefix "; ")
305                  (format stream "in:~{~<~%    ~4:;~{ ~:S~}~>~^ =>~}" in))
306                (terpri stream))
307
308              (unless (and last
309                           (string= form
310                                    (compiler-error-context-original-source last)))
311                (note-message-repeats stream)
312                (setq last nil)
313                (pprint-logical-block (stream nil :per-line-prefix ";   ")
314                  (princ form stream))
315                (fresh-line stream))
316
317              (unless (and last
318                           (equal enclosing
319                                  (compiler-error-context-enclosing-source last)))
320                (when enclosing
321                  (note-message-repeats stream)
322                  (setq last nil)
323                  (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
324
325              (unless (and last
326                           (equal source (compiler-error-context-source last)))
327                (setq *last-format-string* nil)
328                (when source
329                  (note-message-repeats stream)
330                  (dolist (src source)
331                    (fresh-line stream)
332                    (write-string "; ==>" stream)
333                    (terpri stream)
334                    (pprint-logical-block (stream nil :per-line-prefix "; ")
335                      (write-string src stream)))))))
336           (t
337            (fresh-line stream)
338            (note-message-repeats stream)
339            (setq *last-format-string* nil)))
340
341     (setq *last-error-context* context))
342
343   ;; FIXME: this testing for effective equality of compiler messages
344   ;; is ugly, and really ought to be done at a higher level.
345   (unless (and (equal format-string *last-format-string*)
346                (tree-equal format-args *last-format-args*))
347     (note-message-repeats stream nil)
348     (setq *last-format-string* format-string)
349     (setq *last-format-args* format-args)
350     (fresh-line stream)
351     (pprint-logical-block (stream nil :per-line-prefix "; ")
352       (format stream "~&~?" format-string format-args))
353     (fresh-line stream))
354
355   (incf *last-message-count*)
356   (values))
357
358 (defun print-compiler-condition (condition)
359   (declare (type condition condition))
360   (let (;; These different classes of conditions have different
361         ;; effects on the return codes of COMPILE-FILE, so it's nice
362         ;; for users to be able to pick them out by lexical search
363         ;; through the output.
364         (what (etypecase condition
365                 (style-warning 'style-warning)
366                 (warning 'warning)
367                 ((or error compiler-error) 'error))))
368     (print-compiler-message
369      *error-output*
370      (format nil "caught ~S:~%~~@<  ~~@;~~A~~:>" what)
371      (list (princ-to-string condition)))))
372
373 ;;; The act of signalling one of these beasts must not cause WARNINGSP
374 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
375 ;;; inherit from WARNING or STYLE-WARNING.
376 ;;;
377 ;;; FIXME: the handling of compiler-notes could be unified with
378 ;;; warnings and style-warnings (see the various handler functions
379 ;;; below).
380 (define-condition compiler-note (condition) ()
381   (:documentation
382    "Root of the hierarchy of conditions representing information discovered
383 by the compiler that the user might wish to know, but which does not merit
384 a STYLE-WARNING (or any more serious condition)."))
385 (define-condition simple-compiler-note (simple-condition compiler-note) ())
386 (define-condition code-deletion-note (simple-compiler-note) ()
387   (:documentation
388    "A condition type signalled when the compiler deletes code that the user
389 has written, having proved that it is unreachable."))
390
391 (macrolet ((with-condition ((condition datum args) &body body)
392              (with-unique-names (block)
393                `(block ,block
394                   (let ((,condition
395                          (coerce-to-condition ,datum ,args
396                                               'simple-compiler-note
397                                               'with-condition)))
398                     (restart-case
399                         (signal ,condition)
400                       (muffle-warning ()
401                         (return-from ,block (values))))
402                     ,@body
403                     (values))))))
404
405   (defun compiler-notify (datum &rest args)
406     (unless (if *compiler-error-context*
407               (policy *compiler-error-context* (= inhibit-warnings 3))
408               (policy *lexenv* (= inhibit-warnings 3)))
409       (with-condition (condition datum args)
410         (incf *compiler-note-count*)
411         (print-compiler-message
412          *error-output*
413          (format nil "note: ~~A")
414          (list (princ-to-string condition)))))
415     (values))
416
417   ;; Issue a note when we might or might not be in the compiler.
418   (defun maybe-compiler-notify (datum &rest args)
419     (if (boundp '*lexenv*) ; if we're in the compiler
420         (apply #'compiler-notify datum args)
421         (with-condition (condition datum args)
422           (let ((stream *error-output*))
423             (pprint-logical-block (stream nil :per-line-prefix ";")
424               (format stream " note: ~3I~_")
425               (pprint-logical-block (stream nil)
426                 (format stream "~A" condition)))
427             ;; (outside logical block, no per-line-prefix)
428             (fresh-line stream))))))
429
430 ;;; The politically correct way to print out progress messages and
431 ;;; such like. We clear the current error context so that we know that
432 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
433 ;;; message gets seen right away.
434 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
435 (defun compiler-mumble (control &rest args)
436   (let ((stream *standard-output*))
437     (note-message-repeats stream)
438     (setq *last-error-context* nil)
439     (apply #'format stream control args)
440     (force-output stream)
441     (values)))
442
443 ;;; Return a string that somehow names the code in COMPONENT. We use
444 ;;; the source path for the bind node for an arbitrary entry point to
445 ;;; find the source context, then return that as a string.
446 (declaim (ftype (function (component) simple-string) find-component-name))
447 (defun find-component-name (component)
448   (let ((ep (first (block-succ (component-head component)))))
449     (aver ep) ; else no entry points??
450     (multiple-value-bind (form context)
451         (find-original-source (node-source-path (block-start-node ep)))
452       (declare (ignore form))
453       (let ((*print-level* 2)
454             (*print-pretty* nil))
455         (format nil "~{~{~S~^ ~}~^ => ~}"
456                 #+sb-xc-host (list (list (caar context)))
457                 #-sb-xc-host context)))))
458 \f
459 ;;;; condition system interface
460
461 ;;; Keep track of how many times each kind of condition happens.
462 (defvar *compiler-error-count*)
463 (defvar *compiler-warning-count*)
464 (defvar *compiler-style-warning-count*)
465 (defvar *compiler-note-count*)
466
467 ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
468 ;;; should return WARNINGS-P or FAILURE-P.
469 (defvar *failure-p*)
470 (defvar *warnings-p*)
471
472 ;;; condition handlers established by the compiler. We re-signal the
473 ;;; condition, then if it isn't handled, we increment our warning
474 ;;; counter and print the error message.
475 (defun compiler-error-handler (condition)
476   (signal condition)
477   (incf *compiler-error-count*)
478   (setf *warnings-p* t
479         *failure-p* t)
480   (print-compiler-condition condition)
481   (continue condition))
482 (defun compiler-warning-handler (condition)
483   (signal condition)
484   (incf *compiler-warning-count*)
485   (setf *warnings-p* t
486         *failure-p* t)
487   (print-compiler-condition condition)
488   (muffle-warning condition))
489 (defun compiler-style-warning-handler (condition)
490   (signal condition)
491   (incf *compiler-style-warning-count*)
492   (setf *warnings-p* t)
493   (print-compiler-condition condition)
494   (muffle-warning condition))
495 \f
496 ;;;; undefined warnings
497
498 (defvar *undefined-warning-limit* 3
499   #!+sb-doc
500   "If non-null, then an upper limit on the number of unknown function or type
501   warnings that the compiler will print for any given name in a single
502   compilation. This prevents excessive amounts of output when the real
503   problem is a missing definition (as opposed to a typo in the use.)")
504
505 ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
506 ;;; to NAME of the specified KIND. If we have exceeded the warning
507 ;;; limit, then just increment the count, otherwise note the current
508 ;;; error context.
509 ;;;
510 ;;; Undefined types are noted by a condition handler in
511 ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
512 ;;; the compiler, hence the BOUNDP check.
513 (defun note-undefined-reference (name kind)
514   (unless (and
515            ;; Check for boundness so we don't blow up if we're called
516            ;; when IR1 conversion isn't going on.
517            (boundp '*lexenv*)
518            (or
519             ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
520             ;; isn't a good idea; we should have INHIBIT-WARNINGS
521             ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
522             ;; sure what the BOUNDP '*LEXENV* test above is for; it's
523             ;; likely a good idea, but it probably deserves an
524             ;; explanatory comment.
525             (policy *lexenv* (= inhibit-warnings 3))
526             ;; KLUDGE: weird decoupling between here and where we're
527             ;; going to signal the condition.  I don't think we can
528             ;; rewrite this using SIGNAL and RESTART-CASE (to take
529             ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
530             ;; handler, because if that doesn't handle it the ordinary
531             ;; compiler handlers will trigger.
532             (typep
533              (ecase kind
534                (:variable (make-condition 'warning))
535                ((:function :type) (make-condition 'style-warning)))
536              (car
537               (rassoc 'muffle-warning
538                       (lexenv-handled-conditions *lexenv*))))))
539     (let* ((found (dolist (warning *undefined-warnings* nil)
540                     (when (and (equal (undefined-warning-name warning) name)
541                                (eq (undefined-warning-kind warning) kind))
542                       (return warning))))
543            (res (or found
544                     (make-undefined-warning :name name :kind kind))))
545       (unless found (push res *undefined-warnings*))
546       (multiple-value-bind (context old)
547           (find-error-context (list name) (undefined-warning-warnings res))
548         (unless old
549           (when (or (not *undefined-warning-limit*)
550                     (< (undefined-warning-count res) *undefined-warning-limit*))
551             (push context (undefined-warning-warnings res)))
552           (incf (undefined-warning-count res))))))
553   (values))