Commit 8dc02af1 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Add :EMPTY readtables.

darcs-hash:20090905182312-f5546-8ef69cab7c36af5c35fc58a70294d1cead3641b7.gz
parent 6edecc9d
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
(find-package "SB-IMPL")) (find-package "SB-IMPL"))
(pushnew :sbcl+safe-standard-readtable *features*))) (pushnew :sbcl+safe-standard-readtable *features*)))
;;;;; Implementation-dependent cruft ;;;;; Implementation-dependent cruft
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable* #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
#+ :common-lisp (copy-readtable nil)) #+ :common-lisp (copy-readtable nil))
;;;; Mapping between a readtable object and its readtable-name. ;;;; Mapping between a readtable object and its readtable-name.
(defvar *readtable-names* (make-hash-table :test 'eq)) (defvar *readtable-names* (make-hash-table :test 'eq))
...@@ -57,7 +57,7 @@ ...@@ -57,7 +57,7 @@
(loop for name being each hash-value of *readtable-names* (loop for name being each hash-value of *readtable-names*
collect name))) collect name)))
;;;; Mapping between a readtable-name and the actual readtable object. ;;;; Mapping between a readtable-name and the actual readtable object.
;;; On Allegro we reuse their named-readtable support so we work ;;; On Allegro we reuse their named-readtable support so we work
...@@ -99,7 +99,7 @@ ...@@ -99,7 +99,7 @@
#+ :allegro (excl:named-readtable (readtable-name-for-allegro name)) #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
#+ :common-lisp (values (gethash name *named-readtables* nil))) #+ :common-lisp (values (gethash name *named-readtables* nil)))
;;;; Readtables Iterators ;;;; Readtables Iterators
(defmacro with-readtable-iterator ((name readtable) &body body) (defmacro with-readtable-iterator ((name readtable) &body body)
...@@ -223,7 +223,27 @@ ...@@ -223,7 +223,27 @@
(error () nil)) (error () nil))
(return (values t char fn disp? alist))))))))) (return (values t char fn disp? alist)))))))))
(defmacro do-readtable ((entry-designator readtable &optional result)
&body body)
"Iterate through a readtable's macro characters, and dispatch macro characters."
(destructuring-bind (char &optional reader-fn disp? table)
(if (symbolp entry-designator)
(list entry-designator)
entry-designator)
(let ((iter (gensym "ITER+"))
(more? (gensym "MORE?+")))
`(with-readtable-iterator (,iter ,readtable)
(loop
(multiple-value-bind (,more?
,char
,@(when reader-fn (list reader-fn))
,@(when disp? (list disp?))
,@(when table (list table)))
(,iter)
(unless ,more? (return ,result))
,@body))))))
;;;; Specialized PRINT-OBJECT for named readtables. ;;;; Specialized PRINT-OBJECT for named readtables.
;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT ;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
......
(defsystem :named-readtables (asdf:defsystem :named-readtables
:description "Library that creates a namespace for named readtable akin to the namespace of packages." :description "Library that creates a namespace for named readtable akin to the namespace of packages."
:author "Tobias C. Rittweiler <trittweiler@common-lisp.net>" :author "Tobias C. Rittweiler <trittweiler@common-lisp.net>"
:version "1.0 (unpublished so far)" :version "1.0 (unpublished so far)"
......
...@@ -43,14 +43,8 @@ The readtable can be populated using the following `options': ...@@ -43,14 +43,8 @@ The readtable can be populated using the following `options':
(:MERGE `readtable-designators'+) (:MERGE `readtable-designators'+)
Merge the readtables designated into the new readtable, using Merge the readtables designated into the new readtable, using
MERGE-READTABLES-INTO. It is mandatory to supply at least one :MERGE MERGE-READTABLES-INTO.
clause.
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 Note that the process of merging readtables is _not_ commutative, so
that reader macros in earlier entries will be overwritten by later that reader macros in earlier entries will be overwritten by later
ones. ones.
...@@ -90,7 +84,8 @@ Notes: ...@@ -90,7 +84,8 @@ Notes:
its definition -- you have to wrap the DEFREADTABLE form in an explicit its definition -- you have to wrap the DEFREADTABLE form in an explicit
EVAL-WHEN. EVAL-WHEN.
NIL, :STANDARD, and :CURRENT are preregistered readtable names. NIL, :STANDARD, :EMPTY, and :CURRENT are preregistered readtable
names.
" "
(check-type name symbol) (check-type name symbol)
(when (reserved-readtable-name-p name) (when (reserved-readtable-name-p name)
...@@ -127,10 +122,8 @@ Notes: ...@@ -127,10 +122,8 @@ Notes:
(append merge-clauses case-clauses (append merge-clauses case-clauses
macro-clauses syntax-clauses)))) macro-clauses syntax-clauses))))
(cond (cond
((null merge-clauses)
(error "You must specify at least one :MERGE clause in DEFREADTABLE."))
((not (null other-clauses)) ((not (null other-clauses))
(error "Bogus DEFREADTABLE clauses: ~{~A~^, ~}" other-clauses)) (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
(t (t
`(eval-when (:load-toplevel :execute) `(eval-when (:load-toplevel :execute)
(handler-bind ((readtable-does-already-exist (handler-bind ((readtable-does-already-exist
...@@ -141,15 +134,8 @@ Notes: ...@@ -141,15 +134,8 @@ Notes:
(continue c)))) (continue c))))
;; The (FIND-READTABLE ...) is important for proper redefinition ;; The (FIND-READTABLE ...) is important for proper redefinition
;; semantics. ;; semantics.
(let ((readtable (find-readtable ',name))) (let ((readtable (or (find-readtable ',name)
(setq readtable (make-readtable ',name))))
(make-readtable ',name
;; We have to provide an explicit :MERGE
;; argument, because otherwise the
;; :STANDARD readtable would be used which
;; is not necessarily what we want.
:merge ',(rest (first merge-clauses))))
;; 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 'readtable)) collect (process-option option 'readtable))
,@(loop for option in case-clauses ,@(loop for option in case-clauses
...@@ -190,10 +176,10 @@ Notes: ...@@ -190,10 +176,10 @@ Notes:
"Creates and returns a new readtable under the specified `name'. "Creates and returns a new readtable under the specified `name'.
`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the `merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clauses of readtables the new readtable is created from. (See the :MERGE clause of
DEFREADTABLE for details.) If :MERGE wasn't given (or NIL), the :STANDARD DEFREADTABLE for details.) If `merge' wasn't given (or NIL), the :EMPTY
readtable is used instead." readtable is used instead."
(let ((merge-list (or merge '(:standard)))) (let ((merge-list (or merge '(:empty))))
(check-type merge-list list) (check-type merge-list list)
(cond ((reserved-readtable-name-p name) (cond ((reserved-readtable-name-p name)
(error "~A is the designator for a predefined readtable. ~ (error "~A is the designator for a predefined readtable. ~
...@@ -235,17 +221,14 @@ definitions in readtables appearing later in the list will overwrite ...@@ -235,17 +221,14 @@ definitions in readtables appearing later in the list will overwrite
reader-macros appearing earlier. Notice that the /readtable case/ is also reader-macros appearing earlier. Notice that the /readtable case/ is also
subject of the merge operation." subject of the merge operation."
(flet ((merge-into (rt1 rt2) (flet ((merge-into (rt1 rt2)
(with-readtable-iterator (rt2-iter rt2) (do-readtable ((char reader-fn disp? table) rt2)
(loop (unless (standard-macro-char-p char rt2)
(multiple-value-bind (more? char reader-fn disp? table) (rt2-iter) (let ((non-terminating-p (nth-value 1 (get-macro-character char rt2))))
(unless more? (return)) (set-macro-character char reader-fn non-terminating-p rt1)))
(unless (standard-macro-char-p char rt2) (when disp?
(let ((non-terminating-p (nth-value 1 (get-macro-character char rt2)))) (loop for (subchar . subfn) in table do
(set-macro-character char reader-fn non-terminating-p rt1))) (unless (standard-dispatch-macro-char-p char subchar rt2)
(when disp? (set-dispatch-macro-character char subchar subfn rt1)))))
(loop for (subchar . subfn) in table do
(unless (standard-dispatch-macro-char-p char subchar rt2)
(set-dispatch-macro-character char subchar subfn rt1)))))))
rt1)) rt1))
(setf result-table (ensure-readtable result-table)) (setf result-table (ensure-readtable result-table))
(dolist (table (mapcar #'ensure-readtable named-readtable-designators)) (dolist (table (mapcar #'ensure-readtable named-readtable-designators))
...@@ -308,6 +291,15 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -308,6 +291,15 @@ guaranteed to be fresh, but may contain duplicates."
;;; ;;;
(defvar *standard-readtable* (%standard-readtable)) (defvar *standard-readtable* (%standard-readtable))
(defvar *empty-readtable*
(let ((readtable (copy-readtable nil)))
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable (%standard-readtable)))
;; Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable))
(defun standard-macro-char-p (char rt) (defun standard-macro-char-p (char rt)
(multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt) (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
(multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*) (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
...@@ -321,7 +313,7 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -321,7 +313,7 @@ guaranteed to be fresh, but may contain duplicates."
(eq (get-dispatch-macro-character disp-char sub-char rt) (eq (get-dispatch-macro-character disp-char sub-char rt)
(get-dispatch-macro-character disp-char sub-char *standard-readtable*))))) (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
(defparameter *reserved-readtable-names* '(nil :standard :current)) (defparameter *reserved-readtable-names* '(nil :standard :current :empty))
(defun reserved-readtable-name-p (name) (defun reserved-readtable-name-p (name)
(and (member name *reserved-readtable-names*) t)) (and (member name *reserved-readtable-names*) t))
...@@ -333,6 +325,7 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -333,6 +325,7 @@ guaranteed to be fresh, but may contain duplicates."
(defun find-reserved-readtable (reserved-name) (defun find-reserved-readtable (reserved-name)
(cond ((eq reserved-name nil) *standard-readtable*) (cond ((eq reserved-name nil) *standard-readtable*)
((eq reserved-name :standard) *standard-readtable*) ((eq reserved-name :standard) *standard-readtable*)
((eq reserved-name :empty) *empty-readtable*)
((eq reserved-name :current) *readtable*) ((eq reserved-name :current) *readtable*)
(t (error "Bug: no such reserved readtable: ~S" reserved-name)))) (t (error "Bug: no such reserved readtable: ~S" reserved-name))))
...@@ -393,6 +386,7 @@ successfull, NIL otherwise." ...@@ -393,6 +386,7 @@ successfull, NIL otherwise."
(cond ((%readtable-name read-table)) (cond ((%readtable-name read-table))
((eq read-table *readtable*) :current) ((eq read-table *readtable*) :current)
((eq read-table *standard-readtable*) :standard) ((eq read-table *standard-readtable*) :standard)
((eq read-table *empty-readtable*) :empty)
(t nil)))) (t nil))))
......
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
particular: particular:
* you can associate readtables with names, and retrieve * you can associate readtables with names, and retrieve
readtables from their names; readtables by names;
* you can associate source files with readtable names, and be * you can associate source files with readtable names, and be
sure that the right readtable is active when compiling/loading sure that the right readtable is active when compiling/loading
...@@ -39,7 +39,8 @@ ...@@ -39,7 +39,8 @@
* similiarly, your development environment now has a chance to * similiarly, your development environment now has a chance to
automatically determine what readtable should be active while automatically determine what readtable should be active while
processing source forms on interactive commands. processing source forms on interactive commands. (E.g. think of
`C-c C-c' in Slime [yet to be done])
It follows that Named-Readtables is a facility for using readtables in It follows that Named-Readtables is a facility for using readtables in
a localized way. a localized way.
...@@ -47,17 +48,17 @@ ...@@ -47,17 +48,17 @@
Additionally, it also attempts to become a facility for using Additionally, it also attempts to become a facility for using
readtables in a /modular/ way. In particular: readtables in a /modular/ way. In particular:
* it provides a convenience macro to specify the whole content of * it provides a macro to specify the content of a readtable at a
a readtable at one sight. glance;
* it supports multiple inheritance. * it makes it possible to use multiple inheritance between readtables.
* Notes on the API * Notes on the API
The API heavily imitates the API of packages. This has the nice The API heavily imitates the API of packages. This has the nice
property that any experienced Common Lisper will take it up totally property that any experienced Common Lisper will take it up without
effortless. effort.
DEFREADTABLE - DEFPACKAGE DEFREADTABLE - DEFPACKAGE
...@@ -151,6 +152,11 @@ ...@@ -151,6 +152,11 @@
- :CURRENT designates the /current readtable/. - :CURRENT designates the /current readtable/.
- :EMPTY designates an empty readtable. That 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.
* Examples * Examples
> (defreadtable elisp:syntax > (defreadtable elisp:syntax
......
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