named-readtables.lisp 18.1 KB
Newer Older
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
1
2
3
4
5
6
7
8
;;;;
;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
;;;; Copyright (c) 2007, Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC
;;;;
;;;; All rights reserved.
;;;;
;;;; See LICENSE for details.
;;;;
9
10
11
12
13
14
15
16
17
18
19

(in-package :editor-hints.named-readtables)

;;;
;;;  ``This is enough of a foothold to implement a more elaborate
;;;    facility for using readtables in a localized way.''
;;;
;;;                               (X3J13 Cleanup Issue IN-SYNTAX)
;;;


20
21
22
23
24
25
26
27
28
29
30
31
32
33
;;; TODO:
;;;
;;;    * Remove redefinition style-warning in DEFREADTABLE
;;;
;;;    * Add style-warning if redefined readtable contains entries
;;;      not specified in the DEFREADTABLE form (cf. SBCL's DEFPACKAGE)
;;;
;;;    * Add style-warning if :MERGE overwrites entries
;;;
;;;    * Add :FUZE that's like :MERGE without the style-warnings
;;;
;;;    * Think about MAKE-DISPATCHING-MACRO-CHARACTER in DEFREADTABLE


34
35
;;;;;; DEFREADTABLE &c.

36
(defmacro defreadtable (name &body options)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
37
38
39
  "Define a new named readtable, whose name is given by the symbol `name'.
Or, if a readtable is already registered under that name, redefine that
one.
40

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
41
The readtable can be populated using the following `options':
42

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
43
  (:MERGE `readtable-designators'+)
44
45

      Merge the readtables designated into the new readtable, using
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
46
      MERGE-READTABLES-INTO.
47
 
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
48
49
50
      Note that the process of merging readtables is _not_ commutative, so
      that reader macros in earlier entries will be overwritten by later
      ones.
51

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
52
  (:DISPATCH-MACRO-CHAR `macro-char' `sub-char' `function')
53

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
54
55
56
57
      Define a new sub character `sub-char' for the dispatching macro
      character `macro-char', per SET-DISPATCH-MACRO-CHARACTER. You
      probably have to define `macro-char' as a dispatching macro character
      by the following option first.
58

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
59
  (:MACRO-CHAR `macro-char' `function' [`non-terminating-p'])
60

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
61
62
63
      Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
      If `function' is the keyword :DISPATCH, `macro-char' is made a dispatching
      macro character, per MAKE-DISPATCH-MACRO-CHARACTER.
64

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
65
  (:SYNTAX-FROM `from-readtable-designator' `from-char' `to-char')
66

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
67
68
      Set the character syntax of `to-char' in the readtable being defined
      to the same syntax as `from-char' as per SET-SYNTAX-FROM-CHAR.
69

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
70
  (:CASE `case-mode') 
71

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
72
      Defines the /case sensitivity mode/ of the resulting readtable.
73

74
Any number of option clauses may appear. The options are grouped by their
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
75
76
77
78
type, but in each group the order the options appeared textually is
preserved.  The following groups exist and are executed in the following
order: :MERGE, :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group),
finally :SYNTAX-FROM.
79

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
80
81
82
83
84
85
86
Notes:

  The readtable is defined at load-time. If you want to have it available
  at compilation time -- say to use its reader-macros in the same file as
  its definition -- you have to wrap the DEFREADTABLE form in an explicit
  EVAL-WHEN.

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
87
88
  NIL, :STANDARD, :EMPTY, and :CURRENT are preregistered readtable
  names.
89
"
90
91
  (check-type name symbol)
  (when (reserved-readtable-name-p name)
92
    (error "~A is the designator for a predefined readtable. ~
93
            Not acceptable as a user-specified readtable name." name))
94
95
96
  (flet ((process-option (option var)
           (destructure-case option
             ((:merge &rest readtable-designators)
97
	      `(merge-readtables-into ,var ,@readtable-designators))
98
99
100
             ((:dispatch-macro-char disp-char sub-char function)
              `(set-dispatch-macro-character ,disp-char ,sub-char ,function ,var))
             ((:macro-char char function &optional non-terminating-p)
101
102
103
104
105
106
	      (if (eq function :dispatch)
		  ;; FIXME: This is not perfect as SBCL signals an
		  ;; error on already existing dispatch macros. I sent
		  ;; an appropriate patch upstream.
		  `(make-dispatch-macro-character ,char ,non-terminating-p ,var)
		  `(set-macro-character ,char ,function ,non-terminating-p ,var)))
107
108
109
	     ((:syntax-from from-rt-designator from-char to-char)
	      `(set-syntax-from-char ,to-char ,from-char 
				     ,var (find-readtable ,from-rt-designator)))
110
111
	     ((:case mode)
	      `(setf (readtable-case ,var) ,mode))))
112
113
114
115
116
117
118
119
120
121
122
123
124
125
	 (remove-clauses (clauses options)
	   (setq clauses (if (listp clauses) clauses (list clauses)))
	   (remove-if-not #'(lambda (x) (member x clauses)) 
			  options :key #'first)))
    (let* ((merge-clauses  (remove-clauses :merge options))
	   (case-clauses   (remove-clauses :case  options))
	   (macro-clauses  (remove-clauses '(:macro-char :dispatch-macro-char)
					   options))
	   (syntax-clauses (remove-clauses :syntax-from options))
	   (other-clauses  (set-difference options 
					   (append merge-clauses case-clauses 
						   macro-clauses syntax-clauses))))
      (cond 
	((not (null other-clauses))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
126
	 (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
127
128
129
130
131
132
133
134
135
136
	(t
	 `(eval-when (:load-toplevel :execute)
	    (handler-bind ((readtable-does-already-exist
			    #'(lambda (c)
				(simple-style-warn 
				 "Overwriting previously existing readtable ~S."
				 (existing-readtable-name c))
				(continue c))))
	      ;; The (FIND-READTABLE ...) is important for proper redefinition
	      ;; semantics.
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
137
138
	      (let ((readtable (or (find-readtable ',name)
                                   (make-readtable ',name))))
139
140
141
142
143
144
145
146
147
148
149
		,@(loop for option in merge-clauses
			collect (process-option option 'readtable))
		,@(loop for option in case-clauses
			collect (process-option option 'readtable))
		,@(loop for option in macro-clauses
			collect (process-option option 'readtable))
		,@(loop for option in syntax-clauses
			collect (process-option option 'readtable))
		readtable))))))))

(defmacro in-readtable (name)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
150
  "Bind *READTABLE* to the readtable referred to by the symbol `name'."
151
152
153
154
155
156
  (check-type name symbol)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf *readtable* (ensure-readtable ',name))
     (when (find-package :swank)
       (%frob-swank-readtable-alist *package* *readtable*))
     ))
157

158
159
160
161
162
;;; KLUDGE:
;;;   We need support for this in Slime itself, because we want IN-READTABLE
;;;   to work on a per-file basis, and not on a per-package basis.
;;; 
(defun %frob-swank-readtable-alist (package readtable)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
163
164
  (let ((readtable-alist (find-symbol (string '#:*readtable-alist*) 
				      (find-package :swank))))
165
166
167
168
169
170
171
172
173
    (when (boundp readtable-alist)
      (pushnew (cons (package-name package) readtable)
	       (symbol-value readtable-alist)
	       :test #'(lambda (entry1 entry2)
			 (destructuring-bind (pkg-name1 . rt1) entry1
			   (destructuring-bind (pkg-name2 . rt2) entry2
			     (and (string= pkg-name1 pkg-name2)
				  (eq rt1 rt2)))))))))

174

175
(defun make-readtable (name &key merge)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
176
177
178
  "Creates and returns a new readtable under the specified `name'.

`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
179
180
readtables the new readtable is created from. (See the :MERGE clause of
DEFREADTABLE for details.) If `merge' wasn't given (or NIL), the :EMPTY
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
181
readtable is used instead."
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
182
  (let ((merge-list (or merge '(:empty))))
183
184
185
186
    (check-type merge-list list)
    (cond ((reserved-readtable-name-p name)
	   (error "~A is the designator for a predefined readtable. ~
                   Not acceptable as a user-specified readtable name." name))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
187
188
	  ((let ((rt (find-readtable name)))
	     (and rt (cerror "Overwrite existing readtable." 
189
			     'readtable-does-already-exist :readtable-name name))))
190
	  (t (let ((result (apply #'merge-readtables-into
191
192
193
194
195
196
197
				  ;; The first readtable specified in the :merge list is
				  ;; taken as the basis for all subsequent (destructive!)
				  ;; modifications (and hence it's copied.)
				  (copy-readtable (ensure-readtable (first merge-list)))
				  (rest merge-list))))
	       (register-readtable name result))))))

198
(defun rename-readtable (named-readtable-designator new-name)
199
  "Replaces the associated name of the readtable designated by
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
200
201
`named-readtable-designator' with `new-name'. If a readtable is already
registered under `new-name', an error is raised."
202
  (check-type named-readtable-designator named-readtable-designator)
203
204
  (check-type new-name symbol)
  (when (find-readtable new-name)
205
206
    (cerror "Overwrite existing readtable." 
            'readtable-does-already-exist :readtable-name new-name))
207
208
209
210
  (let* ((read-table (ensure-readtable named-readtable-designator))
	 (read-table-name (readtable-name read-table)))
    ;; We use the internal functions directly to omit repeated
    ;; type-checking.
211
212
213
214
    (%unassociate-name-from-readtable read-table-name read-table)
    (%unassociate-readtable-from-name read-table-name read-table)
    (%associate-name-with-readtable new-name read-table)
    (%associate-readtable-with-name new-name read-table)
215
216
    read-table))

217
(defun merge-readtables-into (result-table &rest named-readtable-designators)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
218
219
220
221
222
  "Copy the contents of each readtable in `named-readtable-designators'
into `result-table'. Because the readtables are merged in turn, macro
definitions in readtables appearing later in the list will overwrite
reader-macros appearing earlier.  Notice that the /readtable case/ is also
subject of the merge operation."
223
  (flet ((merge-into (rt1 rt2)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
224
225
226
227
228
229
230
231
	   (do-readtable ((char reader-fn disp? table) rt2)
             (unless (standard-macro-char-p char rt2)
               (let ((non-terminating-p (nth-value 1 (get-macro-character char rt2))))
                 (set-macro-character char reader-fn non-terminating-p rt1)))
             (when disp?
               (loop for (subchar . subfn) in table do
                     (unless (standard-dispatch-macro-char-p char subchar rt2)
                       (set-dispatch-macro-character char subchar subfn rt1)))))
232
233
234
235
236
	   rt1))
    (setf result-table (ensure-readtable result-table))
    (dolist (table (mapcar #'ensure-readtable named-readtable-designators))
      (merge-into result-table table))
    result-table))
237
238
239
240
241
242

(defun list-all-named-readtables ()
  "Returns a list of all registered readtables. The returned list is
guaranteed to be fresh, but may contain duplicates."
  (mapcar #'ensure-readtable (%list-all-readtable-names)))

243

244
245
246
247
(deftype readtable-designator ()
  `(or null readtable))

(deftype named-readtable-designator ()
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
248
  "Either a symbol or a readtable itself."
249
  `(or readtable-designator symbol))
250

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
251
252
253
254
255
256

(define-condition readtable-error (error) ())

(define-condition readtable-does-not-exist (readtable-error)
  ((readtable-name :initarg :readtable-name 
	           :initform (required-argument)
257
258
259
260
261
	           :accessor missing-readtable-name
                   :type named-readtable-designatord))
  (:report (lambda (condition stream)
             (format stream "A readtable named ~S does not exist."
                     (missing-readtable-name condition)))))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
262
263

(define-condition readtable-does-already-exist (readtable-error)
264
265
266
267
  ((readtable-name :initarg :readtable-name
                   :initform (required-argument)
                   :accessor existing-readtable-name
                   :type named-readtable-designatord))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
268
269
  (:report (lambda (condition stream)
             (format stream "A readtable named ~S already exists."
270
                     (existing-readtable-name condition)))))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
271
272


273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
;;; up the perception of its existence by interning a copy of it.
;;;
;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
;;;
;;;   (equal (readtable-name (find-readtable :standard)) "STANDARD")
;;;
;;; holding true.
;;;
;;; We, however, inherit the restriction that the :STANDARD
;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
;;; technically be feasible (as *STANDARD-READTABLE* will contain a
;;; mutable copy of the implementation-internal standard readtable.)
;;; We cannot enforce this restriction without shadowing
;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
;;; is out of scope of this library, though. So we just threaten
;;; with nasal demons.
;;;
(defvar *standard-readtable* (%standard-readtable))
293

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
294
295
296
297
298
299
300
301
302
(defvar *empty-readtable*
  (let ((readtable (copy-readtable nil)))
    (do-readtable (char readtable)
      (set-syntax-from-char char #\A readtable (%standard-readtable)))
    ;; Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
    ;; readtable's dispatch table properly.
    #+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
    readtable))

303
304
305
306
307
308
309
310
311
312
313
314
(defun standard-macro-char-p (char rt)
  (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
    (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
      (and (eq rt-fn std-fn)
	   (eq rt-flag std-flag)))))

(defun standard-dispatch-macro-char-p (disp-char sub-char rt)
  (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
    (and (eq (non-terminating-p disp-char rt)
	     (non-terminating-p disp-char *standard-readtable*))
	 (eq (get-dispatch-macro-character disp-char sub-char rt)
	     (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
315

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
316
(defparameter *reserved-readtable-names* '(nil :standard :current :empty))
317
318

(defun reserved-readtable-name-p (name)
319
  (and (member name *reserved-readtable-names*) t))
320

321
322
323
;;; In principle, we could DEFREADTABLE :STANDARD. But we do reserved
;;; readtable lookup seperately, since we can't register a readtable
;;; for :CURRENT anyway.
324
325

(defun find-reserved-readtable (reserved-name)
326
327
  (cond ((eq reserved-name nil)       *standard-readtable*)
	((eq reserved-name :standard) *standard-readtable*)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
328
        ((eq reserved-name :empty)    *empty-readtable*)
329
	((eq reserved-name :current)  *readtable*)
330
	(t (error "Bug: no such reserved readtable: ~S" reserved-name))))
331
332

(defun find-readtable (named-readtable-designator)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
333
  "Looks for the readtable specified by `named-readtable-designator' and
334
335
336
337
338
339
returns it if it is found. Returns NIL otherwise."
  (check-type named-readtable-designator named-readtable-designator)
  (symbol-macrolet ((designator named-readtable-designator))
    (cond ((readtablep designator) designator)
	  ((reserved-readtable-name-p designator)
	   (find-reserved-readtable designator))
340
	  ((%find-readtable designator)))))
341
342
343
344
345
346
347

;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
;;; macros below.)
(defsetf find-readtable register-readtable)

(defun ensure-readtable (named-readtable-designator &optional (default nil default-p))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
348
349
350
351
352
  "Looks up the readtable specified by `named-readtable-designator' and
returns it if it is found.  If it is not found, it registers the readtable
designated by `default' under the name represented by
`named-readtable-designator'. If no default argument is given, an error is
signalled in this case."
353
354
355
  (symbol-macrolet ((designator named-readtable-designator))
    (cond ((find-readtable designator))
	  ((not default-p)
356
	   (error 'readtable-does-not-exist :readtable-name designator))
357
358
	  (t (setf (find-readtable designator) (ensure-readtable default))))))

359

360
(defun register-readtable (name read-table)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
361
  "Associate `read-table' with `name'."
362
  (check-type name symbol)
363
  (check-type read-table readtable)
364
  (check-type name (not (satisfies reserved-readtable-name-p)))
365
366
  (%associate-readtable-with-name name read-table)
  (%associate-name-with-readtable name read-table)
367
368
369
  read-table)

(defun unregister-readtable (named-readtable-designator)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
370
371
  "Remove the association of `named-readtable-designator'. Returns T if
successfull, NIL otherwise."
372
373
374
375
376
377
  (let* ((read-table (ensure-readtable named-readtable-designator))
	 (read-table-name (readtable-name read-table)))
    (if (not read-table-name)
	nil
	(prog1 t
	  (check-type read-table-name (not (satisfies reserved-readtable-name-p)))
378
379
            (%unassociate-readtable-from-name read-table-name read-table)
            (%unassociate-name-from-readtable read-table-name read-table)))))
380
381

(defun readtable-name (named-readtable-designator)
382
  "Returns the name of the readtable designated by
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
383
`named-readtable-designator', or NIL."
384
385
  (check-type named-readtable-designator named-readtable-designator)
  (let ((read-table (ensure-readtable named-readtable-designator)))
386
    (cond ((%readtable-name read-table))
387
          ((eq read-table *readtable*)          :current)
388
	  ((eq read-table *standard-readtable*) :standard)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
389
          ((eq read-table *empty-readtable*)    :empty)
390
	  (t nil))))
391
392
393
394
395
396
397
398
399
400
401
402
403


;;;;; Compiler macros

;;; Since the :STANDARD read-table is interned, and we can't enforce
;;; its immutability, we signal a style-warning for suspicious uses
;;; that may result in strange behaviour:

;;; Modifying the standard readtable would, obviously, lead to a
;;; propagation of this change to all places which use the :STANDARD
;;; readtable (and thus rendering this readtable to be non-standard,
;;; in fact.)

404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

(defun constant-standard-readtable-expression-p (thing)
  (cond ((symbolp thing) (or (eq thing 'nil) (eq thing :standard)))
	((consp thing)   (some (lambda (x) (equal thing x))
			       '((find-readtable nil)
				 (find-readtable :standard)
				 (ensure-readtable nil)
				 (ensure-readtable :standard))))
	(t nil)))

(defun signal-suspicious-registration-warning (name-expr read-table-expr)
  (simple-style-warn
   "Caution: ~<You're trying to register the :STANDARD readtable ~
    under a new name ~S. As modification of the :STANDARD readtable ~
    is not permitted, subsequent modification of ~S won't be ~
    permitted either. You probably want to wrap COPY-READTABLE ~
    around~@:>~%             ~S"
   (list name-expr name-expr) read-table-expr))
422

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
(let ()
  ;; Defer to runtime because compiler-macros are made available already
  ;; at compilation time. So without this two subsequent invocations of
  ;; COMPILE-FILE on this file would result in an undefined function
  ;; error because the two above functions are not yet available.
  ;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1;
  ;; cf. last example in CLHS "EVAL-WHEN" entry.)
  
  (define-compiler-macro register-readtable (&whole form name read-table)
    (when (constant-standard-readtable-expression-p read-table)
      (signal-suspicious-registration-warning name read-table))
    form)

  (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p))
    (when (and default-p (constant-standard-readtable-expression-p default))
      (signal-suspicious-registration-warning name default))
    form))
440
441