Commit ff5a48d9 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Add :COMMON-LISP as synonym for :STANDARD. Add :MODERN for a case-preserving :STANDARD.

darcs-hash:20090919082940-f5546-ad25a87e75da5f688eda15fc5edb0e37d06395f8.gz
parent c6ba0499
;;;; -*- Mode:Lisp -*-
;;;; ;;;;
;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr@freebits.de> ;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr@freebits.de>
;;;; Copyright (c) 2007, Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC ;;;; Copyright (c) 2007, Robert P. Goldman <rpgoldman@sift.info> and SIFT, LLC
...@@ -87,7 +88,8 @@ Notes: ...@@ -87,7 +88,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, :COMMON-LISP, :MODERN, 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)
...@@ -134,8 +136,9 @@ Notes: ...@@ -134,8 +136,9 @@ Notes:
"Overwriting previously existing readtable ~S." "Overwriting previously existing readtable ~S."
(existing-readtable-name c)) (existing-readtable-name c))
(continue c)))) (continue c))))
;; The (FIND-READTABLE ...) is important for proper redefinition ;; The (FIND-READTABLE ...) is important for proper
;; semantics. ;; redefinition semantics, as redefining has to modify the
;; already existing readtable object.
(let ((readtable (or (find-readtable ',name) (let ((readtable (or (find-readtable ',name)
(make-readtable ',name)))) (make-readtable ',name))))
,@(loop for option in merge-clauses ,@(loop for option in merge-clauses
...@@ -152,6 +155,8 @@ Notes: ...@@ -152,6 +155,8 @@ Notes:
"Set *READTABLE* to the readtable referred to by the symbol `name'." "Set *READTABLE* to the readtable referred to by the symbol `name'."
(check-type name symbol) (check-type name symbol)
`(eval-when (:compile-toplevel :load-toplevel :execute) `(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)) (setf *readtable* (ensure-readtable ',name))
(when (find-package :swank) (when (find-package :swank)
(%frob-swank-readtable-alist *package* *readtable*)) (%frob-swank-readtable-alist *package* *readtable*))
...@@ -209,7 +214,8 @@ standard macro character has been made a constituent." ...@@ -209,7 +214,8 @@ standard macro character has been made a constituent."
(defun rename-readtable (named-readtable-designator new-name) (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 `new-name'. If a readtable is already `named-readtable-designator' with `new-name'. If a readtable is already
registered under `new-name', an error is raised." registered under `new-name', an error of type READTABLE-DOES-ALREADY-EXIST
is signaled."
(check-type named-readtable-designator named-readtable-designator) (check-type named-readtable-designator named-readtable-designator)
(check-type new-name symbol) (check-type new-name symbol)
(when (find-readtable new-name) (when (find-readtable new-name)
...@@ -229,9 +235,9 @@ registered under `new-name', an error is raised." ...@@ -229,9 +235,9 @@ registered under `new-name', an error is raised."
"Copy the contents of each readtable in `named-readtable-designators' "Copy the contents of each readtable in `named-readtable-designators'
into `result-table'. Because the readtables are merged in turn, macro into `result-table'. Because the readtables are merged in turn, macro
definitions in readtables appearing later in the list will overwrite 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."
subject of the merge operation."
(flet ((merge-into (rt1 rt2) (flet ((merge-into (rt1 rt2)
;;; FIXME: document why STANDARD-FOO-CHAR-P
(do-readtable ((char reader-fn disp? table) rt2) (do-readtable ((char reader-fn disp? table) rt2)
(unless (standard-macro-char-p char rt2) (unless (standard-macro-char-p char rt2)
(let ((non-terminating-p (nth-value 1 (get-macro-character char rt2)))) (let ((non-terminating-p (nth-value 1 (get-macro-character char rt2))))
...@@ -291,7 +297,8 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -291,7 +297,8 @@ guaranteed to be fresh, but may contain duplicates."
:type named-readtable-designatord)) :type named-readtable-designatord))
(:report (lambda (condition stream) (:report (lambda (condition stream)
(format stream "A readtable named ~S already exists." (format stream "A readtable named ~S already exists."
(existing-readtable-name condition))))) (existing-readtable-name condition))))
(:documentation "Continuable."))
;;; Although there is no way to get at the standard readtable in ;;; Although there is no way to get at the standard readtable in
...@@ -319,24 +326,32 @@ guaranteed to be fresh, but may contain duplicates." ...@@ -319,24 +326,32 @@ guaranteed to be fresh, but may contain duplicates."
(let ((readtable (copy-readtable nil))) (let ((readtable (copy-readtable nil)))
(do-readtable (char readtable) (do-readtable (char readtable)
(set-syntax-from-char char #\A readtable (%standard-readtable))) (set-syntax-from-char char #\A readtable (%standard-readtable)))
;; Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a ;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly. ;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil) #+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable)) readtable))
(defparameter *reserved-readtable-names* '(nil :standard :current)) (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) (defun reserved-readtable-name-p (name)
(and (member name *reserved-readtable-names*) t)) (and (member name *reserved-readtable-names*) t))
;;; In principle, we could DEFREADTABLE :STANDARD. But we do reserved ;;; In principle, we could DEFREADTABLE some of these. But we do
;;; readtable lookup seperately, since we can't register a readtable ;;; reserved readtable lookup seperately, since we can't register a
;;; for :CURRENT anyway. ;;; readtable for :CURRENT anyway.
(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 :current) *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)))) (t (error "Bug: no such reserved readtable: ~S" reserved-name))))
(defun find-readtable (named-readtable-designator) (defun find-readtable (named-readtable-designator)
...@@ -358,8 +373,8 @@ returns it if it is found. Returns NIL otherwise." ...@@ -358,8 +373,8 @@ returns it if it is found. Returns NIL otherwise."
"Looks up the readtable specified by `named-readtable-designator' and "Looks up the readtable specified by `named-readtable-designator' and
returns it if it is found. If it is not found, it registers the readtable returns it if it is found. If it is not found, it registers the readtable
designated by `default' under the name represented by designated by `default' under the name represented by
`named-readtable-designator'. If no default argument is given, an error is `named-readtable-designator'; or if no default argument is given, it
signalled in this case." signals an error of type READTABLE-DOES-NOT-EXIST instead."
(symbol-macrolet ((designator named-readtable-designator)) (symbol-macrolet ((designator named-readtable-designator))
(cond ((find-readtable designator)) (cond ((find-readtable designator))
((not default-p) ((not default-p)
...@@ -394,8 +409,9 @@ successfull, NIL otherwise." ...@@ -394,8 +409,9 @@ successfull, NIL otherwise."
(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 ((%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*) :common-lisp)
((eq read-table *case-preserving-standard-readtable*) :modern)
(t nil)))) (t nil))))
......
...@@ -117,11 +117,11 @@ ...@@ -117,11 +117,11 @@
(Such merging can more or less be implemented portably albeit (Such merging can more or less be implemented portably albeit
at a certain cost. Most of the time, this cost manifests at a certain cost. Most of the time, this cost manifests
itself at the time a readtable is defined, i.e. at itself at the time a readtable is defined, i.e. once at
compile-time, and once for each definition, only, so it may compile-time, so it may not bother you. Nonetheless, we
not bother you. Nonetheless, we provide extra support for provide extra support for Sbcl, ClozureCL, and AllegroCL at
Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your the moment. Patches for your implementation of choice are
implementation of choice are welcome, of course.) welcome, of course.)
3. DEFREADTABLE does not have compile-time effects. 3. DEFREADTABLE does not have compile-time effects.
...@@ -148,7 +148,9 @@ ...@@ -148,7 +148,9 @@
* Preregistered Readtables * Preregistered Readtables
- NIL, and :STANDARD designate the /standard readtable/. - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
- :MODERM designates a _case-preserving_ /standard-readtable/.
- :CURRENT designates the /current readtable/. - :CURRENT designates the /current readtable/.
...@@ -176,6 +178,14 @@ ...@@ -176,6 +178,14 @@
> ... > ...
> >
> (in-readtable scheme:syntax) > (in-readtable scheme:syntax)
* Acknowledgements
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta and David Crawford for being early adopters, providing
comments and bugfixes.
")) "))
(pushnew :named-readtables *features*) (pushnew :named-readtables *features*)
\ No newline at end of file
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