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              (:constructor %make-definition-source-location
  16                            (namestring toplevel-form-number form-number))
  17              (:copier nil)
  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   ;; DFO form number within the top-level form
  25   (form-number nil :type (or fixnum null) :read-only t)
  26   ;; plist from WITH-COMPILATION-UNIT
  27   (plist *source-plist* :read-only t))
  28
  29 (defun make-definition-source-location ()
  30   (let* ((source-info (and (boundp '*source-info*) *source-info*))
  31          (namestring
  32           (or *source-namestring*
  33               (when source-info
  34                 (make-file-info-namestring
  35                  *compile-file-pathname*
  36                  (get-toplevelish-file-info *source-info*)))))
  37          tlf-number
  38          form-number
  39          (last (and source-info
  40                     (source-info-last-defn-source-loc source-info))))
  41     (acond ((boundp '*current-path*)
  42             (setf tlf-number (source-path-tlf-number *current-path*)
  43                   form-number (source-path-form-number *current-path*)))
  44            ((and source-info (source-info-file-info source-info))
  45             (setf tlf-number (1- (fill-pointer (file-info-forms it))))))
  46     (if (and last
  47              (eql (definition-source-location-toplevel-form-number last) tlf-number)
  48              (eql (definition-source-location-form-number last) form-number)
  49              (string= (definition-source-location-namestring last) namestring)
  50              (equal (definition-source-location-plist last) *source-plist*))
  51         last
  52         (let ((new (%make-definition-source-location namestring tlf-number form-number)))
  53           (when source-info
  54             (setf (source-info-last-defn-source-loc source-info) new))
  55           new))))
  56
  57 #+sb-xc-host
  58 (defun lpnify-namestring (untruename dir type)
  59   (let ((src (position "src" dir :test #'string= :from-end t)))
  60     (cond
  61      ((and src (not (string= (car (last dir)) "output")))
  62       (format nil "SYS:~{~:@(~A~);~}~:@(~A~).~:@(~A~)"
  63               (subseq dir src) (pathname-name untruename) type))
  64      (t (aver (string-equal (car (last dir)) "output"))
  65         (aver (string-equal (pathname-name untruename) "stuff-groveled-from-headers"))
  66         (format nil "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.~:@(~A~)" type)))))
  67
  68 (defun make-file-info-namestring (name file-info)
  69   #+sb-xc-host (declare (ignore name))
  70   (let* ((untruename (file-info-untruename file-info))
  71          (dir (and untruename (pathname-directory untruename))))
  72     #+sb-xc-host
  73     (lpnify-namestring untruename dir (pathname-type untruename))
  74     #-sb-xc-host
  75     (if (and dir (eq (first dir) :absolute))
  76         (namestring untruename)
  77         (if name
  78             (namestring name)
  79             nil))))