1.0.18.16: many STYLE-WARNING changes.
[sbcl.git] / src / code / source-location.lisp
1 ;;;; Source location tracking.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!C")
13
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.
18   (namestring
19    (when (and (boundp '*source-info*)
20               *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
25   (toplevel-form-number
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*))
31
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))))
36     #+sb-xc-host
37     (let ((src (position "src" dir :test #'string=
38                          :from-end t)))
39       (if src
40           (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
41                   (subseq dir src) (pathname-name untruename))
42           ;; FIXME: just output/stuff-groveled-from-headers.lisp
43           (namestring untruename)))
44     #-sb-xc-host
45     (if (and dir (eq (first dir) :absolute))
46         (namestring untruename)
47         (if name
48             (namestring name)
49             nil))))
50
51 #!+sb-source-locations
52 (define-compiler-macro source-location (&environment env)
53   (declare (ignore env))
54   #-sb-xc-host (make-definition-source-location))
55
56 (/show0 "/Processing source location thunks")
57 #!+sb-source-locations
58 (dolist (fun *source-location-thunks*)
59   (/show0 ".")
60   (funcall fun))
61 ;; Unbind the symbol to ensure that we detect any attempts to add new
62 ;; thunks after this.
63 (makunbound '*source-location-thunks*)
64 (/show0 "/Done with source location thunks")