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 (:constructor %make-definition-source-location
16 (namestring toplevel-form-number
))
18 (:make-load-form-fun just-dump-it-normally
))
19 ;; Namestring of the source file that the definition was compiled from.
20 ;; This is null if the definition was not compiled from a file.
21 (namestring nil
:type
(or string null
) :read-only t
)
22 ;; Toplevel form index
23 (toplevel-form-number nil
:type
(or fixnum null
) :read-only t
)
24 ;; plist from WITH-COMPILATION-UNIT
25 (plist *source-plist
* :read-only t
))
27 (defun make-definition-source-location ()
28 (let* ((source-info (and (boundp '*source-info
*) *source-info
*))
30 (or *source-namestring
*
32 (make-file-info-namestring
33 *compile-file-pathname
*
34 (get-toplevelish-file-info *source-info
*)))))
35 (tlf-num (acond ((boundp '*current-path
*)
36 (source-path-tlf-number *current-path
*))
37 ((and source-info
(source-info-file-info source-info
))
38 (1- (fill-pointer (file-info-forms it
))))))
39 (last (and source-info
40 (source-info-last-defn-source-loc source-info
))))
42 (eql (definition-source-location-toplevel-form-number last
) tlf-num
)
43 (string= (definition-source-location-namestring last
) namestring
)
44 (equal (definition-source-location-plist last
) *source-plist
*))
46 (let ((new (%make-definition-source-location namestring tlf-num
)))
48 (setf (source-info-last-defn-source-loc source-info
) new
))
52 (defun lpnify-namestring (untruename dir type
)
53 (let ((src (position "src" dir
:test
#'string
= :from-end t
)))
55 ((and src
(not (string= (car (last dir
)) "output")))
56 (format nil
"SYS:~{~:@(~A~);~}~:@(~A~).~:@(~A~)"
57 (subseq dir src
) (pathname-name untruename
) type
))
58 (t (aver (string-equal (car (last dir
)) "output"))
59 (aver (string-equal (pathname-name untruename
) "stuff-groveled-from-headers"))
60 (format nil
"SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.~:@(~A~)" type
)))))
62 (defun make-file-info-namestring (name file-info
)
63 #+sb-xc-host
(declare (ignore name
))
64 (let* ((untruename (file-info-untruename file-info
))
65 (dir (and untruename
(pathname-directory untruename
))))
67 (lpnify-namestring untruename dir
(pathname-type untruename
))
69 (if (and dir
(eq (first dir
) :absolute
))
70 (namestring untruename
)