1 ;;;; Source location tracking.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (def!struct
(definition-source-location
15 (:make-load-form-fun sb
!kernel
:just-dump-it-normally
))
16 ;; Namestring of the source file that the definition was compiled from.
17 ;; This is null if the definition was not compiled from a file.
19 (when (and (boundp '*source-info
*)
21 (make-file-info-namestring *compile-file-pathname
*
22 (sb!c
:get-toplevelish-file-info
*source-info
*)))
23 :type
(or string null
))
24 ;; Toplevel form index
26 (when (boundp '*current-path
*)
27 (source-path-tlf-number *current-path
*))
28 :type
(or fixnum null
))
29 ;; plist from WITH-COMPILATION-UNIT
30 (plist *source-plist
*))
32 (defun make-file-info-namestring (name file-info
)
33 #+sb-xc-host
(declare (ignore name
))
34 (let* ((untruename (file-info-untruename file-info
))
35 (dir (and untruename
(pathname-directory untruename
))))
37 (let ((src (position "src" dir
:test
#'string
=
40 ((and src
(not (string= (car (last dir
)) "output")))
41 (format nil
"SYS:~{~:@(~A~);~}~:@(~A~).LISP"
42 (subseq dir src
) (pathname-name untruename
)))
43 (t (aver (string-equal (car (last dir
)) "output"))
44 (aver (string-equal (pathname-name untruename
) "stuff-groveled-from-headers"))
45 (aver (string-equal (pathname-type untruename
) "lisp"))
46 "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.LISP")))
48 (if (and dir
(eq (first dir
) :absolute
))
49 (namestring untruename
)
54 #!+sb-source-locations
55 (define-compiler-macro source-location
(&environment env
)
56 (declare (ignore env
))
57 #-sb-xc-host
(make-definition-source-location))
59 ;; We need a regular definition of SOURCE-LOCATION for calls processed
60 ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET.
61 #!+sb-source-locations
62 (setf (symbol-function 'source-location
)
63 (lambda () (make-definition-source-location)))
65 (/show0
"/Processing source location thunks")
66 #!+sb-source-locations
67 (dolist (fun *source-location-thunks
*)
70 ;; Unbind the symbol to ensure that we detect any attempts to add new
72 (makunbound '*source-location-thunks
*)
73 (/show0
"/Done with source location thunks")