named-readtables.lisp 17.6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

;;; Copyright (c) 2007, Tobias C. Rittweiler <tcr@freebits.de>,
;;;                     Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions are met:
;;;     * Redistributions of source code must retain the above copyright
;;;       notice, this list of conditions and the following disclaimer.
;;;     * Redistributions in binary form must reproduce the above copyright
;;;       notice, this list of conditions and the following disclaimer in the
;;;       documentation and/or other materials provided with the distribution.
;;;     * Neither the names of Tobias C. Rittweiler, Robert P. Goldman, SIFT, LLC nor the
;;;       names of its contributors may be used to endorse or promote products
;;;       derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
;;; P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
;;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
;;; P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
;;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(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)
;;;


41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
;;; 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
;;;
;;;    * Revamp cruft.lisp, introduce DEFINTERFACE, DEFIMPLEMENTATION
;;;
;;;    * Think about MAKE-DISPATCHING-MACRO-CHARACTER in DEFREADTABLE


57
58
;;;;;; DEFREADTABLE &c.

59
(defmacro defreadtable (name &body options)
60
  "Define a new named readtable, whose name is given by the symbol NAME.
61
62
63
64
Or, if a readtable is already registered under that name, redefines that one.

The readtable can be populated using the OPTIONS &rest argument, as follows:

65
  (:MERGE &REST READTABLE-DESIGNATORS) -- merge the readtables designated into
66
      the new readtable, using MERGE-READTABLES-INTO.  It is mandatory to supply
67
      at least one :MERGE option naming a readtable to incorporate.
68
 
69
      DEFREADTABLE accepts some special readtable designators, including
70
      NIL or :STANDARD for the standard readtable and :CURRENT for the current
71
72
      readtable, as well as the names of programmer-defined readtables.

73
      Note that the process of merging readtables is _not_ commutative, so that
74
      macros in later entries will overwrite earlier ones, left to right in a single
75
      :MERGE directive, and one after another across multiple :MERGE directives.
76

77
  (:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION) -- define a new
78
79
      dispatch macro character in the readtable, per SET-DISPATCH-MACRO-CHARACTER.

80
  (:MACRO-CHAR MACRO-CHAR FUNCTION &OPTIONAL NON-TERMINATING-P) -- define a 
81
82
83
      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.
84

85
  (:CASE CASE-MODE) -- defines the /case sensititivy mode/ of the resulting
86
87
88
89
90
91
      readtable.

  Any number of option clauses may appear.  The :merge directives are evaluated first,
then the :case directives are evaluated in the order they appear. At last the local
macro definitions in :dispatch-macro-char and :macro-char are evaluated in the order
they appear."
92
93
  (check-type name symbol)
  (when (reserved-readtable-name-p name)
94
    (error "~A is the designator for a predefined readtable. ~
95
            Not acceptable as a user-specified readtable name." name))
96
97
98
  (flet ((process-option (option var)
           (destructure-case option
             ((:merge &rest readtable-designators)
99
	      `(merge-readtables-into ,var ,@readtable-designators))
100
101
102
             ((: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)
103
104
105
106
107
108
	      (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)))
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
	     ((:case mode)
	      `(setf (readtable-case ,var) ,mode))))
	 (member-of (&rest rest) #'(lambda (x) (member x rest))))
    (let* ((merge-clauses (remove-if-not (member-of :merge) options :key #'first))
	   (case-clauses  (remove-if-not (member-of :case)  options :key #'first))
	   (macro-clauses (remove-if-not (member-of :macro-char
						    :dispatch-macro-char) options
					 :key #'first))
	   (other-clauses (set-difference options (append merge-clauses case-clauses macro-clauses))))
      (cond ((null merge-clauses)
	     (error "Not at least one (:merge ...) clause given in DEFREADTABLE form."))
	    ((not (null other-clauses))
	     (error "Bogus DEFREADTABLE clauses: ~{~A~^, ~}" other-clauses))
	    (t
	     `(eval-when (:compile-toplevel :load-toplevel :execute)
		;; The (FIND-READTABLE ...) is important for proper redefinition semantics.
125
126
		(let ((readtable (find-readtable ',name)))
		  (if readtable
127
		      (simple-style-warn "redefining ~A in DEFREADTABLE" ',name)
128
		      (setq readtable
129
			    (make-readtable ',name
130
131
132
133
134
					    ;; We have to provide an explicit :MERGE argument,
					    ;; because otherwise the :STANDARD readtable would
					    ;; be used which is not necessarily what we want.
					    :merge ',(rest (first merge-clauses)))))
		  ;; We have to grovel all MERGE-CLAUSES for the redefinition case.
135
		  ,@(loop for option in merge-clauses
136
			  collect (process-option option 'readtable))
137
		  ,@(loop for option in case-clauses
138
			  collect (process-option option 'readtable))
139
		  ,@(loop for option in macro-clauses
140
141
			  collect (process-option option 'readtable))
		  readtable)))))))
142

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
;;; 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)
  (let ((readtable-alist (find-symbol "*READTABLE-ALIST*" (find-package "SWANK"))))
    (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)))))))))

158
159
160
161
(defmacro in-readtable (name)
  "Bind the *readtable* to the readtable referred to by NAME, raising
an error if no such readtable can be found."
  (check-type name symbol)
162
  `(eval-when (:compile-toplevel :load-toplevel :execute)
163
164
165
166
     (setf *readtable* (ensure-readtable ',name))
     (when (find-package "SWANK")
       (%frob-swank-readtable-alist *package* *readtable*))
     ))
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
(defun make-readtable (name &key merge)
  "Makes and returns a new readtable under the specified NAME. The
keyarg :MERGE takes a list of named-readtable-designators and specifies
the readtables the new readtable is created from. (See the :MERGE
clauses of DEFREADTABLE for details.) If :MERGE wasn't given (or NIL),
the :STANDARD readtable is used instead."
  (let ((merge-list (or merge '(:standard))))
    (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))
	  ((and (find-readtable name)
		(cerror "Overwrite existing readtable."
			"A readtable named ~S already exists." name)))
182
	  (t (let ((result (apply #'merge-readtables-into
183
184
185
186
187
188
189
				  ;; 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))))))

190
(defun rename-readtable (named-readtable-designator new-name)
191
  "Replaces the associated name of the readtable designated by
192
193
NAMED-READTABLE-DESIGNATOR with NEW-NAME If a readtable is already
registered under the new name, an error is raised."
194
  (check-type named-readtable-designator named-readtable-designator)
195
196
197
  (check-type new-name symbol)
  (when (find-readtable new-name)
    (error "A readtable named ~S already exists." new-name))
198
199
200
201
202
203
  (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.
    (%unregister-readtable-name read-table)
    (%unregister-readtable read-table-name)
204
205
    (%register-readtable-name new-name read-table)
    (%register-readtable new-name read-table)
206
207
    read-table))

208
(defun merge-readtables-into (result-table &rest named-readtable-designators)
209
210
211
212
213
  "Copy the contents of each readtable in NAMED-READTABLE-DESIGNATORS,
in turn, into RESULT-TABLE.  Because the readtables are merged in
turn, macro definitions in readtables later in the list will overwrite
definitions in readtables listed earlier.  Notice that the /readtable
case/ is also subject of the merge operation."
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
  (flet ((merge-into (rt1 rt2)
	   (%with-readtable-iterator (rt2-iter rt2)
	     (loop
	      (multiple-value-bind (more? char reader-fn disp? table) (rt2-iter)
		(unless more? (return))
		(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)))))))
	   rt1))
    (setf result-table (ensure-readtable result-table))
    (dolist (table (mapcar #'ensure-readtable named-readtable-designators))
      (merge-into result-table table))
    result-table))
231
232
233
234
235
236

(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)))

237

238
239
240
241
(deftype readtable-designator ()
  `(or null readtable))

(deftype named-readtable-designator ()
242
  `(or readtable-designator symbol))
243

244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
;;; 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))
264
265
266
267
268
269
270
271
272
273
274
275
276

(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*)))))
277
278
279
280

(defparameter *reserved-readtable-names* '(nil :standard :current))

(defun reserved-readtable-name-p (name)
281
  (and (member name *reserved-readtable-names*) t))
282

283
284
285
;;; In principle, we could DEFREADTABLE :STANDARD. But we do reserved
;;; readtable lookup seperately, since we can't register a readtable
;;; for :CURRENT anyway.
286
287

(defun find-reserved-readtable (reserved-name)
288
289
290
  (cond ((eq reserved-name nil)       *standard-readtable*)
	((eq reserved-name :standard) *standard-readtable*)
	((eq reserved-name :current)  *readtable*)
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
	(t (error "No such reserved readtable: ~S" reserved-name))))

(defun find-readtable (named-readtable-designator)
  "Looks for the readtable specified by NAMED-READTABLE-DESIGNATOR and 
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))
	  ((%find-readtable-from-name designator)))))

;;; 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))
  "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 was given, an error
is signalled."
  (symbol-macrolet ((designator named-readtable-designator))
    (cond ((find-readtable designator))
	  ((not default-p)
	   (error "The name ~S does not designate any readtable." designator))
	  (t (setf (find-readtable designator) (ensure-readtable default))))))

320

321
322
323
(defun register-readtable (name read-table)
  "Associate READ-TABLE as the readtable associated with NAME."
  (check-type name symbol)
324
  (check-type read-table readtable)
325
326
327
  (check-type name (not (satisfies reserved-readtable-name-p)))
  (%register-readtable-name name read-table)
  (%register-readtable name read-table)
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
  read-table)

(defun unregister-readtable (named-readtable-designator)
  "Remove the readtable association of NAMED-READTABLE-DESIGNATOR.
Returns T if successfull, NIL otherwise."
  (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)))
	  (%unregister-readtable-name read-table)
	  (%unregister-readtable read-table-name)))))

(defun readtable-name (named-readtable-designator)
343
  "Returns the name of the readtable designated by
344
345
346
NAMED-READTABLE-DESIGNATOR or NIL."
  (check-type named-readtable-designator named-readtable-designator)
  (let ((read-table (ensure-readtable named-readtable-designator)))
347
348
    (cond ((eq read-table *readtable*)          :current)
	  ((eq read-table *standard-readtable*) :standard)
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
	  (t (%readtable-name read-table)))))


;;;;; 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.)

(define-condition simple-style-warning (style-warning simple-warning)
  ())

366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
(defun simple-style-warn (format-control &rest format-args)
  (warn 'simple-style-warning
	 :format-control format-control
	 :format-arguments format-args))

(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))
388
389
390
391
392
393
394
395
396
397
398
399

(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)