;;; 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)
+(defmacro define-source-context (name lambda-list &body body)
#!+sb-doc
- "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+ "DEFINE-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)))))
+ (lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
-(def-source-context defstruct (name-or-options &rest slots)
+(defmacro def-source-context (&rest rest)
+ (deprecation-warning 'def-source-context 'define-source-context)
+ `(define-source-context ,@rest))
+
+(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)))
-(def-source-context function (thing)
+(define-source-context function (thing)
(if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
`(lambda ,(second thing))
`(function ,thing)))
(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)))
;;; 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))))
+ (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)))
;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
;;; error context, or NIL if we can't figure anything out. ARGS is a
(cond ((= *last-message-count* 1)
(when terpri (terpri *error-output*)))
((> *last-message-count* 1)
- (format *error-output* "~&; [Last message occurs ~D times.]~2%"
+ (format *error-output* "~&; [Last message occurs ~W times.]~2%"
*last-message-count*)))
(setq *last-message-count* 0))
;;; 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
+;;; 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)