1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / compiler / ir1report.lisp

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 72f0fa2..6a6bb12 100644 (file)
--- 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
@@ -182,10 +195,8 @@
   (let ((context *compiler-error-context*))
     (if (compiler-error-context-p context)
         (values context t)
-        (let* ((path (or (and (boundp '*current-path*) *current-path*)
-                         (if context
-                             (node-source-path context)
-                             nil)))
+        (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)
@@ -270,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))
@@ -298,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