1 | ;;;; |
---|
2 | ;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr@freebits.de> |
---|
3 | ;;;; |
---|
4 | ;;;; All rights reserved. |
---|
5 | ;;;; |
---|
6 | ;;;; See LICENSE for details. |
---|
7 | ;;;; |
---|
8 | |
---|
9 | (in-package :editor-hints.named-readtables) |
---|
10 | |
---|
11 | (defmacro define-cruft (name lambda-list &body (docstring . alternatives)) |
---|
12 | (assert (typep docstring 'string) (docstring) "Docstring missing!") |
---|
13 | (assert (not (null alternatives))) |
---|
14 | `(progn |
---|
15 | (declaim (inline ,name)) |
---|
16 | (defun ,name ,lambda-list ,docstring ,(first alternatives)))) |
---|
17 | |
---|
18 | (eval-when (:compile-toplevel :execute) |
---|
19 | #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE" |
---|
20 | (find-package "SB-IMPL")) |
---|
21 | (pushnew :sbcl+safe-standard-readtable *features*))) |
---|
22 | |
---|
23 | |
---|
24 | ;;;;; Implementation-dependent cruft |
---|
25 | |
---|
26 | ;;;; Mapping between a readtable object and its readtable-name. |
---|
27 | |
---|
28 | (defvar *readtable-names* (make-hash-table :test 'eq)) |
---|
29 | |
---|
30 | (define-cruft %associate-readtable-with-name (name readtable) |
---|
31 | "Associate READTABLE with NAME for READTABLE-NAME to work." |
---|
32 | #+ :common-lisp (setf (gethash readtable *readtable-names*) name)) |
---|
33 | |
---|
34 | (define-cruft %unassociate-readtable-from-name (name readtable) |
---|
35 | "Remove the association between READTABLE and NAME." |
---|
36 | #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*))) |
---|
37 | (remhash readtable *readtable-names*))) |
---|
38 | |
---|
39 | (define-cruft %readtable-name (readtable) |
---|
40 | "Return the name associated with READTABLE." |
---|
41 | #+ :common-lisp (values (gethash readtable *readtable-names*))) |
---|
42 | |
---|
43 | (define-cruft %list-all-readtable-names () |
---|
44 | "Return a list of all available readtable names." |
---|
45 | #+ :common-lisp (list* :standard :current |
---|
46 | (loop for name being each hash-value of *readtable-names* |
---|
47 | collect name))) |
---|
48 | |
---|
49 | |
---|
50 | ;;;; Mapping between a readtable-name and the actual readtable object. |
---|
51 | |
---|
52 | ;;; On Allegro we reuse their named-readtable support so we work |
---|
53 | ;;; nicely on their infrastructure. |
---|
54 | |
---|
55 | #-allegro |
---|
56 | (defvar *named-readtables* (make-hash-table :test 'eq)) |
---|
57 | |
---|
58 | #+allegro |
---|
59 | (defun readtable-name-for-allegro (symbol) |
---|
60 | (multiple-value-bind (kwd status) |
---|
61 | (if (keywordp symbol) |
---|
62 | (values symbol nil) |
---|
63 | ;; Kludge: ACL uses keywords to name readtables, we allow |
---|
64 | ;; arbitrary symbols. |
---|
65 | (intern (format nil "~A.~A" |
---|
66 | (package-name (symbol-package symbol)) |
---|
67 | (symbol-name symbol)) |
---|
68 | :keyword)) |
---|
69 | (prog1 kwd |
---|
70 | (assert (or (not status) (get kwd 'named-readtable-designator))) |
---|
71 | (setf (get kwd 'named-readtable-designator) t)))) |
---|
72 | |
---|
73 | (define-cruft %associate-name-with-readtable (name readtable) |
---|
74 | "Associate NAME with READTABLE for FIND-READTABLE to work." |
---|
75 | #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable) |
---|
76 | #+ :common-lisp (setf (gethash name *named-readtables*) readtable)) |
---|
77 | |
---|
78 | (define-cruft %unassociate-name-from-readtable (name readtable) |
---|
79 | "Remove the association between NAME and READTABLE" |
---|
80 | #+ :allegro (let ((n (readtable-name-for-allegro name))) |
---|
81 | (assert (eq readtable (excl:named-readtable n))) |
---|
82 | (setf (excl:named-readtable n) nil)) |
---|
83 | #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*))) |
---|
84 | (remhash name *named-readtables*))) |
---|
85 | |
---|
86 | (define-cruft %find-readtable (name) |
---|
87 | "Return the readtable named NAME." |
---|
88 | #+ :allegro (excl:named-readtable (readtable-name-for-allegro name) nil) |
---|
89 | #+ :common-lisp (values (gethash name *named-readtables* nil))) |
---|
90 | |
---|
91 | |
---|
92 | ;;;; Reader-macro related predicates |
---|
93 | |
---|
94 | ;;; CLISP creates new function objects for standard reader macros on |
---|
95 | ;;; each readtable copy. |
---|
96 | (define-cruft function= (fn1 fn2) |
---|
97 | "Are reader-macro function-designators FN1 and FN2 the same?" |
---|
98 | #+ :clisp |
---|
99 | (let* ((fn1 (ensure-function fn1)) |
---|
100 | (fn2 (ensure-function fn2)) |
---|
101 | (n1 (system::function-name fn1)) |
---|
102 | (n2 (system::function-name fn2))) |
---|
103 | (if (and (eq n1 :lambda) (eq n2 :lambda)) |
---|
104 | (eq fn1 fn2) |
---|
105 | (equal n1 n2))) |
---|
106 | #+ :sbcl |
---|
107 | (let ((fn1 (ensure-function fn1)) |
---|
108 | (fn2 (ensure-function fn2))) |
---|
109 | (or (eq fn1 fn2) |
---|
110 | ;; After SBCL 1.1.18, for dispatch macro characters |
---|
111 | ;; GET-MACRO-CHARACTER returns closures whose name is: |
---|
112 | ;; |
---|
113 | ;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR) |
---|
114 | ;; |
---|
115 | ;; Treat all these closures equivalent. |
---|
116 | (flet ((internal-dispatch-macro-closure-name-p (name) |
---|
117 | (find "SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR" name |
---|
118 | :key #'prin1-to-string :test #'string-equal))) |
---|
119 | (let ((n1 (sb-impl::%fun-name fn1)) |
---|
120 | (n2 (sb-impl::%fun-name fn2))) |
---|
121 | (and (listp n1) (listp n2) |
---|
122 | (internal-dispatch-macro-closure-name-p n1) |
---|
123 | (internal-dispatch-macro-closure-name-p n2)))))) |
---|
124 | #+ :common-lisp |
---|
125 | (eq (ensure-function fn1) (ensure-function fn2))) |
---|
126 | |
---|
127 | ;;; CLISP will incorrectly fold the call to G-D-M-C away |
---|
128 | ;;; if not declared inline. |
---|
129 | (define-cruft dispatch-macro-char-p (char rt) |
---|
130 | "Is CHAR a dispatch macro character in RT?" |
---|
131 | #+ :common-lisp |
---|
132 | (handler-case (locally |
---|
133 | #+clisp (declare (notinline get-dispatch-macro-character)) |
---|
134 | (get-dispatch-macro-character char #\x rt) |
---|
135 | t) |
---|
136 | (error () nil))) |
---|
137 | |
---|
138 | ;; (defun macro-char-p (char rt) |
---|
139 | ;; (let ((reader-fn (%get-macro-character char rt))) |
---|
140 | ;; (and reader-fn t))) |
---|
141 | |
---|
142 | ;; (defun standard-macro-char-p (char rt) |
---|
143 | ;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt) |
---|
144 | ;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*) |
---|
145 | ;; (and (eq rt-fn std-fn) |
---|
146 | ;; (eq rt-flag std-flag))))) |
---|
147 | |
---|
148 | ;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt) |
---|
149 | ;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt)))) |
---|
150 | ;; (and (eq (non-terminating-p disp-char rt) |
---|
151 | ;; (non-terminating-p disp-char *standard-readtable*)) |
---|
152 | ;; (eq (get-dispatch-macro-character disp-char sub-char rt) |
---|
153 | ;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*))))) |
---|
154 | |
---|
155 | |
---|
156 | ;;;; Readtables Iterators |
---|
157 | |
---|
158 | (defmacro with-readtable-iterator ((name readtable) &body body) |
---|
159 | (let ((it (gensym))) |
---|
160 | `(let ((,it (%make-readtable-iterator ,readtable))) |
---|
161 | (macrolet ((,name () `(funcall ,',it))) |
---|
162 | ,@body)))) |
---|
163 | |
---|
164 | #+sbcl |
---|
165 | (defun %make-readtable-iterator (readtable) |
---|
166 | (let ((char-macro-array (sb-impl::character-macro-array readtable)) |
---|
167 | (char-macro-ht (sb-impl::character-macro-hash-table readtable)) |
---|
168 | (dispatch-tables (sb-impl::dispatch-tables readtable)) |
---|
169 | (char-code 0)) |
---|
170 | (with-hash-table-iterator (ht-iterator char-macro-ht) |
---|
171 | (labels ((grovel-base-chars () |
---|
172 | (if (>= char-code sb-int:base-char-code-limit) |
---|
173 | (grovel-unicode-chars) |
---|
174 | (let ((reader-fn (svref char-macro-array char-code)) |
---|
175 | (char (code-char (shiftf char-code (1+ char-code))))) |
---|
176 | (if reader-fn |
---|
177 | (yield char) |
---|
178 | (grovel-base-chars))))) |
---|
179 | (grovel-unicode-chars () |
---|
180 | (multiple-value-bind (more? char) (ht-iterator) |
---|
181 | (if (not more?) |
---|
182 | (values nil nil nil nil nil) |
---|
183 | (yield char)))) |
---|
184 | (yield (char) |
---|
185 | (let ((disp-fn (get-macro-character char readtable)) |
---|
186 | (disp-ht)) |
---|
187 | (cond |
---|
188 | ((setq disp-ht (cdr (assoc char dispatch-tables))) |
---|
189 | (let ((sub-char-alist)) |
---|
190 | (maphash (lambda (k v) |
---|
191 | (push (cons k v) sub-char-alist)) |
---|
192 | disp-ht) |
---|
193 | (values t char disp-fn t sub-char-alist))) |
---|
194 | (t |
---|
195 | (values t char disp-fn nil nil)))))) |
---|
196 | #'grovel-base-chars)))) |
---|
197 | #+clozure |
---|
198 | (defun %make-readtable-iterator (readtable) |
---|
199 | (flet ((ensure-alist (x) |
---|
200 | #.`(etypecase x |
---|
201 | (list x) |
---|
202 | ,@(uiop:if-let (sv (uiop:find-symbol* '#:sparse-vector :ccl nil)) |
---|
203 | `((,sv |
---|
204 | (let ((table (uiop:symbol-call :ccl '#:sparse-vector-table x))) |
---|
205 | (uiop:while-collecting (c) |
---|
206 | (loop for i below (length table) do |
---|
207 | (uiop:if-let ((v (svref table i))) |
---|
208 | (loop with i8 = (ash i 8) |
---|
209 | for j below (length v) do |
---|
210 | (uiop:if-let ((datum (svref v j))) |
---|
211 | (c (cons (code-char (+ i8 j)) datum)))))))))))))) |
---|
212 | (let ((char-macros |
---|
213 | (ensure-alist |
---|
214 | (#.(or (uiop:find-symbol* '#:rdtab.macros :ccl nil) (uiop:find-symbol* '#:rdtab.alist :ccl)) readtable)))) |
---|
215 | (lambda () |
---|
216 | (if char-macros |
---|
217 | (destructuring-bind (char . defn) (pop char-macros) |
---|
218 | (if (consp defn) |
---|
219 | (values t char (car defn) t (ensure-alist (cdr defn))) |
---|
220 | (values t char defn nil nil))) |
---|
221 | (values nil nil nil nil nil)))))) |
---|
222 | |
---|
223 | ;;; Written on ACL 8.0. |
---|
224 | #+allegro |
---|
225 | (defun %make-readtable-iterator (readtable) |
---|
226 | (declare (optimize speed)) ; for TCO |
---|
227 | (check-type readtable readtable) |
---|
228 | (let* ((macro-table (first (excl::readtable-macro-table readtable))) |
---|
229 | (dispatch-tables (excl::readtable-dispatch-tables readtable)) |
---|
230 | (table-length (length macro-table)) |
---|
231 | (idx 0)) |
---|
232 | (labels ((grovel-macro-chars () |
---|
233 | (if (>= idx table-length) |
---|
234 | (grovel-dispatch-chars) |
---|
235 | (let ((read-fn (svref macro-table idx)) |
---|
236 | (oidx idx)) |
---|
237 | (incf idx) |
---|
238 | (if (or (eq read-fn #'excl::read-token) |
---|
239 | (eq read-fn #'excl::read-dispatch-char) |
---|
240 | (eq read-fn #'excl::undefined-macro-char)) |
---|
241 | (grovel-macro-chars) |
---|
242 | (values t (code-char oidx) read-fn nil nil))))) |
---|
243 | (grovel-dispatch-chars () |
---|
244 | (if (null dispatch-tables) |
---|
245 | (values nil nil nil nil nil) |
---|
246 | (destructuring-bind (disp-char sub-char-table) |
---|
247 | (first dispatch-tables) |
---|
248 | (setf dispatch-tables (rest dispatch-tables)) |
---|
249 | ;;; Kludge. We can't fully clear dispatch tables |
---|
250 | ;;; in %CLEAR-READTABLE. |
---|
251 | (when (eq (svref macro-table (char-code disp-char)) |
---|
252 | #'excl::read-dispatch-char) |
---|
253 | (values t |
---|
254 | disp-char |
---|
255 | (svref macro-table (char-code disp-char)) |
---|
256 | t |
---|
257 | (loop for subch-fn across sub-char-table |
---|
258 | for subch-code from 0 |
---|
259 | when subch-fn |
---|
260 | collect (cons (code-char subch-code) |
---|
261 | subch-fn)))))))) |
---|
262 | #'grovel-macro-chars))) |
---|
263 | |
---|
264 | |
---|
265 | #-(or sbcl clozure allegro) |
---|
266 | (eval-when (:compile-toplevel) |
---|
267 | (let ((*print-pretty* t)) |
---|
268 | (simple-style-warn |
---|
269 | "~&~@< ~@;~A has not been ported to ~A. ~ |
---|
270 | We fall back to a portable implementation of readtable iterators. ~ |
---|
271 | This implementation has to grovel through all available characters. ~ |
---|
272 | On Unicode-aware implementations this may come with some costs.~@:>" |
---|
273 | (package-name '#.*package*) (lisp-implementation-type)))) |
---|
274 | |
---|
275 | #-(or sbcl clozure allegro) |
---|
276 | (defun %make-readtable-iterator (readtable) |
---|
277 | (check-type readtable readtable) |
---|
278 | (let ((char-code 0)) |
---|
279 | #'(lambda () |
---|
280 | (prog () |
---|
281 | :GROVEL |
---|
282 | (when (< char-code char-code-limit) |
---|
283 | (let ((char (code-char char-code))) |
---|
284 | (incf char-code) |
---|
285 | (when (not char) (go :GROVEL)) |
---|
286 | (let ((fn (get-macro-character char readtable))) |
---|
287 | (when (not fn) (go :GROVEL)) |
---|
288 | (multiple-value-bind (disp? alist) |
---|
289 | (handler-case ; grovel dispatch macro characters. |
---|
290 | (values |
---|
291 | t |
---|
292 | ;; Only grovel upper case characters to |
---|
293 | ;; avoid duplicates. |
---|
294 | (loop for code from 0 below char-code-limit |
---|
295 | for subchar = (non-lowercase-code-char code) |
---|
296 | for disp-fn = (and subchar |
---|
297 | (get-dispatch-macro-character |
---|
298 | char subchar readtable)) |
---|
299 | when disp-fn |
---|
300 | collect (cons subchar disp-fn))) |
---|
301 | (error () nil)) |
---|
302 | (return (values t char fn disp? alist)))))))))) |
---|
303 | |
---|
304 | #-(or sbcl clozure allegro) |
---|
305 | (defun non-lowercase-code-char (code) |
---|
306 | (let ((ch (code-char code))) |
---|
307 | (when (and ch (or (not (alpha-char-p ch)) |
---|
308 | (upper-case-p ch))) |
---|
309 | ch))) |
---|
310 | |
---|
311 | (defmacro do-readtable ((entry-designator readtable &optional result) |
---|
312 | &body body) |
---|
313 | "Iterate through a readtable's macro characters, and dispatch macro characters." |
---|
314 | (destructuring-bind (char &optional reader-fn non-terminating-p disp? table) |
---|
315 | (if (symbolp entry-designator) |
---|
316 | (list entry-designator) |
---|
317 | entry-designator) |
---|
318 | (let ((iter (gensym "ITER+")) |
---|
319 | (more? (gensym "MORE?+")) |
---|
320 | (rt (gensym "READTABLE+"))) |
---|
321 | `(let ((,rt ,readtable)) |
---|
322 | (with-readtable-iterator (,iter ,rt) |
---|
323 | (loop |
---|
324 | (multiple-value-bind (,more? |
---|
325 | ,char |
---|
326 | ,@(when reader-fn (list reader-fn)) |
---|
327 | ,@(when disp? (list disp?)) |
---|
328 | ,@(when table (list table))) |
---|
329 | (,iter) |
---|
330 | (unless ,more? (return ,result)) |
---|
331 | (let ,(when non-terminating-p |
---|
332 | ;; FIXME: N-T-P should be incorporated in iterators. |
---|
333 | `((,non-terminating-p |
---|
334 | (nth-value 1 (get-macro-character ,char ,rt))))) |
---|
335 | ,@body)))))))) |
---|
336 | |
---|
337 | ;;;; Misc |
---|
338 | |
---|
339 | ;;; This should return an implementation's actual standard readtable |
---|
340 | ;;; object only if the implementation makes the effort to guard against |
---|
341 | ;;; modification of that object. Otherwise it should better return a |
---|
342 | ;;; copy. |
---|
343 | (define-cruft %standard-readtable () |
---|
344 | "Return the standard readtable." |
---|
345 | #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable* |
---|
346 | #+ :common-lisp (copy-readtable nil)) |
---|
347 | |
---|
348 | ;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a |
---|
349 | ;;; readtable's dispatch table properly. |
---|
350 | ;;; Same goes for Allegro but that does not seem to provide a |
---|
351 | ;;; setter for their readtable's dispatch tables. Hence this ugly |
---|
352 | ;;; workaround. |
---|
353 | (define-cruft %clear-readtable (readtable) |
---|
354 | "Make all macro characters in READTABLE be constituents." |
---|
355 | #+ :sbcl |
---|
356 | (prog1 readtable |
---|
357 | (do-readtable (char readtable) |
---|
358 | (set-syntax-from-char char #\A readtable)) |
---|
359 | (setf (sb-impl::dispatch-tables readtable) nil)) |
---|
360 | #+ :allegro |
---|
361 | (prog1 readtable |
---|
362 | (do-readtable (char readtable) |
---|
363 | (set-syntax-from-char char #\A readtable)) |
---|
364 | (let ((dispatch-tables (excl::readtable-dispatch-tables readtable))) |
---|
365 | (setf (cdr dispatch-tables) nil) |
---|
366 | (setf (caar dispatch-tables) #\Backspace) |
---|
367 | (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil)))) |
---|
368 | #+ :common-lisp |
---|
369 | (do-readtable (char readtable readtable) |
---|
370 | (set-syntax-from-char char #\A readtable))) |
---|
371 | |
---|
372 | ;;; See Clozure Trac Ticket 601. This is supposed to be removed at |
---|
373 | ;;; some point in the future. |
---|
374 | (define-cruft %get-dispatch-macro-character (char subchar rt) |
---|
375 | "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER." |
---|
376 | #+ :ccl (ignore-errors |
---|
377 | (get-dispatch-macro-character char subchar rt)) |
---|
378 | #+ :common-lisp (get-dispatch-macro-character char subchar rt)) |
---|
379 | |
---|
380 | ;;; Allegro stores READ-TOKEN as reader macro function of each |
---|
381 | ;;; constituent character. |
---|
382 | (define-cruft %get-macro-character (char rt) |
---|
383 | "Ensure ANSI behaviour for GET-MACRO-CHARACTER." |
---|
384 | #+ :allegro (let ((fn (get-macro-character char rt))) |
---|
385 | (cond ((not fn) nil) |
---|
386 | ((function= fn #'excl::read-token) nil) |
---|
387 | (t fn))) |
---|
388 | #+ :common-lisp (get-macro-character char rt)) |
---|
389 | |
---|
390 | |
---|
391 | ;;;; Specialized PRINT-OBJECT for named readtables. |
---|
392 | |
---|
393 | ;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT |
---|
394 | ;;; that specializes on READTABLE is actually forbidden. It's quite |
---|
395 | ;;; likely to work (modulo package-locks) on most implementations, |
---|
396 | ;;; though. |
---|
397 | |
---|
398 | ;;; We don't need this on Allegro CL's as we hook into their |
---|
399 | ;;; named-readtable facility, and they provide such a method already. |
---|
400 | #-allegro |
---|
401 | (without-package-lock (:common-lisp #+lispworks :implementation) |
---|
402 | (defmethod print-object :around ((rt readtable) stream) |
---|
403 | (let ((name (readtable-name rt))) |
---|
404 | (if name |
---|
405 | (print-unreadable-object (rt stream :type nil :identity t) |
---|
406 | (format stream "~A ~S" :named-readtable name)) |
---|
407 | (call-next-method))))) |
---|