/[slime]/slime/swank-source-path-parser.lisp
ViewVC logotype

Contents of /slime/swank-source-path-parser.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Fri Aug 13 20:32:33 2004 UTC (9 years, 8 months ago) by lgorrie
Branch: MAIN
CVS Tags: SLIME-1-0
Changes since 1.6: +4 -17 lines
Removed caching of readtables and the source-map hashtable. Fresh
creation is ultra-cheap (<1ms).
The caching didn't handle modifications to readtables and generally
made me feel uneasy while tracking down an obscure bug in a reader
macro.

The cached source-map hashtable also wasn't thread-safe (ho hum).
1 dbarlow 1.1 ;;;; Source-paths
2    
3     ;;; CMUCL/SBCL use a data structure called "source-path" to locate
4     ;;; subforms. The compiler assigns a source-path to each form in a
5     ;;; compilation unit. Compiler notes usually contain the source-path
6     ;;; of the error location.
7     ;;;
8     ;;; Compiled code objects don't contain source paths, only the
9     ;;; "toplevel-form-number" and the (sub-) "form-number". To get from
10     ;;; the form-number to the source-path we need the entire toplevel-form
11     ;;; (i.e. we have to read the source code). CMUCL has already some
12     ;;; utilities to do this translation, but we use some extended
13     ;;; versions, because we need more exact position info. Apparently
14     ;;; Hemlock is happy with the position of the toplevel-form; we also
15     ;;; need the position of subforms.
16     ;;;
17     ;;; We use a special readtable to get the positions of the subforms.
18     ;;; The readtable stores the start and end position for each subform in
19     ;;; hashtable for later retrieval.
20    
21     ;;; Taken from swank-cmucl.lisp, by Helmut Eller
22    
23 heller 1.3 (in-package :swank-backend)
24 dbarlow 1.1
25     (defun make-source-recorder (fn source-map)
26     "Return a macro character function that does the same as FN, but
27     additionally stores the result together with the stream positions
28     before and after of calling FN in the hashtable SOURCE-MAP."
29 heller 1.2 (declare (type function fn))
30 dbarlow 1.1 (lambda (stream char)
31     (let ((start (file-position stream))
32     (values (multiple-value-list (funcall fn stream char)))
33     (end (file-position stream)))
34 heller 1.2 ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char))
35 dbarlow 1.1 (unless (null values)
36     (push (cons start end) (gethash (car values) source-map)))
37     (values-list values))))
38    
39 heller 1.4 #+sbcl
40     ;; not sure why this should be the case, but SBCL 0.8.6 returns
41     ;; #<FUNCTION "top level local call SB!IMPL::UNDEFINED-MACRO-CHAR">
42     ;; for (get-macro-character) on characters that aren't macros.
43     ;; As there's no way to detect the syntax of a character (only
44     ;; to set it from another character) we have to compare against
45     ;; this undefined-macro function to avoid turning everything into
46     ;; a macro -- Dan Barlow
47 heller 1.6 (if (not (get-macro-character #\space nil))
48     (defun cmucl-style-get-macro-character (char table)
49     (get-macro-character char table))
50     (defun cmucl-style-get-macro-character (char table)
51     (let ((rt (or table sb-impl::*standard-readtable*)))
52     (cond ((sb-impl::constituentp char)
53     (values (sb-impl::get-coerced-cmt-entry char rt) t))
54     ((sb-impl::terminating-macrop char)
55     (values (sb-impl::get-coerced-cmt-entry char rt) nil))
56     (t
57     (values nil nil))))))
58 heller 1.4
59 heller 1.5 #+cmu
60 heller 1.4 (defun cmucl-style-get-macro-character (char table)
61     (get-macro-character char table))
62 heller 1.6
63     ;; Unlike CMUCL, SBCL stores NIL values into the character-macro-table
64     ;; for constituent (in the CL sense) chars, and uses
65     ;; get-coerced-cmt-entry to convert those NILs to #'read-token. In
66     ;; CMUCL all constituents are also macro-chars.
67     ;;
68     ;; CMUCL and SBCL use a somewhat strange encoding for CL's Character
69     ;; Syntax Types:
70     ;;
71     ;; CL Implementation
72     ;; ---------------- --------------
73     ;; Constituent (constituentp x) i.e. (<= +char-attr-constituent+ x)
74     ;; Macro Char (constituentp x) or +char-attr-terminating-macro+
75     ;; Single Escape +char-attr-escape+
76     ;; Invalid (constituentp x) with undefined-macro-char as fun
77     ;; Multiple Escape +char-attr-multiple-escape+
78     ;; Whitespace +char-attr-whitespace+
79     ;;
80     ;; One effect of this encoding is that invalid chars are not detected
81     ;; inside tokens and it seems that there's no good way to distinguish
82     ;; constituents from macro-chars.
83    
84     (defun dump-readtable (rt)
85     (dotimes (code char-code-limit)
86     (let ((char (code-char code)))
87     (multiple-value-bind (fn terminatingp) (get-macro-character char rt)
88     (format t "~S[~D]: ~12,1T~A ~A~%"
89     char code fn terminatingp)))))
90    
91     ;; (dump-readtable *readtable*)
92    
93     (let ((rt (copy-readtable nil)))
94     ;; If #\space is a macro-char, it shouldn't terminate tokens.
95     (assert (or (not (cmucl-style-get-macro-character #\space rt))
96     (nth-value 1 (cmucl-style-get-macro-character #\space rt))))
97     ;; In SBCL (get-macro-character #\\) returns #'read-token, t. And
98     ;; (set-macro-character #\\ #'read-token t) confuses #'read-string,
99     ;; because it uses the attributes in the readtable for parsing
100     ;; decisions.
101     (assert (not (cmucl-style-get-macro-character #\\ rt))))
102 heller 1.4
103 dbarlow 1.1 (defun make-source-recording-readtable (readtable source-map)
104     "Return a source position recording copy of READTABLE.
105     The source locations are stored in SOURCE-MAP."
106     (let* ((tab (copy-readtable readtable))
107 heller 1.4 (*readtable* tab))
108 dbarlow 1.1 (dotimes (code char-code-limit)
109     (let ((char (code-char code)))
110 heller 1.4 (multiple-value-bind (fn term)
111     (cmucl-style-get-macro-character char tab)
112     (when fn
113 dbarlow 1.1 (set-macro-character char (make-source-recorder fn source-map)
114     term tab)))))
115     tab))
116    
117 lgorrie 1.7 (defvar *source-map* nil
118 dbarlow 1.1 "The hashtable table used for source position recording.")
119    
120     (defun read-and-record-source-map (stream)
121     "Read the next object from STREAM.
122     Return the object together with a hashtable that maps
123     subexpressions of the object to stream positions."
124 lgorrie 1.7 (let* ((*source-map* (make-hash-table :test #'eq))
125     (*readtable* (make-source-recording-readtable *readtable* *source-map*)))
126 dbarlow 1.1 (values (read stream) *source-map*)))
127 lgorrie 1.7
128 dbarlow 1.1 (defun source-path-stream-position (path stream)
129     "Search the source-path PATH in STREAM and return its position."
130     (destructuring-bind (tlf-number . path) path
131     (let ((*read-suppress* t))
132     (dotimes (i tlf-number) (read stream))
133     (multiple-value-bind (form source-map)
134     (read-and-record-source-map stream)
135     (source-path-source-position (cons 0 path) form source-map)))))
136    
137     (defun source-path-string-position (path string)
138     (with-input-from-string (s string)
139     (source-path-stream-position path s)))
140    
141     (defun source-path-file-position (path filename)
142     (with-open-file (file filename)
143     (source-path-stream-position path file)))
144    
145     (defun source-path-source-position (path form source-map)
146     "Return the start position of PATH from FORM and SOURCE-MAP. All
147     subforms along the path are considered and the start and end position
148     of deepest (i.e. smallest) possible form is returned."
149     ;; compute all subforms along path
150     (let ((forms (loop for n in path
151     for f = form then (nth n f)
152     collect f)))
153     ;; select the first subform present in source-map
154     (loop for form in (reverse forms)
155     for positions = (gethash form source-map)
156     until (and positions (null (cdr positions)))
157     finally (destructuring-bind ((start . end)) positions
158     (return (values (1- start) end))))))
159    

  ViewVC Help
Powered by ViewVC 1.1.5