X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=c8dced28c4e11de16e0c6ff41c659bbcfd55b459;hb=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=6143aeeaf34dcaea0326275fdefd7105473c8bab;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 6143aee..c8dced2 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -97,25 +97,29 @@
 ;;; 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)))
@@ -125,11 +129,14 @@
 (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)))
 
@@ -188,21 +195,30 @@
          (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