/[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.5 - (show annotations)
Mon Mar 29 17:49:38 2004 UTC (10 years ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-14, SLIME-0-13, SLIME-0-12
Changes since 1.4: +1 -1 lines
(cmucl-style-get-macro-character): The feature is CMU not CMUCL.
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 (in-package :swank-backend)
24
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 (declare (type function fn))
30 (lambda (stream char)
31 (let ((start (file-position stream))
32 (values (multiple-value-list (funcall fn stream char)))
33 (end (file-position stream)))
34 ;;(format t "[~D ~{~A~^, ~} ~D ~D]~%" start values end (char-code char))
35 (unless (null values)
36 (push (cons start end) (gethash (car values) source-map)))
37 (values-list values))))
38
39 #+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 ;;
48 ;; Just copy CMUCL's implementation, to get identical behavior. The
49 ;; SBCL implementation uses GET-RAW-CMT-ENTRY; we use
50 ;; GET-COERCED-CMT-ENTRY, which seems to be what SET-MACRO-CHARACTER
51 ;; expects. -- Helmut Eller
52 (defun cmucl-style-get-macro-character (char table)
53 (let ((rt (or table sb-impl::*standard-readtable*)))
54 (cond ((sb-impl::constituentp char)
55 (values (sb-impl::get-coerced-cmt-entry char rt) t))
56 ((sb-impl::terminating-macrop char)
57 (values (sb-impl::get-coerced-cmt-entry char rt) nil))
58 (t nil))))
59
60 #+cmu
61 (defun cmucl-style-get-macro-character (char table)
62 (get-macro-character char table))
63
64 (defun make-source-recording-readtable (readtable source-map)
65 "Return a source position recording copy of READTABLE.
66 The source locations are stored in SOURCE-MAP."
67 (let* ((tab (copy-readtable readtable))
68 (*readtable* tab))
69 (dotimes (code char-code-limit)
70 (let ((char (code-char code)))
71 (multiple-value-bind (fn term)
72 (cmucl-style-get-macro-character char tab)
73 (when fn
74 (set-macro-character char (make-source-recorder fn source-map)
75 term tab)))))
76 tab))
77
78 (defun make-source-map ()
79 (make-hash-table :test #'eq))
80
81 (defvar *source-map* (make-source-map)
82 "The hashtable table used for source position recording.")
83
84 (defvar *recording-readtable-cache* '()
85 "An alist of (READTABLE . RECORDING-READTABLE) pairs.")
86
87 (defun lookup-recording-readtable (readtable)
88 "Find a cached or create a new recording readtable for READTABLE."
89 (or (cdr (assoc readtable *recording-readtable-cache*))
90 (let ((table (make-source-recording-readtable readtable *source-map*)))
91 (push (cons readtable table) *recording-readtable-cache*)
92 table)))
93
94 (defun read-and-record-source-map (stream)
95 "Read the next object from STREAM.
96 Return the object together with a hashtable that maps
97 subexpressions of the object to stream positions."
98 (let ((*readtable* (lookup-recording-readtable *readtable*)))
99 (clrhash *source-map*)
100 (values (read stream) *source-map*)))
101
102 (defun source-path-stream-position (path stream)
103 "Search the source-path PATH in STREAM and return its position."
104 (destructuring-bind (tlf-number . path) path
105 (let ((*read-suppress* t))
106 (dotimes (i tlf-number) (read stream))
107 (multiple-value-bind (form source-map)
108 (read-and-record-source-map stream)
109 (source-path-source-position (cons 0 path) form source-map)))))
110
111 (defun source-path-string-position (path string)
112 (with-input-from-string (s string)
113 (source-path-stream-position path s)))
114
115 (defun source-path-file-position (path filename)
116 (with-open-file (file filename)
117 (source-path-stream-position path file)))
118
119 (defun source-path-source-position (path form source-map)
120 "Return the start position of PATH from FORM and SOURCE-MAP. All
121 subforms along the path are considered and the start and end position
122 of deepest (i.e. smallest) possible form is returned."
123 ;; compute all subforms along path
124 (let ((forms (loop for n in path
125 for f = form then (nth n f)
126 collect f)))
127 ;; select the first subform present in source-map
128 (loop for form in (reverse forms)
129 for positions = (gethash form source-map)
130 until (and positions (null (cdr positions)))
131 finally (destructuring-bind ((start . end)) positions
132 (return (values (1- start) end))))))
133

  ViewVC Help
Powered by ViewVC 1.1.5