(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
;;; 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))
+ #-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)
;; 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))
+ (original-source-path nil :type list)
+ ;; the lexenv active at the time
+ (lexenv nil :type (or null lexenv)))
;;; If true, this is the node which is used as context in compiler warning
;;; messages.
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)))
+ (with-unique-names (whole)
`(setf (gethash ',name *source-context-methods*)
- (lambda (,n-whole)
- (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-
-(defmacro def-source-context (&rest rest)
- (deprecation-warning 'def-source-context 'define-source-context)
- `(define-source-context ,@rest))
+ (lambda (,whole)
+ (destructuring-bind ,lambda-list ,whole ,@body)))))
(define-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
`(defstruct ,(if (consp name-or-options)
- (car name-or-options)
- name-or-options)))
+ (car name-or-options)
+ name-or-options)))
(define-source-context function (thing)
(if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
`(lambda ,(second thing))
`(function ,thing)))
+(define-source-context named-lambda (name lambda-list &body forms)
+ (declare (ignore lambda-list forms))
+ (if (and (consp name) (eq 'eval (first name)))
+ (second name)
+ `(named-lambda ,name)))
+
+(defvar *source-form-context-alist* nil)
+
;;; 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)
- (let* ((context-fun-default (lambda (x)
- (declare (ignore x))
- (list (first form) (second form))))
- (context-fun (gethash (first form)
- *source-context-methods*
- context-fun-default)))
- (declare (type function context-fun))
- (funcall context-fun (rest form))))
- (t
- form)))
+ (flet ((get-it (form)
+ (cond ((atom form) nil)
+ ((>= (length form) 2)
+ (let* ((context-fun-default
+ (lambda (x)
+ (declare (ignore x))
+ (list (first form) (second form))))
+ (context-fun
+ (gethash (first form)
+ *source-context-methods*
+ context-fun-default)))
+ (declare (type function context-fun))
+ (funcall context-fun (rest form))))
+ (t
+ form))))
+ (get-it (or (cdr (assoc form *source-form-context-alist* :test #'eq))
+ form))))
;;; Given a source path, return the original source form and a
;;; description of the interesting aspects of the context in which it
(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*)))
+ (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)))))))))
+ (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))
(with-standard-io-syntax
- (let ((*print-readably* nil)
- (*print-pretty* pretty)
- (*print-level* *compiler-error-print-level*)
- (*print-length* *compiler-error-print-length*)
- (*print-lines* *compiler-error-print-lines*))
- (if pretty
- (format nil "~<~@; ~S~:>" (list form))
- (prin1-to-string form)))))
-
-;;; shorthand for a repeated idiom in creating debug names
-;;;
-;;; the problem, part I: We want to create debug names that look like
-;;; "&MORE processor for <something>" where <something> might be
-;;; either a source-name value (typically a symbol) or a non-symbol
-;;; debug-name value (typically a string). It's awkward to handle this
-;;; with FORMAT because we'd like to splice a source-name value using
-;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
-;;; (to avoid irrelevant quotes at string splice boundaries).
-;;;
-;;; the problem, part II: The <something> is represented as a pair
-;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
-;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily
-;;; we don't use a value if it's NIL, instead defaulting it. But we
-;;; can't safely/comfortably use NIL for that in this context, since
-;;; the app programmer can use NIL as a name, so we use the private
-;;; symbol .ANONYMOUS. instead.)
-;;;
-;;; the solution: Use this function to convert whatever it is to a
-;;; string, which FORMAT can then splice using "~A".
-(defun as-debug-name (source-name debug-name)
- (if (eql source-name '.anonymous.)
- debug-name
- (debug-namify "~S" source-name)))
+ (with-compiler-io-syntax
+ (let ((*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)
+;;;
+;;; If OLD-CONTEXTS is passed in, and includes a context with the
+;;; same original source path as the new context would have, the old
+;;; context is reused instead, and a secondary value of T is returned.
+(defun find-error-context (args &optional old-contexts)
(let ((context *compiler-error-context*))
(if (compiler-error-context-p context)
- context
- (let ((path (or (and (boundp '*current-path*) *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-info (source-info-file-info *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-info)
- :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))))))))))
+ (values context t)
+ (let* ((path (or (and (node-p context) (node-source-path context))
+ (and (boundp '*current-path*) *current-path*)))
+ (old
+ (find (when path (source-path-original-source path))
+ (remove-if #'null old-contexts)
+ :test #'equal
+ :key #'compiler-error-context-original-source-path)))
+ (if old
+ (values old t)
+ (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-info (source-info-file-info *source-info*)))
+ (values
+ (make-compiler-error-context
+ :enclosing-source (short)
+ :source (full)
+ :original-source (stringify-form form)
+ :context src-context
+ :file-name (file-info-name file-info)
+ :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)
+ :lexenv (if context
+ (node-lexenv context)
+ (if (boundp '*lexenv*) *lexenv* nil)))
+ nil))))))))))
\f
;;;; printing error messages
;;; 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))
+(defun note-message-repeats (stream &optional (terpri t))
(cond ((= *last-message-count* 1)
- (when terpri (terpri *error-output*)))
- ((> *last-message-count* 1)
- (format *error-output* "~&; [Last message occurs ~W times.]~2%"
- *last-message-count*)))
+ (when terpri
+ (terpri stream)))
+ ((> *last-message-count* 1)
+ (format stream "~&; [Last message occurs ~W times.]~2%"
+ *last-message-count*)))
(setq *last-message-count* 0))
;;; Print out the message, with appropriate context if we can find it.
;;;
;;; 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)
+(defun print-compiler-message (stream format-string format-args)
+ (with-compiler-io-syntax
+ (%print-compiler-message stream format-string format-args)))
+(defun %print-compiler-message (stream 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 "~&"))))
+ (let ((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 stream)
+ (setq last nil)
+ (format stream "~2&; file: ~A~%" (namestring file))))
+
+ (unless (and last
+ (equal in (compiler-error-context-context last)))
+ (note-message-repeats stream)
+ (setq last nil)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "in:~{~<~% ~4:;~{ ~:S~}~>~^ =>~}" in))
+ (terpri stream))
+
+ (unless (and last
+ (string= form
+ (compiler-error-context-original-source last)))
+ (note-message-repeats stream)
+ (setq last nil)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (princ form stream))
+ (fresh-line stream))
+
+ (unless (and last
+ (equal enclosing
+ (compiler-error-context-enclosing-source last)))
+ (when enclosing
+ (note-message-repeats stream)
+ (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 stream)
+ (dolist (src source)
+ (fresh-line stream)
+ (write-string "; ==>" stream)
+ (terpri stream)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (write-string src stream)))))))
+ (t
+ (fresh-line stream)
+ (note-message-repeats stream)
+ (setq *last-format-string* nil)))
+
+ (setq *last-error-context* context))
+
+ ;; FIXME: this testing for effective equality of compiler messages
+ ;; is ugly, and really ought to be done at a higher level.
+ (unless (and (equal format-string *last-format-string*)
+ (tree-equal format-args *last-format-args*))
+ (note-message-repeats stream nil)
+ (setq *last-format-string* format-string)
+ (setq *last-format-args* format-args)
+ (fresh-line stream)
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "~&~?" format-string format-args))
+ (fresh-line 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)
- ((or error compiler-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))
+ ;; 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)
+ ((or error compiler-error) 'error))))
+ (print-compiler-message
+ *error-output*
+ (format nil "caught ~S:~%~~@< ~~@;~~A~~:>" what)
+ (list (princ-to-string condition)))))
;;; The act of signalling one of these beasts must not cause WARNINGSP
;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
;;; FIXME: the handling of compiler-notes could be unified with
;;; warnings and style-warnings (see the various handler functions
;;; below).
-(define-condition compiler-note (condition) ())
+(define-condition compiler-note (condition) ()
+ (:documentation
+ "Root of the hierarchy of conditions representing information discovered
+by the compiler that the user might wish to know, but which does not merit
+a STYLE-WARNING (or any more serious condition)."))
(define-condition simple-compiler-note (simple-condition compiler-note) ())
-
-(defun compiler-notify (format-string &rest format-args)
- ;; FORMAT-STRING and FORMAT-ARGS might well end up turning into
- ;; DATUM and REST, and COERCE-TO-CONDITION will be used.
- (unless (if *compiler-error-context*
- (policy *compiler-error-context* (= inhibit-warnings 3))
- (policy *lexenv* (= inhibit-warnings 3)))
- (restart-case
- (signal (make-condition 'simple-compiler-note
- :format-control format-string
- :format-arguments format-args))
- (muffle-warning ()
- (return-from compiler-notify (values))))
- (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-notify (&rest rest)
- (if (boundp '*lexenv*) ; if we're in the compiler
- (apply #'compiler-notify rest)
- (progn
- (restart-case
- (signal (make-condition 'simple-compiler-note
- :format-control (car rest)
- :format-arguments (cdr rest)))
- (muffle-warning ()
- (return-from maybe-compiler-notify (values))))
- (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)))
- ;; (outside logical block, no per-line-prefix)
- (fresh-line stream))
- (values))))
+(define-condition code-deletion-note (simple-compiler-note) ()
+ (:documentation
+ "A condition type signalled when the compiler deletes code that the user
+has written, having proved that it is unreachable."))
+
+(macrolet ((with-condition ((condition datum args) &body body)
+ (with-unique-names (block)
+ `(block ,block
+ (let ((,condition
+ (coerce-to-condition ,datum ,args
+ 'simple-compiler-note
+ 'with-condition)))
+ (restart-case
+ (signal ,condition)
+ (muffle-warning ()
+ (return-from ,block (values))))
+ ,@body
+ (values))))))
+
+ (defun compiler-notify (datum &rest args)
+ (unless (if *compiler-error-context*
+ (policy *compiler-error-context* (= inhibit-warnings 3))
+ (policy *lexenv* (= inhibit-warnings 3)))
+ (with-condition (condition datum args)
+ (incf *compiler-note-count*)
+ (print-compiler-message
+ *error-output*
+ (format nil "note: ~~A")
+ (list (princ-to-string condition)))))
+ (values))
+
+ ;; Issue a note when we might or might not be in the compiler.
+ (defun maybe-compiler-notify (datum &rest args)
+ (if (boundp '*lexenv*) ; if we're in the compiler
+ (apply #'compiler-notify datum args)
+ (with-condition (condition datum args)
+ (let ((stream *error-output*))
+ (pprint-logical-block (stream nil :per-line-prefix ";")
+ (format stream " note: ~3I~_")
+ (pprint-logical-block (stream nil)
+ (format stream "~A" condition)))
+ ;; (outside logical block, no per-line-prefix)
+ (fresh-line stream))))))
;;; 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))
+(defun compiler-mumble (control &rest args)
+ (let ((stream *standard-output*))
+ (note-message-repeats stream)
+ (setq *last-error-context* nil)
+ (apply #'format stream control args)
+ (force-output stream)
+ (values)))
;;; Return a string that somehow names the code in COMPONENT. We use
;;; the source path for the bind node for an arbitrary entry point to
(let ((ep (first (block-succ (component-head component)))))
(aver ep) ; else no entry points??
(multiple-value-bind (form context)
- (find-original-source
- (node-source-path (continuation-next (block-start ep))))
+ (find-original-source (node-source-path (block-start-node ep)))
(declare (ignore form))
(let ((*print-level* 2)
- (*print-pretty* nil))
- (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+ (*print-pretty* nil))
+ (format nil "~{~{~S~^ ~}~^ => ~}"
+ #+sb-xc-host (list (list (caar context)))
+ #-sb-xc-host context)))))
\f
;;;; condition system interface
(signal condition)
(incf *compiler-error-count*)
(setf *warnings-p* t
- *failure-p* t)
+ *failure-p* t)
(print-compiler-condition condition)
(continue condition))
(defun compiler-warning-handler (condition)
(signal condition)
(incf *compiler-warning-count*)
(setf *warnings-p* t
- *failure-p* t)
+ *failure-p* t)
(print-compiler-condition condition)
(muffle-warning condition))
(defun compiler-style-warning-handler (condition)
;;; the compiler, hence the BOUNDP check.
(defun note-undefined-reference (name kind)
(unless (and
- ;; Check for boundness so we don't blow up if we're called
- ;; when IR1 conversion isn't going on.
- (boundp '*lexenv*)
- ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
- ;; isn't a good idea; we should have INHIBIT-WARNINGS
- ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
- ;; sure what the BOUNDP '*LEXENV* test above is for; it's
- ;; likely a good idea, but it probably deserves an
- ;; explanatory comment.
- (policy *lexenv* (= inhibit-warnings 3)))
+ ;; Check for boundness so we don't blow up if we're called
+ ;; when IR1 conversion isn't going on.
+ (boundp '*lexenv*)
+ (or
+ ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+ ;; isn't a good idea; we should have INHIBIT-WARNINGS
+ ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+ ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+ ;; likely a good idea, but it probably deserves an
+ ;; explanatory comment.
+ (policy *lexenv* (= inhibit-warnings 3))
+ ;; KLUDGE: weird decoupling between here and where we're
+ ;; going to signal the condition. I don't think we can
+ ;; rewrite this using SIGNAL and RESTART-CASE (to take
+ ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
+ ;; handler, because if that doesn't handle it the ordinary
+ ;; compiler handlers will trigger.
+ (typep
+ (ecase kind
+ (:variable (make-condition 'warning))
+ ((:function :type) (make-condition 'style-warning)))
+ (car
+ (rassoc 'muffle-warning
+ (lexenv-handled-conditions *lexenv*))))))
(let* ((found (dolist (warning *undefined-warnings* nil)
- (when (and (equal (undefined-warning-name warning) name)
- (eq (undefined-warning-kind warning) kind))
- (return warning))))
- (res (or found
- (make-undefined-warning :name name :kind kind))))
+ (when (and (equal (undefined-warning-name warning) name)
+ (eq (undefined-warning-kind warning) kind))
+ (return warning))))
+ (res (or found
+ (make-undefined-warning :name name :kind kind))))
(unless found (push res *undefined-warnings*))
- (when (or (not *undefined-warning-limit*)
- (< (undefined-warning-count res) *undefined-warning-limit*))
- (push (find-error-context (list name))
- (undefined-warning-warnings res)))
- (incf (undefined-warning-count res))))
+ (multiple-value-bind (context old)
+ (find-error-context (list name) (undefined-warning-warnings res))
+ (unless old
+ (when (or (not *undefined-warning-limit*)
+ (< (undefined-warning-count res) *undefined-warning-limit*))
+ (push context (undefined-warning-warnings res)))
+ (incf (undefined-warning-count res))))))
(values))
projects / sbcl.git / blobdiff