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    (or *source-namestring*
  20        (when (and (boundp '*source-info*)
  21                   *source-info*)
  22          (make-file-info-namestring *compile-file-pathname*
  23                                     (sb!c:get-toplevelish-file-info *source-info*))))
  24    :type (or string null))
  25   ;; Toplevel form index
  26   (toplevel-form-number
  27    (when (boundp '*current-path*)
  28      (source-path-tlf-number *current-path*))
  29    :type (or fixnum null))
  30   ;; plist from WITH-COMPILATION-UNIT
  31   (plist *source-plist*))
  32
  33 (defun make-file-info-namestring (name file-info)
  34   #+sb-xc-host (declare (ignore name))
  35   (let* ((untruename (file-info-untruename file-info))
  36          (dir (and untruename (pathname-directory untruename))))
  37     #+sb-xc-host
  38     (let ((src (position "src" dir :test #'string=
  39                          :from-end t)))
  40       (cond
  41         ((and src (not (string= (car (last dir)) "output")))
  42          (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
  43                  (subseq dir src) (pathname-name untruename)))
  44         (t (aver (string-equal (car (last dir)) "output"))
  45            (aver (string-equal (pathname-name untruename) "stuff-groveled-from-headers"))
  46            (aver (string-equal (pathname-type untruename) "lisp"))
  47            "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.LISP")))
  48     #-sb-xc-host
  49     (if (and dir (eq (first dir) :absolute))
  50         (namestring untruename)
  51         (if name
  52             (namestring name)
  53             nil))))
  54
  55 #!+sb-source-locations
  56 (define-compiler-macro source-location (&environment env)
  57   (declare (ignore env))
  58   #-sb-xc-host (make-definition-source-location))
  59
  60 ;; We need a regular definition of SOURCE-LOCATION for calls processed
  61 ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET.
  62 #!+sb-source-locations
  63 (setf (symbol-function 'source-location)
  64       (lambda () (make-definition-source-location)))
  65
  66 (/show0 "/Processing source location thunks")
  67 #!+sb-source-locations
  68 (dolist (fun *source-location-thunks*)
  69   (/show0 ".")
  70   (funcall fun))
  71 ;; Unbind the symbol to ensure that we detect any attempts to add new
  72 ;; thunks after this.
  73 (makunbound '*source-location-thunks*)
  74 (/show0 "/Done with source location thunks")