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 ;;; A DEFINITION-SOURCE-LOCATION contains two packed fixnums in the INDICES slot,
  15 ;;; and unless there is a non-nil plist, does not store the plist.
  16 (def!struct (definition-source-location
  17              (:constructor %make-basic-definition-source-location
  18                            (namestring indices))
  19              (:copier nil))
  20   ;; Namestring of the source file that the definition was compiled from.
  21   ;; This is null if the definition was not compiled from a file.
  22   (namestring nil :type (or string null) :read-only t)
  23   (indices 0 :type integer :read-only t))
  24 (!set-load-form-method definition-source-location  (:xc :target))
  25 (def!struct (definition-source-location+plist
  26              (:include definition-source-location)
  27              (:constructor %make-full-definition-source-location
  28                            (namestring indices plist))
  29              (:copier nil))
  30   (plist nil :read-only t))
  31
  32 (declaim (inline definition-source-location-toplevel-form-number
  33                  definition-source-location-form-number
  34                  definition-source-location-plist))
  35 ;;; Toplevel form index
  36 (defun definition-source-location-toplevel-form-number (source-loc)
  37   (let ((val (ash (definition-source-location-indices source-loc) -15)))
  38     (cond ((plusp val) (1- val))
  39           ((minusp val) val))))
  40 ;; DFO form number within the top-level form
  41 (defun definition-source-location-form-number (source-loc)
  42   (let ((val (ldb (byte 15 0) (definition-source-location-indices source-loc))))
  43     (if (plusp val) (1- val))))
  44 ;; plist from WITH-COMPILATION-UNIT
  45 (defun definition-source-location-plist (source-loc)
  46   (when (typep (the definition-source-location source-loc)
  47                'definition-source-location+plist)
  48     (definition-source-location+plist-plist source-loc)))
  49
  50 (defun %make-definition-source-location (namestring tlf-num subform-num)
  51   (declare (type (or null (integer -1 *)) tlf-num)
  52            (type (or null unsigned-byte) subform-num))
  53   (let* ((plist *source-plist*)
  54          ;; Use 15 bits for subform#, and all other bits (including sign) for TLF#.
  55          ;; Map 0 to NIL, 1 to 0, 2 to 1, etc; but -1 remains itself.
  56          (indices
  57           (logior (ash (cond ((eql tlf-num -1) -1)
  58                              (tlf-num (1+ tlf-num))
  59                              (t 0))
  60                        15)
  61                   ;; If subform-num exceeds 32766 just drop it.
  62                   (if (and subform-num (< subform-num 32767))
  63                       (1+ subform-num)
  64                       0)))
  65          (source-info (and (boundp '*source-info*) *source-info*))
  66          (last (and source-info
  67                     (source-info-last-defn-source-loc source-info))))
  68     (if (and last
  69              (eql (definition-source-location-indices last) indices)
  70              (string= (definition-source-location-namestring last) namestring)
  71              (equal (definition-source-location-plist last) plist))
  72         last
  73         (let ((new (if plist
  74                        (%make-full-definition-source-location namestring indices plist)
  75                        (%make-basic-definition-source-location namestring indices))))
  76           (when source-info
  77             (setf (source-info-last-defn-source-loc source-info) new))
  78           new))))
  79
  80 (defun make-definition-source-location ()
  81   (let* ((source-info (and (boundp '*source-info*) *source-info*))
  82          (namestring
  83           (or *source-namestring*
  84               (when source-info
  85                 (make-file-info-namestring
  86                  cl:*compile-file-pathname*
  87                  (get-toplevelish-file-info source-info)))))
  88          tlf-number
  89          form-number)
  90     (acond ((boundp '*current-path*)
  91             (setf tlf-number (source-path-tlf-number *current-path*)
  92                   form-number (source-path-form-number *current-path*)))
  93            ((and source-info (source-info-file-info source-info))
  94             (setf tlf-number (1- (fill-pointer (file-info-forms it))))))
  95     (%make-definition-source-location namestring tlf-number form-number)))
  96
  97 (defun make-file-info-namestring (name file-info)
  98   (let* ((pathname (file-info-pathname file-info))
  99          (dir (and pathname (pathname-directory pathname))))
 100     (if (and dir (eq (first dir) :absolute))
 101         (namestring pathname)
 102         (if name
 103             (namestring name)
 104             nil))))
 105
 106 #+sb-source-locations
 107 (progn
 108   (define-source-transform source-location ()
 109     (make-definition-source-location))
 110   ;; We need a regular definition of SOURCE-LOCATION for calls processed
 111   ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET.
 112   #-sb-xc-host
 113   (defun source-location ()
 114     (make-definition-source-location)))
 115
 116 #+(and (not sb-source-locations) (not sb-xc-host)) ; defined in cross-misc in make-host-1
 117 (defun source-location () nil)
 118
 119 (in-package "SB-IMPL")
 120
 121 (defvar *eval-source-context* nil)
 122 (defvar *eval-tlf-index* nil)
 123 (defvar *eval-source-info* nil)