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)))))
+ (lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
(defmacro def-source-context (&rest rest)
(deprecation-warning 'def-source-context 'define-source-context)
(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)))
+ (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)))
(format nil "~<~@; ~S~:>" (list form))
(prin1-to-string form)))))
-;;; shorthand for creating debug names from source names or other
-;;; stems, e.g.
-;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
-;;; (DEBUG-NAMIFY "top level form ~S" FORM)
+;;; shorthand for a repeated idiom in creating debug names
;;;
-;;; FIXME: This function seems to have a lot in common with
-;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
-;;; functions.
-(defun debug-namify (format-string &rest format-arguments)
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*package* *cl-package*)
- (*print-length* 3)
- (*print-level* 2))
- (apply #'format nil format-string format-arguments))))
+;;; 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)))
;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
;;; error context, or NIL if we can't figure anything out. ARGS is a
(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 nil)
(what (etypecase condition
(style-warning 'style-warning)
(warning 'warning)
- (error 'error))))
+ ((or error compiler-error) 'error))))
(multiple-value-bind (format-string format-args)
(if (typep condition 'simple-condition)
(values (simple-condition-format-control 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)))
+ (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)
+;;; 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
+;;; inherit from WARNING or STYLE-WARNING.
+;;;
+;;; 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) ()
+ (: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) ())
+(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."))
+
+(defun compiler-notify (datum &rest 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))
+ (let ((condition
+ (coerce-to-condition datum args
+ 'simple-compiler-note 'compiler-notify)))
+ (restart-case
+ (signal condition)
+ (muffle-warning ()
+ (return-from compiler-notify (values))))
+ (incf *compiler-note-count*)
+ (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 "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)
+(defun maybe-compiler-notify (&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)
+ (apply #'compiler-notify rest)
+ (progn
+ (let ((condition
+ (coerce-to-condition (car rest) (cdr rest)
+ 'simple-compiler-note
+ 'maybe-compiler-notify)))
+ (restart-case
+ (signal condition)
+ (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)
+ (format stream "~A" condition)))
+ ;; (outside logical block, no per-line-prefix)
+ (fresh-line stream)))
+ (values))))
;;; The politically correct way to print out progress messages and
;;; such like. We clear the current error context so that we know that
(aver ep) ; else no entry points??
(multiple-value-bind (form context)
(find-original-source
- (node-source-path (continuation-next (block-start ep))))
+ (node-source-path (block-start-node ep)))
(declare (ignore form))
(let ((*print-level* 2)
(*print-pretty* nil))