fix rounding of floats big enough to be bignums
[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    (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")