-\f
-;;;; compiler error context determination
-
-(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
- macroexpansion) that we print in full. For additional enclosing forms, we
- print only the CAR.")
-(declaim (type unsigned-byte *enclosing-source-cutoff*))
-
-;;; We separate the determination of compiler error contexts from the actual
-;;; signalling of those errors by objectifying the error context. This allows
-;;; postponement of the determination of how (and if) to signal the error.
-;;;
-;;; We take care not to reference any of the IR1 so that pending potential
-;;; error messages won't prevent the IR1 from being GC'd. To this end, we
-;;; convert source forms to strings so that source forms that contain IR1
-;;; references (e.g. %DEFUN) don't hold onto the IR.
-(defstruct (compiler-error-context
- #-no-ansi-print-object
- (:print-object (lambda (x stream)
- (print-unreadable-object (x stream :type t))))
- (:copier nil))
- ;; A list of the stringified CARs of the enclosing non-original source forms
- ;; exceeding the *enclosing-source-cutoff*.
- (enclosing-source nil :type list)
- ;; A list of stringified enclosing non-original source forms.
- (source nil :type list)
- ;; The stringified form in the original source that expanded into Source.
- (original-source (required-argument) :type simple-string)
- ;; A list of prefixes of "interesting" forms that enclose original-source.
- (context nil :type list)
- ;; The FILE-INFO-NAME for the relevant FILE-INFO.
- (file-name (required-argument)
- :type (or pathname (member :lisp :stream)))
- ;; 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))
-
-;;; If true, this is the node which is used as context in compiler warning
-;;; messages.
-(declaim (type (or null compiler-error-context node) *compiler-error-context*))
-(defvar *compiler-error-context* nil)
-
-;;; a hashtable mapping macro names to source context parsers. Each parser
-;;; function returns the source-context list for that form.
-(defvar *source-context-methods* (make-hash-table))
-
-;;; documentation originally from cmu-user.tex:
-;;; This macro defines how to extract an abbreviated source context from
-;;; the \var{name}d form when it appears in the compiler input.
-;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
-;;; parse the arguments. The \var{body} should return a list of
-;;; subforms that can be printed on about one line. There are
-;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
-;;; no method is defined, then the first two subforms are returned.
-;;; Note that this facility implicitly determines the string name
-;;; associated with anonymous functions.
-;;; So even though SBCL itself only uses this macro within this file, it's a
-;;; reasonable thing to put in SB-EXT in case some dedicated user wants to do
-;;; some heavy tweaking to make SBCL give more informative output about his
-;;; code.
-(defmacro def-source-context (name lambda-list &body body)
- #!+sb-doc
- "DEF-SOURCE-CONTEXT Name Lambda-List Form*
- This macro defines how to extract an abbreviated source context from the
- Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
- style lambda-list used to parse the arguments. The Body should return a
- list of subforms suitable for a \"~{~S ~}\" format string."
- (let ((n-whole (gensym)))
- `(setf (gethash ',name *source-context-methods*)
- #'(lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(def-source-context defstruct (name-or-options &rest slots)
- (declare (ignore slots))
- `(defstruct ,(if (consp name-or-options)
- (car name-or-options)
- name-or-options)))
-
-(def-source-context function (thing)
- (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
- `(lambda ,(second thing))
- `(function ,thing)))
-
-;;; Return the first two elements of FORM if FORM is a list. Take the
-;;; CAR of the second form if appropriate.
-(defun source-form-context (form)
- (cond ((atom form) nil)
- ((>= (length form) 2)
- (funcall (gethash (first form) *source-context-methods*
- #'(lambda (x)
- (declare (ignore x))
- (list (first form) (second form))))
- (rest form)))
- (t
- form)))
-
-;;; Given a source path, return the original source form and a description
-;;; of the interesting aspects of the context in which it appeared. The
-;;; context is a list of lists, one sublist per context form. The sublist is a
-;;; list of some of the initial subforms of the context form.
-;;;
-;;; For now, we use the first two subforms of each interesting form. A form is
-;;; interesting if the first element is a symbol beginning with "DEF" and it is
-;;; not the source form. If there is no DEF-mumble, then we use the outermost
-;;; containing form. If the second subform is a list, then in some cases we
-;;; return the car of that form rather than the whole form (i.e. don't show
-;;; defstruct options, etc.)
-(defun find-original-source (path)
- (declare (list path))
- (let* ((rpath (reverse (source-path-original-source path)))
- (tlf (first rpath))
- (root (find-source-root tlf *source-info*)))
- (collect ((context))
- (let ((form root)
- (current (rest rpath)))
- (loop
- (when (atom form)
- (aver (null current))
- (return))
- (let ((head (first form)))
- (when (symbolp head)
- (let ((name (symbol-name head)))
- (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
- (context (source-form-context form))))))
- (when (null current) (return))
- (setq form (nth (pop current) form)))
-
- (cond ((context)
- (values form (context)))
- ((and path root)
- (let ((c (source-form-context root)))
- (values form (if c (list c) nil))))
- (t
- (values '(unable to locate source)
- '((some strange place)))))))))
-
-;;; Convert a source form to a string, suitably formatted for use in
-;;; compiler warnings.
-(defun stringify-form (form &optional (pretty t))
- (let ((*print-level* *compiler-error-print-level*)
- (*print-length* *compiler-error-print-length*)
- (*print-lines* *compiler-error-print-lines*)
- (*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
-;;; list of things that are going to be printed out in the error
-;;; message, and can thus be blown off when they appear in the source
-;;; context.
-(defun find-error-context (args)
- (let ((context *compiler-error-context*))
- (if (compiler-error-context-p context)
- context
- (let ((path (or *current-path*
- (if context
- (node-source-path context)
- nil))))
- (when (and *source-info* path)
- (multiple-value-bind (form src-context) (find-original-source path)
- (collect ((full nil cons)
- (short nil cons))
- (let ((forms (source-path-forms path))
- (n 0))
- (dolist (src (if (member (first forms) args)
- (rest forms)
- forms))
- (if (>= n *enclosing-source-cutoff*)
- (short (stringify-form (if (consp src)
- (car src)
- src)
- nil))
- (full (stringify-form src)))
- (incf n)))
-
- (let* ((tlf (source-path-tlf-number path))
- (file (find-file-info tlf *source-info*)))
- (make-compiler-error-context
- :enclosing-source (short)
- :source (full)
- :original-source (stringify-form form)
- :context src-context
- :file-name (file-info-name file)
- :file-position
- (multiple-value-bind (ignore pos)
- (find-source-root tlf *source-info*)
- (declare (ignore ignore))
- pos)
- :original-source-path
- (source-path-original-source path))))))))))
-\f
-;;;; printing error messages
-
-;;; We save the context information that we printed out most recently
-;;; so that we don't print it out redundantly.
-
-;;; The last COMPILER-ERROR-CONTEXT that we printed.
-(defvar *last-error-context* nil)
-(declaim (type (or compiler-error-context null) *last-error-context*))
-
-;;; The format string and args for the last error we printed.
-(defvar *last-format-string* nil)
-(defvar *last-format-args* nil)
-(declaim (type (or string null) *last-format-string*))
-(declaim (type list *last-format-args*))
-
-;;; The number of times that the last error message has been emitted,
-;;; so that we can compress duplicate error messages.
-(defvar *last-message-count* 0)
-(declaim (type index *last-message-count*))
-
-;;; If the last message was given more than once, then print out an
-;;; indication of how many times it was repeated. We reset the message count
-;;; when we are done.
-(defun note-message-repeats (&optional (terpri t))
- (cond ((= *last-message-count* 1)
- (when terpri (terpri *error-output*)))
- ((> *last-message-count* 1)
- (format *error-output* "~&; [Last message occurs ~D times.]~2%"
- *last-message-count*)))
- (setq *last-message-count* 0))
-
-;;; Print out the message, with appropriate context if we can find it.
-;;; If the context is different from the context of the last message
-;;; we printed, then we print the context. If the original source is
-;;; different from the source we are working on, then we print the
-;;; current source in addition to the original source.
-;;;
-;;; 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)
-
- (declare (type simple-string format-string))
- (declare (type list format-args))
-
- (let ((stream *error-output*)
- (context (find-error-context format-args)))
- (cond
- (context
- (let ((file (compiler-error-context-file-name context))
- (in (compiler-error-context-context context))
- (form (compiler-error-context-original-source context))
- (enclosing (compiler-error-context-enclosing-source context))
- (source (compiler-error-context-source context))
- (last *last-error-context*))
-
- (unless (and last
- (equal file (compiler-error-context-file-name last)))
- (when (pathnamep file)
- (note-message-repeats)
- (setq last nil)
- (format stream "~2&; file: ~A~%" (namestring file))))
-
- (unless (and last
- (equal in (compiler-error-context-context last)))
- (note-message-repeats)
- (setq last nil)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
- (format stream "~%"))
-
-
- (unless (and last
- (string= form
- (compiler-error-context-original-source last)))
- (note-message-repeats)
- (setq last nil)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (format stream " ~A" form))
- (format stream "~&"))
-
- (unless (and last
- (equal enclosing
- (compiler-error-context-enclosing-source last)))
- (when enclosing
- (note-message-repeats)
- (setq last nil)
- (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
- (unless (and last
- (equal source (compiler-error-context-source last)))
- (setq *last-format-string* nil)
- (when source
- (note-message-repeats)
- (dolist (src source)
- (format stream "~&")
- (write-string "; ==>" stream)
- (format stream "~&")
- (pprint-logical-block (stream nil :per-line-prefix "; ")
- (write-string src stream)))))))
- (t
- (format stream "~&")
- (note-message-repeats)
- (setq *last-format-string* nil)
- (format stream "~&")))
-
- (setq *last-error-context* context)
-
- (unless (and (equal format-string *last-format-string*)
- (tree-equal format-args *last-format-args*))
- (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 "~&"))))
-
- (incf *last-message-count*)
- (values))
-
-(defun print-compiler-condition (condition)
- (declare (type condition condition))
- (let (;; These different classes of conditions have different
- ;; effects on the return codes of COMPILE-FILE, so it's nice
- ;; for users to be able to pick them out by lexical search
- ;; through the output.
- (what (etypecase condition
- (style-warning 'style-warning)
- (warning 'warning)
- (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)))
- (values))
-
-;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
-;;; condition-signalling functions, but it just writes some output instead of
-;;; signalling. (In CMU CL, it did signal a condition, but this didn't seem to
-;;; work all that well; it was weird to have COMPILE-FILE return with
-;;; WARNINGS-P set when the only problem was that the compiler couldn't figure
-;;; out how to compile something as efficiently as it liked.)
-(defun compiler-note (format-string &rest format-args)
- (unless (if *compiler-error-context*
- (policy *compiler-error-context* (= inhibit-warnings 3))
- (policy *lexenv* (= inhibit-warnings 3)))
- (incf *compiler-note-count*)
- (print-compiler-message (format nil "note: ~A" format-string)
- format-args))
- (values))
-
-;;; Issue a note when we might or might not be in the compiler.
-(defun maybe-compiler-note (&rest rest)
- (if (boundp '*lexenv*) ; if we're in the compiler
- (apply #'compiler-note rest)
- (let ((stream *error-output*))
- (pprint-logical-block (stream nil :per-line-prefix ";")
-
- (format stream " note: ~3I~_")
- (pprint-logical-block (stream nil)
- (apply #'format stream rest)))
- (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
-
-;;; The politically correct way to print out progress messages and
-;;; such like. We clear the current error context so that we know that
-;;; it needs to be reprinted, and we also Force-Output so that the
-;;; message gets seen right away.
-(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
-(defun compiler-mumble (format-string &rest format-args)
- (note-message-repeats)
- (setq *last-error-context* nil)
- (apply #'format *error-output* format-string format-args)
- (force-output *error-output*)
- (values))