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 (source-info-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 (let* ((untruename (file-info-untruename file-info
))
34 (dir (and untruename
(pathname-directory untruename
))))
36 (let ((src (position "src" dir
:test
#'string
=
39 (format nil
"SYS:~{~:@(~A~);~}~:@(~A~).LISP"
40 (subseq dir src
) (pathname-name untruename
))
41 ;; FIXME: just output/stuff-groveled-from-headers.lisp
42 (namestring untruename
)))
44 (if (and dir
(eq (first dir
) :absolute
))
45 (namestring untruename
)
50 #!+sb-source-locations
51 (define-compiler-macro source-location
(&environment env
)
53 (unless (policy env
(and (> space
1)
55 (make-definition-source-location)))
57 (/show0
"/Processing source location thunks")
58 #!+sb-source-locations
59 (dolist (fun *source-location-thunks
*)
62 ;; Unbind the symbol to ensure that we detect any attempts to add new
64 (makunbound '*source-location-thunks
*)
65 (/show0
"/Done with source location thunks")