named-readtables.lisp 21.5 KB
Newer Older
1
;;;; -*- Mode:Lisp -*-
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
2 3 4 5 6 7 8 9
;;;;
;;;; 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.
;;;;
10 11 12 13 14 15 16 17 18 19 20 21

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

22
(defmacro defreadtable (name &body options)
23 24 25
  "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.
26

27
The readtable can be populated using the following `options':
28

29
  (:MERGE `readtable-designators'+)
30

31 32 33
      Merge the readtables designated into the new readtable being defined
      as per MERGE-READTABLES-INTO.

34 35 36
      If no :MERGE clause is given, an empty readtable is used. See
      MAKE-READTABLE.

37 38 39 40 41 42 43 44 45
  (:FUZE `readtable-designators'+)

      Like :MERGE except:

      Error conditions of type READER-MACRO-CONFLICT that are signaled
      during the merge operation will be silently _continued_. It follows
      that reader macros in earlier entries will be overwritten by later
      ones.

46
  (:DISPATCH-MACRO-CHAR `macro-char' `sub-char' `function')
47

48 49 50 51
      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.
52

53
  (:MACRO-CHAR `macro-char' `function' [`non-terminating-p'])
54

55
      Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
56 57
      If `function' is the keyword :DISPATCH, `macro-char' is made a
      dispatching macro character, per MAKE-DISPATCH-MACRO-CHARACTER.
58

59
  (:SYNTAX-FROM `from-readtable-designator' `from-char' `to-char')
60

61 62
      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.
63

64
  (:CASE `case-mode') 
65

66
      Defines the /case sensitivity mode/ of the resulting readtable.
67

68
Any number of option clauses may appear. The options are grouped by their
69 70
type, but in each group the order the options appeared textually is
preserved.  The following groups exist and are executed in the following
71 72
order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR
and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM.
73

74 75 76 77 78 79 80
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.

81 82 83
  On redefinition, the target readtable is made empty first before it's
  refilled according to the clauses.

84 85
  NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
  preregistered readtable names.
86
"
87 88
  (check-type name symbol)
  (when (reserved-readtable-name-p name)
89
    (error "~A is the designator for a predefined readtable. ~
90
            Not acceptable as a user-specified readtable name." name))
91 92 93
  (flet ((process-option (option var)
           (destructure-case option
             ((:merge &rest readtable-designators)
94 95
	      `(merge-readtables-into ,var
                 ,@(mapcar #'(lambda (x) `',x) readtable-designators))) ; quotify
96 97 98 99
             ((:fuze &rest readtable-designators)
	      `(handler-bind ((reader-macro-conflict #'continue))
                 (merge-readtables-into ,var
                   ,@(mapcar #'(lambda (x) `',x) 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
	      (if (eq function :dispatch)
		  `(make-dispatch-macro-character ,char ,non-terminating-p ,var)
		  `(set-macro-character ,char ,function ,non-terminating-p ,var)))
106 107 108
	     ((:syntax-from from-rt-designator from-char to-char)
	      `(set-syntax-from-char ,to-char ,from-char 
				     ,var (find-readtable ,from-rt-designator)))
109 110
	     ((:case mode)
	      `(setf (readtable-case ,var) ,mode))))
111 112 113 114
	 (remove-clauses (clauses options)
	   (setq clauses (if (listp clauses) clauses (list clauses)))
	   (remove-if-not #'(lambda (x) (member x clauses)) 
			  options :key #'first)))
115
    (let* ((merge-clauses  (remove-clauses '(:merge :fuze) options))
116 117 118 119 120 121 122 123 124
	   (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))
125
	 (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
126 127
	(t
	 `(eval-when (:load-toplevel :execute)
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
            ;; The (FIND-READTABLE ...) isqrt important for proper
            ;; redefinition semantics, as redefining has to modify the
            ;; already existing readtable object.
            (let ((readtable (find-readtable ',name)))
              (cond ((not readtable)
                     (setq readtable (make-readtable ',name)))
                    (t
                     (setq readtable (%clear-readtable readtable))
                     (simple-style-warn "Overwriting already existing readtable ~S."
                                        readtable)))
              ,@(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)))))))
147 148

(defmacro in-readtable (name)
149
  "Set *READTABLE* to the readtable referred to by the symbol `name'."
150 151
  (check-type name symbol)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
152 153
     ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
     ;; (GET-MACRO-CHARACTER #\"))
154 155 156 157
     (setf *readtable* (ensure-readtable ',name))
     (when (find-package :swank)
       (%frob-swank-readtable-alist *package* *readtable*))
     ))
158

159 160
;;; KLUDGE: [interim solution]
;;;
161 162 163 164
;;;   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
165 166
  (let ((readtable-alist (find-symbol (string '#:*readtable-alist*) 
				      (find-package :swank))))
167 168 169 170 171 172 173 174
    (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)))))))))
175 176 177 178 179 180 181

(deftype readtable-designator ()
  `(or null readtable))

(deftype named-readtable-designator ()
  "Either a symbol or a readtable itself."
  `(or readtable-designator symbol))
182

183

184 185
(declaim (special *standard-readtable* *empty-readtable*))

186
(define-api make-readtable
187 188
    (&optional (name nil name-supplied-p) &key merge)
    (&optional named-readtable-designator &key (:merge list) => readtable)
189 190 191
  "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
192 193
readtables the new readtable is created from. (See the :MERGE clause of
DEFREADTABLE for details.)
194

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
195 196 197 198 199 200 201 202 203 204
If `merge' is NIL, an empty readtable is used instead.

If `name' is not given, an anonymous empty readtable is returned.

Notes:

  An empty readtable is a readtable where each character's syntax is the
  same as in the /standard readtable/ except that each macro character has
  been made a constituent. Basically: whitespace stays whitespace,
  everything else is constituent."
205 206 207
  (cond ((not name-supplied-p)
         (copy-readtable *empty-readtable*))
        ((reserved-readtable-name-p name)
208
         (error "~A is the designator for a predefined readtable. ~
209
                   Not acceptable as a user-specified readtable name." name))
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
        ((let ((rt (find-readtable name)))
           (and rt (prog1 nil
                     (cerror "Overwrite existing entry." 
                             'readtable-does-already-exist :readtable-name name)
                     ;; Explicitly unregister to make sure that we do not hold on
                     ;; of any reference to RT.
                     (unregister-readtable rt)))))
        (t (let ((result (apply #'merge-readtables-into
                                ;; 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 (if merge
                                                    (ensure-readtable (first merge))
                                                    *empty-readtable*))
                                (rest merge))))
225
               
226
             (register-readtable name result)))))
227

228
(define-api rename-readtable
229
    (old-name new-name)
230
    (named-readtable-designator symbol => readtable)
231 232 233
  "Replaces the associated name of the readtable designated by `old-name'
with `new-name'. If a readtable is already registered under `new-name', an
error of type READTABLE-DOES-ALREADY-EXIST is signaled."
234
  (when (find-readtable new-name)
235
    (cerror "Overwrite existing entry." 
236
            'readtable-does-already-exist :readtable-name new-name))
237
  (let* ((readtable (ensure-readtable old-name))
238
	 (readtable-name (readtable-name readtable)))
239 240
    ;; We use the internal functions directly to omit repeated
    ;; type-checking.
241 242 243 244 245
    (%unassociate-name-from-readtable readtable-name readtable)
    (%unassociate-readtable-from-name readtable-name readtable)
    (%associate-name-with-readtable new-name readtable)
    (%associate-readtable-with-name new-name readtable)
    readtable))
246

247
(define-api merge-readtables-into
248
    (result-readtable &rest named-readtables)
249
    (named-readtable-designator &rest named-readtable-designator => readtable)
250 251
  "Copy the contents of each readtable in `named-readtables' into
`result-table'.
252 253 254 255 256

If a macro character appears in more than one of the readtables, i.e. if a
conflict is discovered during the merge, an error of type
READER-MACRO-CONFLICT is signaled."
  (flet ((merge-into (to from)
257 258 259 260 261 262 263
	   (do-readtable ((char reader-fn non-terminating-p disp? table) from)
             (check-reader-macro-conflict from to char)
             (cond ((not disp?)
                    (set-macro-character char reader-fn non-terminating-p to))
                   (t
                    (ensure-dispatch-macro-character char non-terminating-p to)
                    (loop for (subchar . subfn) in table do
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
264 265
                          (check-reader-macro-conflict from to char subchar)
                          (set-dispatch-macro-character char subchar subfn to)))))
266
	   to))
267
    (let ((result-table (ensure-readtable result-readtable)))
268
      (dolist (table (mapcar #'ensure-readtable named-readtables))
269 270
        (merge-into result-table table))
      result-table)))
271

272 273
(defun ensure-dispatch-macro-character (char &optional non-terminating-p
                                                       (readtable *readtable*))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
274 275 276
  (if (dispatch-macro-char-p char readtable)
      t
      (make-dispatch-macro-character char non-terminating-p readtable)))
277

278
(define-api copy-named-readtable
279
    (named-readtable)
280
    (named-readtable-designator => readtable)
281
  "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
282
  (copy-readtable (ensure-readtable named-readtable)))
283

284
(define-api list-all-named-readtables () (=> list)
285 286 287 288
  "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)))

289

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
290 291 292 293 294
(define-condition readtable-error (error) ())

(define-condition readtable-does-not-exist (readtable-error)
  ((readtable-name :initarg :readtable-name 
	           :initform (required-argument)
295
	           :accessor missing-readtable-name
296
                   :type named-readtable-designator))
297 298 299
  (: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
300 301

(define-condition readtable-does-already-exist (readtable-error)
302 303 304
  ((readtable-name :initarg :readtable-name
                   :initform (required-argument)
                   :accessor existing-readtable-name
305
                   :type named-readtable-designator))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
306 307
  (:report (lambda (condition stream)
             (format stream "A readtable named ~S already exists."
308 309
                     (existing-readtable-name condition))))
  (:documentation "Continuable."))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
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 341 342 343 344 345 346
(define-condition reader-macro-conflict (readtable-error)
  ((macro-char
    :initarg :macro-char
    :initform (required-argument)
    :accessor conflicting-macro-char
    :type character)
   (sub-char
    :initarg :sub-char
    :initform nil
    :accessor conflicting-dispatch-sub-char
    :type (or null character))
   (from-readtable
    :initarg :from-readtable
    :initform (required-argument)
    :accessor from-readtable
    :type readtable)
   (to-readtable
    :initarg :to-readtable
    :initform (required-argument)
    :accessor to-readtable
    :type readtable))
  (:report
   (lambda (condition stream)
     (format stream "~@<Reader macro conflict while trying to merge the ~
                        ~:[macro character~;dispatch macro characters~] ~
                        ~@C~@[ ~@C~] from ~A into ~A.~@:>"
             (conflicting-dispatch-sub-char condition)
             (conflicting-macro-char condition)
             (conflicting-dispatch-sub-char condition)
             (from-readtable condition)
             (to-readtable condition))))
  (:documentation "Continuable.

This condition is signaled during the merge process if a) a reader macro
\(be it a macro character or the sub character of a dispatch macro
character\) is both present in the source as well as the target readtable,
347
and b) if and only if the two respective reader macro functions differ."))
348 349 350

(defun check-reader-macro-conflict (from to char &optional subchar)
  (flet ((conflictp (from-fn to-fn)
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
351
           (assert from-fn) ; if this fails, there's a bug in readtable iterators.
352
           (and to-fn (not (function= to-fn from-fn)))))
353
    (when (if subchar
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
354 355 356 357
              (conflictp (%get-dispatch-macro-character char subchar from)
                         (%get-dispatch-macro-character char subchar to))
              (conflictp (%get-macro-character char from)
                         (%get-macro-character char to)))
358 359 360 361 362 363 364
      (cerror (format nil "Overwrite ~@C in ~A." char to)
              'reader-macro-conflict
              :from-readtable from
              :to-readtable to
              :macro-char char
              :sub-char subchar))))

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
365

366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384
;;; 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.
;;;
385 386
(defvar *standard-readtable*
  (%standard-readtable))
387

388
(defvar *empty-readtable*
389
  (%clear-readtable (copy-readtable nil)))
390

391 392 393 394 395 396 397
(defvar *case-preserving-standard-readtable*
  (let ((readtable (copy-readtable nil)))
    (setf (readtable-case readtable) :preserve)
    readtable))

(defparameter *reserved-readtable-names*
  '(nil :standard :common-lisp :modern :current))
398 399

(defun reserved-readtable-name-p (name)
400
  (and (member name *reserved-readtable-names*) t))
401

402 403 404
;;; In principle, we could DEFREADTABLE some of these. But we do
;;; reserved readtable lookup seperately, since we can't register a
;;; readtable for :CURRENT anyway.
405 406

(defun find-reserved-readtable (reserved-name)
407 408 409 410 411
  (cond ((eq reserved-name nil)          *standard-readtable*)
	((eq reserved-name :standard)    *standard-readtable*)
        ((eq reserved-name :common-lisp) *standard-readtable*)
        ((eq reserved-name :modern)      *case-preserving-standard-readtable*)
	((eq reserved-name :current)     *readtable*)
412
	(t (error "Bug: no such reserved readtable: ~S" reserved-name))))
413

414
(define-api find-readtable
415
    (name)
416
    (named-readtable-designator => (or readtable null))
417 418 419 420 421 422
  "Looks for the readtable specified by `name' and returns it if it is
found. Returns NIL otherwise."
  (cond ((readtablep name) name)
        ((reserved-readtable-name-p name)
         (find-reserved-readtable name))
        ((%find-readtable name))))
423 424 425 426 427 428

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

429
(define-api ensure-readtable
430
    (name &optional (default nil default-p))
431 432
    (named-readtable-designator &optional (or named-readtable-designator null)
      => readtable)
433 434 435 436 437 438 439 440
  "Looks up the readtable specified by `name' and returns it if it's found.
If it is not found, it registers the readtable designated by `default'
under the name represented by `name'; or if no default argument is given,
it signals an error of type READTABLE-DOES-NOT-EXIST instead."
  (cond ((find-readtable name))
        ((not default-p)
         (error 'readtable-does-not-exist :readtable-name name))
        (t (setf (find-readtable name) (ensure-readtable default)))))
441

442

443 444 445
(define-api register-readtable
    (name readtable)
    (symbol readtable => readtable)
446
  "Associate `readtable' with `name'. Returns the readtable."
447
  (assert (typep name '(not (satisfies reserved-readtable-name-p))))
448 449 450
  (%associate-readtable-with-name name readtable)
  (%associate-name-with-readtable name readtable)
  readtable)
451

452
(define-api unregister-readtable
453
    (named-readtable)
454
    (named-readtable-designator => boolean)
455 456 457
  "Remove the association of `named-readtable'. Returns T if successfull,
NIL otherwise."
  (let* ((readtable (find-readtable named-readtable))
458 459
	 (readtable-name (and readtable (readtable-name readtable))))
    (if (not readtable-name)
460 461
	nil
	(prog1 t
462 463 464
	  (check-type readtable-name (not (satisfies reserved-readtable-name-p)))
            (%unassociate-readtable-from-name readtable-name readtable)
            (%unassociate-name-from-readtable readtable-name readtable)))))
465

466
(define-api readtable-name
467
    (named-readtable)
468
    (named-readtable-designator => symbol)
469 470 471
  "Returns the name of the readtable designated by `named-readtable', or
NIL."
   (let ((readtable (ensure-readtable named-readtable)))
472 473 474 475
    (cond ((%readtable-name readtable))
          ((eq readtable *readtable*) :current)
	  ((eq readtable *standard-readtable*) :common-lisp)
          ((eq readtable *case-preserving-standard-readtable*) :modern)
476
	  (t nil))))
477 478 479 480


;;;;; Compiler macros

481
;;; Since the :STANDARD readtable is interned, and we can't enforce
482 483 484 485 486 487 488 489
;;; 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.)

490 491 492 493 494 495 496 497 498 499

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

500
(defun signal-suspicious-registration-warning (name-expr readtable-expr)
501 502 503 504 505 506
  (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"
507
   (list name-expr name-expr) readtable-expr))
508

509 510 511 512 513 514 515 516
(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.)
  
517 518 519
  (define-compiler-macro register-readtable (&whole form name readtable)
    (when (constant-standard-readtable-expression-p readtable)
      (signal-suspicious-registration-warning name readtable))
520 521 522 523 524 525
    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))
526 527