X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=6a6bb12f64f340cdd8754d4a0045fd1dc54f535d;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=25a7f57ee65578ba63300e615994dddc6b4e9a26;hpb=4da7c01c1cd31a730308f1e610cf636569109aeb;p=sbcl.git

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 25a7f57..6a6bb12 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -101,21 +101,34 @@
       `(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
@@ -268,9 +281,9 @@
 ;;;
 ;;; We suppress printing of messages identical to the previous, but
 ;;; record the number of times that the message is repeated.
-(defmacro 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)
+  (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))
@@ -296,7 +309,7 @@
                (note-message-repeats stream)
                (setq last nil)
                (pprint-logical-block (stream nil :per-line-prefix "; ")
-                 (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+                 (format stream "in:~{~<~%    ~4:;~{ ~:S~}~>~^ =>~}" in))
                (terpri stream))
 
              (unless (and last