(when (and (boundp '*source-info*)
*source-info*)
(make-file-info-namestring *compile-file-pathname*
- (source-info-file-info *source-info*)))
+ (sb!c:get-toplevelish-file-info *source-info*)))
:type (or string null))
;; Toplevel form index
(toplevel-form-number
(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)
#!+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