Commit 57383c1e authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Named Readtables are now named by symbols, not string-designators.

darcs-hash:20080927125935-f5546-64d6b1ab754c0157cb007d5d4c33550a23362270.gz
parent c05ab168
...@@ -9,9 +9,8 @@ ...@@ -9,9 +9,8 @@
(defvar *readtable-names* (make-hash-table :test 'eq)) (defvar *readtable-names* (make-hash-table :test 'eq))
(declaim (inline %register-readtable-name)) (declaim (inline %register-readtable-name))
(defun %register-readtable-name (string-designator read-table) (defun %register-readtable-name (name read-table)
(setf (gethash read-table *readtable-names*) (setf (gethash read-table *readtable-names*) name))
(string string-designator)))
(declaim (inline %unregister-readtable-name)) (declaim (inline %unregister-readtable-name))
(defun %unregister-readtable-name (read-table) (defun %unregister-readtable-name (read-table)
...@@ -23,7 +22,7 @@ ...@@ -23,7 +22,7 @@
(declaim (inline %list-all-readtable-names)) (declaim (inline %list-all-readtable-names))
(defun %list-all-readtable-names () (defun %list-all-readtable-names ()
(list* "STANDARD" "CURRENT" (list* :standard :current
(loop for name being each hash-value of *readtable-names* (loop for name being each hash-value of *readtable-names*
collect name))) collect name)))
...@@ -102,26 +101,22 @@ ...@@ -102,26 +101,22 @@
#-allegro #-allegro
(progn (progn
(defvar *named-readtables* (make-package (gensym "READTABLES+"))) (defvar *named-readtables* (make-hash-table :test 'eq))
(declaim (inline %register-readtable)) (declaim (inline %register-readtable))
(defun %register-readtable (string-designator read-table) (defun %register-readtable (name read-table)
(let ((name (intern (string string-designator) *named-readtables*))) (setf (gethash name *named-readtables*) read-table))
(setf (symbol-value name) read-table)))
(declaim (inline %unregister-readtable)) (declaim (inline %unregister-readtable))
(defun %unregister-readtable (string-designator) (defun %unregister-readtable (name)
(let ((name (find-symbol (string string-designator) *named-readtables*))) (remhash name *named-readtables*))
(when name
(setf (symbol-value name) nil)
(unintern name *named-readtables*))))
(declaim (inline %find-readtable-from-name)) (declaim (inline %find-readtable-from-name))
(defun %find-readtable-from-name (string-designator) (defun %find-readtable-from-name (name)
(let ((name (find-symbol (string string-designator) *named-readtables*))) (values (gethash name *named-readtables* nil))))
(and name (symbol-value name)))))
;; FIXME: Adapt from STRING-DESIGNATOR to SYMBOL.
#+allegro #+allegro
(progn (progn
(defun %register-readtable (string-designator read-table) (defun %register-readtable (string-designator read-table)
......
...@@ -40,8 +40,8 @@ ...@@ -40,8 +40,8 @@
;;;;;; DEFREADTABLE &c. ;;;;;; DEFREADTABLE &c.
(defmacro defreadtable (string-designator &rest options) (defmacro defreadtable (name &rest options)
"Define a new named readtable, whose name is given by STRING-DESIGNATOR. "Define a new named readtable, whose name is given by the symbol NAME.
Or, if a readtable is already registered under that name, redefines that one. 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: The readtable can be populated using the OPTIONS &rest argument, as follows:
...@@ -71,10 +71,10 @@ The readtable can be populated using the OPTIONS &rest argument, as follows: ...@@ -71,10 +71,10 @@ The readtable can be populated using the OPTIONS &rest argument, as follows:
then the :case directives are evaluated in the order they appear. At last the local 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 macro definitions in :dispatch-macro-char and :macro-char are evaluated in the order
they appear." they appear."
(check-type string-designator string-designator) (check-type name symbol)
(when (reserved-readtable-name-p string-designator) (when (reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~ (error "~A is the designator for a predefined readtable. ~
Not acceptable as a user-specified readtable name." string-designator)) Not acceptable as a user-specified readtable name." name))
(flet ((process-option (option var) (flet ((process-option (option var)
(destructure-case option (destructure-case option
((:merge &rest readtable-designators) ((:merge &rest readtable-designators)
...@@ -99,16 +99,17 @@ they appear." ...@@ -99,16 +99,17 @@ they appear."
(t (t
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:compile-toplevel :load-toplevel :execute)
;; The (FIND-READTABLE ...) is important for proper redefinition semantics. ;; The (FIND-READTABLE ...) is important for proper redefinition semantics.
(let ((read-table (find-readtable ,string-designator))) (let ((read-table (find-readtable ',name)))
(if read-table (if read-table
(simple-style-warn "redefining ~A in ~A" ,string-designator 'defreadtable) (simple-style-warn "redefining ~A in DEFREADTABLE" ',name)
(setq read-table (setq read-table
(make-readtable ,string-designator (make-readtable ',name
;; We have to provide an explicit :MERGE argument, ;; We have to provide an explicit :MERGE argument,
;; because otherwise the :STANDARD readtable would ;; because otherwise the :STANDARD readtable would
;; be used which is not necessarily what we want. ;; be used which is not necessarily what we want.
:merge ',(rest (first merge-clauses))))) :merge ',(rest (first merge-clauses)))))
;; We have to grovel all MERGE-CLAUSES for the redefinition case. ;; We have to grovel all MERGE-CLAUSES for the redefinition case.
,@(loop for option in merge-clauses ,@(loop for option in merge-clauses
collect (process-option option 'read-table)) collect (process-option option 'read-table))
,@(loop for option in case-clauses ,@(loop for option in case-clauses
...@@ -117,13 +118,12 @@ they appear." ...@@ -117,13 +118,12 @@ they appear."
collect (process-option option 'read-table)) collect (process-option option 'read-table))
read-table))))))) read-table)))))))
(defmacro in-readtable (string-designator) (defmacro in-readtable (name)
"Bind the *readtable* to the readtable referred to by "Bind the *readtable* to the readtable referred to by NAME, raising
STRING-DESIGNATOR, raising an error if no such readtable can an error if no such readtable can be found."
be found." (check-type name symbol)
(check-type string-designator string-designator)
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:compile-toplevel :load-toplevel :execute)
(setf *readtable* (ensure-readtable ,string-designator)))) (setf *readtable* (ensure-readtable ',name))))
(defun make-readtable (name &key merge) (defun make-readtable (name &key merge)
"Makes and returns a new readtable under the specified NAME. The "Makes and returns a new readtable under the specified NAME. The
...@@ -147,22 +147,22 @@ the :STANDARD readtable is used instead." ...@@ -147,22 +147,22 @@ the :STANDARD readtable is used instead."
(rest merge-list)))) (rest merge-list))))
(register-readtable name result)))))) (register-readtable name result))))))
(defun rename-readtable (named-readtable-designator string-designator) (defun rename-readtable (named-readtable-designator new-name)
"Replaces the associated name of the readtable designated by "Replaces the associated name of the readtable designated by
NAMED-READTABLE-DESIGNATOR with STRING-DESIGNATOR. If a readtable is NAMED-READTABLE-DESIGNATOR with NEW-NAME If a readtable is already
already registered under the new name, an error is raised." registered under the new name, an error is raised."
(check-type named-readtable-designator named-readtable-designator) (check-type named-readtable-designator named-readtable-designator)
(check-type string-designator string-designator) (check-type new-name symbol)
(when (find-readtable string-designator) (when (find-readtable new-name)
(error "A readtable named ~S already exists." string-designator)) (error "A readtable named ~S already exists." new-name))
(let* ((read-table (ensure-readtable named-readtable-designator)) (let* ((read-table (ensure-readtable named-readtable-designator))
(read-table-name (readtable-name read-table))) (read-table-name (readtable-name read-table)))
;; We use the internal functions directly to omit repeated ;; We use the internal functions directly to omit repeated
;; type-checking. ;; type-checking.
(%unregister-readtable-name read-table) (%unregister-readtable-name read-table)
(%unregister-readtable read-table-name) (%unregister-readtable read-table-name)
(%register-readtable-name string-designator read-table) (%register-readtable-name new-name read-table)
(%register-readtable string-designator read-table) (%register-readtable new-name read-table)
read-table)) read-table))
(defun merge-readtables-into (result-table &rest named-readtable-designators) (defun merge-readtables-into (result-table &rest named-readtable-designators)
...@@ -195,14 +195,11 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -195,14 +195,11 @@ guaranteed to be fresh, but may contain duplicates."
(mapcar #'ensure-readtable (%list-all-readtable-names))) (mapcar #'ensure-readtable (%list-all-readtable-names)))
(deftype string-designator ()
`(or string symbol character))
(deftype readtable-designator () (deftype readtable-designator ()
`(or null readtable)) `(or null readtable))
(deftype named-readtable-designator () (deftype named-readtable-designator ()
`(or readtable-designator string-designator)) `(or readtable-designator symbol))
;;; Although there is no way to get at the standard readtable in ;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make ;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
...@@ -241,18 +238,16 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -241,18 +238,16 @@ guaranteed to be fresh, but may contain duplicates."
(defparameter *reserved-readtable-names* '(nil :standard :current)) (defparameter *reserved-readtable-names* '(nil :standard :current))
(defun reserved-readtable-name-p (name) (defun reserved-readtable-name-p (name)
(and (member (string name) *reserved-readtable-names* (and (member name *reserved-readtable-names*) t))
:test #'string= :key #'symbol-name)
t))
;;; In principle, we could DEFREADTABLE :STANDARD. But we do reserved ;;; In principle, we could DEFREADTABLE :STANDARD. But we do reserved
;;; readtable lookup seperately, since we can't register a readtable ;;; readtable lookup seperately, since we can't register a readtable
;;; for :CURRENT anyway. ;;; for :CURRENT anyway.
(defun find-reserved-readtable (reserved-name) (defun find-reserved-readtable (reserved-name)
(cond ((string= reserved-name nil) *standard-readtable*) (cond ((eq reserved-name nil) *standard-readtable*)
((string= reserved-name :standard) *standard-readtable*) ((eq reserved-name :standard) *standard-readtable*)
((string= reserved-name :current) *readtable*) ((eq reserved-name :current) *readtable*)
(t (error "No such reserved readtable: ~S" reserved-name)))) (t (error "No such reserved readtable: ~S" reserved-name))))
(defun find-readtable (named-readtable-designator) (defun find-readtable (named-readtable-designator)
...@@ -283,13 +278,13 @@ is signalled." ...@@ -283,13 +278,13 @@ is signalled."
(t (setf (find-readtable designator) (ensure-readtable default)))))) (t (setf (find-readtable designator) (ensure-readtable default))))))
(defun register-readtable (string-designator read-table) (defun register-readtable (name read-table)
"Associate READ-TABLE as the readtable associated with STRING-DESIGNATOR." "Associate READ-TABLE as the readtable associated with NAME."
(check-type string-designator string-designator) (check-type name symbol)
(check-type read-table readtable) (check-type read-table readtable)
(check-type string-designator (not (satisfies reserved-readtable-name-p))) (check-type name (not (satisfies reserved-readtable-name-p)))
(%register-readtable-name string-designator read-table) (%register-readtable-name name read-table)
(%register-readtable string-designator read-table) (%register-readtable name read-table)
read-table) read-table)
(defun unregister-readtable (named-readtable-designator) (defun unregister-readtable (named-readtable-designator)
...@@ -305,12 +300,12 @@ Returns T if successfull, NIL otherwise." ...@@ -305,12 +300,12 @@ Returns T if successfull, NIL otherwise."
(%unregister-readtable read-table-name))))) (%unregister-readtable read-table-name)))))
(defun readtable-name (named-readtable-designator) (defun readtable-name (named-readtable-designator)
"Returns the name (as string) of the readtable designated by "Returns the name of the readtable designated by
NAMED-READTABLE-DESIGNATOR or NIL." NAMED-READTABLE-DESIGNATOR or NIL."
(check-type named-readtable-designator named-readtable-designator) (check-type named-readtable-designator named-readtable-designator)
(let ((read-table (ensure-readtable named-readtable-designator))) (let ((read-table (ensure-readtable named-readtable-designator)))
(cond ((eq read-table *readtable*) "CURRENT") (cond ((eq read-table *readtable*) :current)
((eq read-table *standard-readtable*) "STANDARD") ((eq read-table *standard-readtable*) :standard)
(t (%readtable-name read-table))))) (t (%readtable-name read-table)))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment