;;;; -*- Mode:Lisp -*- ;;;; ;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler ;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC ;;;; ;;;; All rights reserved. ;;;; ;;;; See LICENSE for details. ;;;; (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 (name &body options) "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. The readtable can be populated using the following OPTIONS: - `(:MERGE READTABLE-DESIGNATORS+)` Merge the readtables designated into the new readtable being defined as per MERGE-READTABLES-INTO. If no :MERGE clause is given, an empty readtable is used. See MAKE-READTABLE. - `(:FUSE 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. For backward compatibility, :FUZE is accepted as an alias of :FUSE. - `(:DISPATCH-MACRO-CHAR MACRO-CHAR SUB-CHAR FUNCTION)` 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. - `(:MACRO-CHAR MACRO-CHAR FUNCTION [NON-TERMINATING-P])` 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. - `(:SYNTAX-FROM FROM-READTABLE-DESIGNATOR FROM-CHAR TO-CHAR)` 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. - `(:CASE CASE-MODE)` Defines the _case sensitivity mode_ of the resulting readtable. Any number of option clauses may appear. The options are grouped by their 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 and :FUSE (one group), :CASE, :MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM. 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. On redefinition, the target readtable is made empty first before it's refilled according to the clauses. NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are preregistered readtable names." (check-type name symbol) (when (reserved-readtable-name-p name) (error "~A is the designator for a predefined readtable. ~ Not acceptable as a user-specified readtable name." name)) (flet ((process-option (option var) (destructure-case option ((:merge &rest readtable-designators) `(merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) readtable-designators))) ((:fuse &rest readtable-designators) `(handler-bind ((reader-macro-conflict #'continue)) (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) readtable-designators)))) ;; alias for :FUSE ((:fuze &rest readtable-designators) `(handler-bind ((reader-macro-conflict #'continue)) (merge-readtables-into ,var ,@(mapcar #'(lambda (x) `',x) 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) (if (eq function :dispatch) `(make-dispatch-macro-character ,char ,non-terminating-p ,var) `(set-macro-character ,char ,function ,non-terminating-p ,var))) ((:syntax-from from-rt-designator from-char to-char) `(set-syntax-from-char ,to-char ,from-char ,var (find-readtable ,from-rt-designator))) ((:case mode) `(setf (readtable-case ,var) ,mode)))) (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 :fuze :fuse) 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)) (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses)) (t `(eval-when (:load-toplevel :execute) ;; 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))))))) (defmacro in-readtable (name) "Set *READTABLE* to the readtable referred to by the symbol NAME." (check-type name symbol) `(eval-when (:compile-toplevel :load-toplevel :execute) ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO* ;; (GET-MACRO-CHARACTER #\")) (setf *readtable* (ensure-readtable ',name)) (when (find-package :swank) (%frob-swank-readtable-alist *package* *readtable*)))) ;;; KLUDGE: [interim solution] ;;; ;;; 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 (string '#:*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))))))))) (deftype readtable-designator () `(or null readtable)) (deftype named-readtable-designator () "Either a symbol or a readtable itself." `(or readtable-designator symbol)) ;;;;; Compiler macros ;;; Since the :STANDARD readtable 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.) (eval-when (:compile-toplevel :load-toplevel :execute) (defun constant-standard-readtable-expression-p (thing) (or (null thing) (eq thing :standard) (and (consp thing) (find thing '((find-readtable nil) (find-readtable :standard) (ensure-readtable nil) (ensure-readtable :standard)) :test #'equal)))) (defun signal-suspicious-registration-warning (name-expr readtable-expr) (when (constant-standard-readtable-expression-p readtable-expr) (simple-style-warn "Caution: ~~% ~S" (list name-expr name-expr) readtable-expr)))) (define-compiler-macro register-readtable (&whole form name readtable) (signal-suspicious-registration-warning name readtable) form) (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p)) (when default-p (signal-suspicious-registration-warning name default)) form) (declaim (special *standard-readtable* *empty-readtable*)) (define-api make-readtable (&optional (name nil name-supplied-p) &key merge) (&optional named-readtable-designator &key (:merge list) => readtable) "Creates and returns a new readtable under the specified NAME. MERGE takes a list of NAMED-READTABLE-DESIGNATORS and specifies the 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. 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." (cond ((not name-supplied-p) (copy-readtable *empty-readtable*)) ((reserved-readtable-name-p name) (error "~A is the designator for a predefined readtable. ~ Not acceptable as a user-specified readtable name." name)) ((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)))) (register-readtable name result))))) (define-api rename-readtable (old-name new-name) (named-readtable-designator symbol => readtable) "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." (when (find-readtable new-name) (cerror "Overwrite existing entry." 'readtable-does-already-exist :readtable-name new-name)) (let* ((readtable (ensure-readtable old-name)) (readtable-name (readtable-name readtable))) ;; We use the internal functions directly to omit repeated ;; type-checking. (%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)) (define-api merge-readtables-into (result-readtable &rest named-readtables) (named-readtable-designator &rest named-readtable-designator => readtable) "Copy the contents of each readtable in NAMED-READTABLES into RESULT-READTABLE. 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) (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))))) to)) (let ((result-table (ensure-readtable result-readtable))) (dolist (table (mapcar #'ensure-readtable named-readtables)) (merge-into result-table table)) result-table))) (defun ensure-dispatch-macro-character (char &optional non-terminating-p (readtable *readtable*)) (if (dispatch-macro-char-p char readtable) t (make-dispatch-macro-character char non-terminating-p readtable))) (define-api copy-named-readtable (named-readtable) (named-readtable-designator => readtable) "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument." (copy-readtable (ensure-readtable named-readtable))) (define-api list-all-named-readtables () (=> list) "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))) (define-condition readtable-error (error) ()) (define-condition readtable-does-not-exist (readtable-error) ((readtable-name :initarg :readtable-name :initform (required-argument) :accessor missing-readtable-name :type named-readtable-designator)) (:report (lambda (condition stream) (format stream "A readtable named ~S does not exist." (missing-readtable-name condition))))) (define-condition readtable-does-already-exist (readtable-error) ((readtable-name :initarg :readtable-name :initform (required-argument) :accessor existing-readtable-name :type named-readtable-designator)) (:report (lambda (condition stream) (format stream "A readtable named ~S already exists." (existing-readtable-name condition)))) (:documentation "Continuable.")) (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 "~@" (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 reader macro (be it a macro character or the sub character of a dispatch macro character) is present in the both source and the target readtable and the two respective reader macro functions differ.")) (defun check-reader-macro-conflict (from to char &optional subchar) (flet ((conflictp (from-fn to-fn) (assert from-fn () "Bug in readtable iterators or concurrent access?") (and to-fn (not (function= to-fn from-fn))))) (when (if subchar (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))) (cerror (format nil "Overwrite ~@C in ~A." char to) 'reader-macro-conflict :from-readtable from :to-readtable to :macro-char char :sub-char subchar)))) ;;; 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)) (defvar *empty-readtable* (%clear-readtable (copy-readtable nil))) (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)) (defun reserved-readtable-name-p (name) (and (member name *reserved-readtable-names*) t)) ;;; 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. (defun find-reserved-readtable (reserved-name) (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*) (t (error "Bug: no such reserved readtable: ~S" reserved-name)))) (define-api find-readtable (name) (named-readtable-designator => (or readtable null)) "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)))) ;;; 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) (define-api ensure-readtable (name &optional (default nil default-p)) (named-readtable-designator &optional (or named-readtable-designator null) => readtable) "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))))) (define-api register-readtable (name readtable) (symbol readtable => readtable) "Associate READTABLE with NAME. Returns the readtable." (assert (typep name '(not (satisfies reserved-readtable-name-p)))) (%associate-readtable-with-name name readtable) (%associate-name-with-readtable name readtable) readtable) (define-api unregister-readtable (named-readtable) (named-readtable-designator => boolean) "Remove the association of NAMED-READTABLE. Returns T if successfull, NIL otherwise." (let* ((readtable (find-readtable named-readtable)) (readtable-name (and readtable (readtable-name readtable)))) (if (not readtable-name) nil (prog1 t (check-type readtable-name (not (satisfies reserved-readtable-name-p))) (%unassociate-readtable-from-name readtable-name readtable) (%unassociate-name-from-readtable readtable-name readtable))))) (define-api readtable-name (named-readtable) (named-readtable-designator => symbol) "Returns the name of the readtable designated by NAMED-READTABLE, or NIL." (let ((readtable (ensure-readtable named-readtable))) (cond ((%readtable-name readtable)) ((eq readtable *readtable*) :current) ((eq readtable *standard-readtable*) :common-lisp) ((eq readtable *case-preserving-standard-readtable*) :modern) (t nil))))