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
192 193 194 195 196 197 198
readtables the new readtable is created from. (See the :MERGE clause
of DEFREADTABLE for details.) If `merge' is NIL, an empty readtable is
used instead.

An empty readtable is a readtable where the character syntax of each
character is like in the /standard readtable/ except that each
standard macro character has been made a constituent."
199 200 201
  (cond ((not name-supplied-p)
         (copy-readtable *empty-readtable*))
        ((reserved-readtable-name-p name)
202
         (error "~A is the designator for a predefined readtable. ~
203
                   Not acceptable as a user-specified readtable name." name))
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
        ((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))))
219
               
220
             (register-readtable name result)))))
221

222
(define-api rename-readtable
223
    (old-name new-name)
224
    (named-readtable-designator symbol => readtable)
225 226 227
  "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."
228
  (when (find-readtable new-name)
229
    (cerror "Overwrite existing entry." 
230
            'readtable-does-already-exist :readtable-name new-name))
231
  (let* ((readtable (ensure-readtable old-name))
232
	 (readtable-name (readtable-name readtable)))
233 234
    ;; We use the internal functions directly to omit repeated
    ;; type-checking.
235 236 237 238 239
    (%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))
240

241
(define-api merge-readtables-into
242
    (result-readtable &rest named-readtables)
243
    (named-readtable-designator &rest named-readtable-designator => readtable)
244 245
  "Copy the contents of each readtable in `named-readtables' into
`result-table'.
246 247 248 249 250

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)
251 252 253 254 255 256 257 258 259
	   (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
                      (check-reader-macro-conflict from to char subchar)
                      (set-dispatch-macro-character char subchar subfn to)))))
260
	   to))
261
    (let ((result-table (ensure-readtable result-readtable)))
262
      (dolist (table (mapcar #'ensure-readtable named-readtables))
263 264
        (merge-into result-table table))
      result-table)))
265

266 267 268 269
(defun ensure-dispatch-macro-character (char &optional non-terminating-p
                                                       (readtable *readtable*))
  (unless (dispatch-macro-char-p char readtable)
    (make-dispatch-macro-character char non-terminating-p readtable)))
270

271
(define-api copy-named-readtable
272
    (named-readtable)
273
    (named-readtable-designator => readtable)
274
  "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
275
  (copy-readtable (ensure-readtable named-readtable)))
276

277
(define-api list-all-named-readtables () (=> list)
278 279 280 281
  "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)))

282

Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
283 284 285 286 287
(define-condition readtable-error (error) ())

(define-condition readtable-does-not-exist (readtable-error)
  ((readtable-name :initarg :readtable-name 
	           :initform (required-argument)
288
	           :accessor missing-readtable-name
289
                   :type named-readtable-designator))
290 291 292
  (: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
293 294

(define-condition readtable-does-already-exist (readtable-error)
295 296 297
  ((readtable-name :initarg :readtable-name
                   :initform (required-argument)
                   :accessor existing-readtable-name
298
                   :type named-readtable-designator))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
299 300
  (:report (lambda (condition stream)
             (format stream "A readtable named ~S already exists."
301 302
                     (existing-readtable-name condition))))
  (:documentation "Continuable."))
Tobias C. Rittweiler's avatar
Tobias C. Rittweiler committed
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
(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,
340
and b) if and only if the two respective reader macro functions differ."))
341

342

343 344
(defun check-reader-macro-conflict (from to char &optional subchar)
  (flet ((conflictp (from-fn to-fn)
345
           (and to-fn (not (function= to-fn from-fn)))))
346
    (when (if subchar
347 348
              (conflictp (safe-get-dispatch-macro-character char subchar from)
                         (safe-get-dispatch-macro-character char subchar to))
349 350 351 352 353 354 355 356 357
              (conflictp (get-macro-character char from)
                         (get-macro-character char to)))
      (cerror (format nil "Overwrite ~@C in ~A." char to)
              'reader-macro-conflict
              :from-readtable from
              :to-readtable to
              :macro-char char
              :sub-char subchar))))

358 359 360 361 362 363 364
;;; See Ticket 601. This is supposed to be removed at some point in
;;; the future.
(defun safe-get-dispatch-macro-character (char subchar rt)
  #+ccl (ignore-errors
         (get-dispatch-macro-character char subchar rt))
  #-ccl (get-dispatch-macro-character char subchar rt))

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