0.9.13.30
[sbcl.git] / src / code / early-source-location.lisp
1 ;;;; Minimal implementation of the source-location tracking machinery, which
2 ;;;; defers the real work to until source-location.lisp
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!C")
14
15 (defvar *source-location-thunks* nil)
16
17 ;; Should get called only in unusual circumstances. Normally handled
18 ;; by a compiler macro.
19 (defun source-location ()
20   nil)
21
22 ;; Will be redefined in src/code/source-location.lisp
23 #-sb-xc-host
24 (define-compiler-macro source-location ()
25   (when (and (boundp '*source-info*)
26              (symbol-value '*source-info*))
27     `(cons ,(make-file-info-namestring
28               *compile-file-pathname*
29               (source-info-file-info (symbol-value '*source-info*)))
30            ,(when (boundp '*current-path*)
31                   (source-path-tlf-number (symbol-value '*current-path*))))))
32
33 ;; If the whole source location tracking machinery has been loaded
34 ;; (detected by the type of SOURCE-LOCATION), execute BODY. Otherwise
35 ;; wrap it in a lambda and execute later.
36 (defmacro with-source-location ((source-location) &body body)
37   `(when ,source-location
38      (if (consp ,source-location)
39          (push (lambda ()
40                  (let ((,source-location
41                         (make-definition-source-location
42                          :namestring (car ,source-location)
43                          :toplevel-form-number (cdr ,source-location))))
44                    ,@body))
45                *source-location-thunks*)
46          ,@body)))