named-readtables.lisp 15.4 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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
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
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340

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


;;;;;; DEFREADTABLE &c.

(defmacro defreadtable (string-designator &rest options)
  "Define a new named readtable, whose name is given by STRING-DESIGNATOR.
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:

  (:merge &rest readtable-designators) -- merge the readtables designated into
      the new readtable, using merge-readtables.  It is mandatory to supply 
      at least one :merge option naming a readtable to incorporate.
 
      Defreadtable accepts some special readtable designators, including
      NIL or :standard for the standard readtable and :current for the current
      readtable, as well as the names of programmer-defined readtables.

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

  (:dispatch-macro-char macro-char sub-char function) -- define a new
      dispatch macro character in the readtable, per SET-DISPATCH-MACRO-CHARACTER.

  (:macro-char macro-char function &optional non-terminating-p) -- define a 
      new macro character in the readtable, per SET-MACRO-CHARACTER.

  (:case case-mode) -- defines the /case sensititivy mode/ of the resulting
      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."
  (check-type string-designator string-designator)
  (when (reserved-readtable-name-p string-designator)
    (error "~A is the designator for a predefined readtable. ~
            Not acceptable as a user-specified readtable name." string-designator))
  (flet ((process-option (option var)
           (destructure-case option
             ((:merge &rest readtable-designators)
	      `(setf ,var (merge-readtables ,var ,@readtable-designators)))
             ((: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)
              `(set-macro-character ,char ,function ,non-terminating-p ,var))
	     ((: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.
		(let ((read-table (or (find-readtable ,string-designator)
				      (make-readtable ,string-designator
						      :merge ',(rest (first merge-clauses))))))
		  ;; We traverse all merge-clauses (i.e. not just (REST MERGE-CLAUSES))
		  ;; for the case when (FIND-READTABLE ...) was non-NIL.
		  ,@(loop for option in merge-clauses
			  collect (process-option option 'read-table))
		  ,@(loop for option in case-clauses
			  collect (process-option option 'read-table))
		  ,@(loop for option in macro-clauses
			  collect (process-option option 'read-table))
		  read-table)))))))

(defmacro in-readtable (string-designator)
  "Bind the *readtable* to the readtable referred to by
STRING-DESIGNATOR, raising an error if no such readtable can
be found."
  (check-type string-designator string-designator)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf *readtable* (ensure-readtable ,string-designator))))

(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)))
	  (t (let ((result (apply #'merge-readtables
				  ;; 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))))))

(defun rename-readtable (named-readtable-designator string-designator)
  "Replaces the associated name of the readtable designated by
NAMED-READTABLE-DESIGNATOR with STRING-DESIGNATOR. If a readtable is
already registered under the new name, an error is raised."
  (check-type named-readtable-designator named-readtable-designator)
  (check-type string-designator string-designator)
  (when (find-readtable string-designator)
    (error "A readtable named ~S already exists." string-designator))
  (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)
    (%register-readtable-name string-designator read-table)
    (%register-readtable string-designator read-table)
    read-table))


;;; FIXME: This is completely not working as it's supposed to be. I
;;; assumed semantics of CL:COPY-READTABLE that don't exist.
(defun merge-readtables (result-table &rest named-readtable-designators)
  "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."
  (setf result-table (ensure-readtable result-table))
  (dolist (table (mapcar #'ensure-readtable named-readtable-designators))
    (setf result-table (copy-readtable table result-table)))
  result-table)

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



(deftype string-designator ()
  `(or string symbol character))

(deftype readtable-designator ()
  `(or null readtable))

(deftype named-readtable-designator ()
  `(or readtable-designator string-designator))

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;;; 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* (copy-readtable nil)))

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

(defun reserved-readtable-name-p (name)
  (and (member (string name) *reserved-readtable-names*
	       :test #'string= :key #'symbol-name)
       t))

;;; We must do reserved readtable lookup seperately, since we can't
;;; integrate it fully into the registration scheme anyway because of
;;; :CURRENT. So we just do it completely seperately.

(defun find-reserved-readtable (reserved-name)
  (cond ((string= reserved-name nil)       *standard-readtable*)
	((string= reserved-name :standard) *standard-readtable*)
	((string= reserved-name :current)  *readtable*)
	(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))))))



(defun register-readtable (string-designator read-table)
  "Associate READ-TABLE as the readtable associated with STRING-DESIGNATOR."
  (check-type string-designator string-designator)
  (check-type read-table readtable)
  (check-type string-designator (not (satisfies reserved-readtable-name-p)))
  (%register-readtable-name string-designator read-table)
  (%register-readtable string-designator read-table)
  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)
  "Returns the name (as string) of the readtable designated by
NAMED-READTABLE-DESIGNATOR or NIL."
  (check-type named-readtable-designator named-readtable-designator)
  (let ((read-table (ensure-readtable named-readtable-designator)))
    (cond ((eq read-table *readtable*)          "CURRENT")
	  ((eq read-table *standard-readtable*) "STANDARD")
	  (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)
  ())

(eval-when (:compile-toplevel :load-toplevel :execute)
  (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))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun signal-suspicious-registration-warning (name-expr read-table-expr)
    (warn 'simple-style-warning
	  :format-control
	  "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"
	  :format-arguments `((,name-expr ,name-expr) ,read-table-expr))))

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



;;;;; Internal implementation