1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / source-location.lisp

diff --git a/src/code/source-location.lisp b/src/code/source-location.lisp
index b96898b..be1abd2 100644 (file)
--- a/src/code/source-location.lisp
+++ b/src/code/source-location.lisp
@@ -16,10 +16,11 @@
   ;; Namestring of the source file that the definition was compiled from.
   ;; This is null if the definition was not compiled from a file.
   (namestring
-   (when (and (boundp '*source-info*)
-              *source-info*)
-     (make-file-info-namestring *compile-file-pathname*
-                                (source-info-file-info *source-info*)))
+   (or *source-namestring*
+       (when (and (boundp '*source-info*)
+                  *source-info*)
+         (make-file-info-namestring *compile-file-pathname*
+                                    (sb!c:get-toplevelish-file-info *source-info*))))
    :type (or string null))
   ;; Toplevel form index
   (toplevel-form-number
@@ -30,16 +31,20 @@
   (plist *source-plist*))
 
 (defun make-file-info-namestring (name file-info)
+  #+sb-xc-host (declare (ignore name))
   (let* ((untruename (file-info-untruename file-info))
          (dir (and untruename (pathname-directory untruename))))
     #+sb-xc-host
     (let ((src (position "src" dir :test #'string=
                          :from-end t)))
-      (if src
-          (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
-                  (subseq dir src) (pathname-name untruename))
-          ;; FIXME: just output/stuff-groveled-from-headers.lisp
-          (namestring untruename)))
+      (cond
+        ((and src (not (string= (car (last dir)) "output")))
+         (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+                 (subseq dir src) (pathname-name untruename)))
+        (t (aver (string-equal (car (last dir)) "output"))
+           (aver (string-equal (pathname-name untruename) "stuff-groveled-from-headers"))
+           (aver (string-equal (pathname-type untruename) "lisp"))
+           "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.LISP")))
     #-sb-xc-host
     (if (and dir (eq (first dir) :absolute))
         (namestring untruename)
@@ -49,10 +54,14 @@
 
 #!+sb-source-locations
 (define-compiler-macro source-location (&environment env)
-  #-sb-xc-host
-  (unless (policy env (and (> space 1)
-                           (> space debug)))
-    (make-definition-source-location)))
+  (declare (ignore env))
+  #-sb-xc-host (make-definition-source-location))
+
+;; We need a regular definition of SOURCE-LOCATION for calls processed
+;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET.
+#!+sb-source-locations
+(setf (symbol-function 'source-location)
+      (lambda () (make-definition-source-location)))
 
 (/show0 "/Processing source location thunks")
 #!+sb-source-locations