[snow-cvs] r10 - in trunk: lib lib/named-readtables lib/named-readtables/doc lib/named-readtables/tests src/java/snow src/java/snow/example src/lisp/snow
Alessio Stalla
astalla at common-lisp.net
Thu Oct 22 20:10:11 UTC 2009
Author: astalla
Date: Thu Oct 22 16:10:10 2009
New Revision: 10
Log:
Integrated named readtables
updated to latest abcl (fixes a bug with set-syntax-from-char which broke named readtables)
implemented read macro for EL binding
fixed compilation with ant (snow is no longer an eclipse project)
Added:
trunk/lib/named-readtables/
trunk/lib/named-readtables/LICENSE
trunk/lib/named-readtables/cruft.lisp
trunk/lib/named-readtables/define-api.lisp
trunk/lib/named-readtables/doc/
trunk/lib/named-readtables/doc/named-readtables.html
trunk/lib/named-readtables/named-readtables.asd
trunk/lib/named-readtables/named-readtables.lisp
trunk/lib/named-readtables/package.lisp
trunk/lib/named-readtables/tests/
trunk/lib/named-readtables/tests/package.lisp
trunk/lib/named-readtables/tests/rt.lisp
trunk/lib/named-readtables/tests/tests.lisp
trunk/lib/named-readtables/utils.lisp
Modified:
trunk/lib/abcl.jar
trunk/src/java/snow/Snow.java
trunk/src/java/snow/example/example.lisp
trunk/src/lisp/snow/compile-system.lisp
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.asd
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Added: trunk/lib/named-readtables/LICENSE
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/LICENSE Thu Oct 22 16:10:10 2009
@@ -0,0 +1,36 @@
+
+Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+Copyright (c) 2007, Robert P. Goldman <rpgoldman at sift.info> and SIFT, LLC
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
+ SIFT, LLC nor the names of its contributors may be used to
+ endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
+P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
+P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: trunk/lib/named-readtables/cruft.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/cruft.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,375 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
+ (assert (typep docstring 'string) (docstring) "Docstring missing!")
+ (assert (not (null alternatives)))
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name ,lambda-list ,docstring ,(first alternatives))))
+
+(eval-when (:compile-toplevel :execute)
+ #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
+ (find-package "SB-IMPL"))
+ (pushnew :sbcl+safe-standard-readtable *features*)))
+
+
+;;;;; Implementation-dependent cruft
+
+;;;; Mapping between a readtable object and its readtable-name.
+
+(defvar *readtable-names* (make-hash-table :test 'eq))
+
+(define-cruft %associate-readtable-with-name (name readtable)
+ "Associate READTABLE with NAME for READTABLE-NAME to work."
+ #+ :common-lisp (setf (gethash readtable *readtable-names*) name))
+
+(define-cruft %unassociate-readtable-from-name (name readtable)
+ "Remove the association between READTABLE and NAME."
+ #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
+ (remhash readtable *readtable-names*)))
+
+(define-cruft %readtable-name (readtable)
+ "Return the name associated with READTABLE."
+ #+ :common-lisp (values (gethash readtable *readtable-names*)))
+
+(define-cruft %list-all-readtable-names ()
+ "Return a list of all available readtable names."
+ #+ :common-lisp (list* :standard :current
+ (loop for name being each hash-value of *readtable-names*
+ collect name)))
+
+
+;;;; Mapping between a readtable-name and the actual readtable object.
+
+;;; On Allegro we reuse their named-readtable support so we work
+;;; nicely on their infrastructure.
+
+#-allegro
+(defvar *named-readtables* (make-hash-table :test 'eq))
+
+#+allegro
+(defun readtable-name-for-allegro (symbol)
+ (multiple-value-bind (kwd status)
+ (if (keywordp symbol)
+ (values symbol nil)
+ ;; Kludge: ACL uses keywords to name readtables, we allow
+ ;; arbitrary symbols.
+ (intern (format nil "~A.~A"
+ (package-name (symbol-package symbol))
+ (symbol-name symbol))
+ :keyword))
+ (prog1 kwd
+ (assert (or (not status) (get kwd 'named-readtable-designator)))
+ (setf (get kwd 'named-readtable-designator) t))))
+
+(define-cruft %associate-name-with-readtable (name readtable)
+ "Associate NAME with READTABLE for FIND-READTABLE to work."
+ #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
+ #+ :common-lisp (setf (gethash name *named-readtables*) readtable))
+
+(define-cruft %unassociate-name-from-readtable (name readtable)
+ "Remove the association between NAME and READTABLE"
+ #+ :allegro (let ((n (readtable-name-for-allegro name)))
+ (assert (eq readtable (excl:named-readtable n)))
+ (setf (excl:named-readtable n) nil))
+ #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
+ (remhash name *named-readtables*)))
+
+(define-cruft %find-readtable (name)
+ "Return the readtable named NAME."
+ #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
+ #+ :common-lisp (values (gethash name *named-readtables* nil)))
+
+
+;;;; Reader-macro related predicates
+
+;;; CLISP creates new function objects for standard reader macros on
+;;; each readtable copy.
+(define-cruft function= (fn1 fn2)
+ "Are reader-macro function-designators FN1 and FN2 the same?"
+ #+ :clisp
+ (let* ((fn1 (ensure-function fn1))
+ (fn2 (ensure-function fn2))
+ (n1 (system::function-name fn1))
+ (n2 (system::function-name fn2)))
+ (if (and (eq n1 :lambda) (eq n2 :lambda))
+ (eq fn1 fn2)
+ (equal n1 n2)))
+ #+ :common-lisp
+ (eq (ensure-function fn1) (ensure-function fn2)))
+
+;;; CCL has a bug that prevents the portable form below from working
+;;; (Ticket 601). CLISP will incorrectly fold the call to G-D-M-C away
+;;; if not declared inline.
+(define-cruft dispatch-macro-char-p (char rt)
+ "Is CHAR a dispatch macro character in RT?"
+ #+ :ccl
+ (let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
+ (or (consp (cdr def))
+ (eq (car def) #'ccl::read-dispatch)))
+ #+ :common-lisp
+ (handler-case (locally
+ #+clisp (declare (notinline get-dispatch-macro-character))
+ (get-dispatch-macro-character char #\x rt)
+ t)
+ (error () nil)))
+
+;; (defun macro-char-p (char rt)
+;; (let ((reader-fn (%get-macro-character char rt)))
+;; (and reader-fn t)))
+
+;; (defun standard-macro-char-p (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*)
+;; (and (eq rt-fn std-fn)
+;; (eq rt-flag std-flag)))))
+
+;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
+;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
+;; (and (eq (non-terminating-p disp-char rt)
+;; (non-terminating-p disp-char *standard-readtable*))
+;; (eq (get-dispatch-macro-character disp-char sub-char rt)
+;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
+
+
+;;;; Readtables Iterators
+
+(defmacro with-readtable-iterator ((name readtable) &body body)
+ (let ((it (gensym)))
+ `(let ((,it (%make-readtable-iterator ,readtable)))
+ (macrolet ((,name () `(funcall ,',it)))
+ , at body))))
+
+#+sbcl
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-array (sb-impl::character-macro-array readtable))
+ (char-macro-ht (sb-impl::character-macro-hash-table readtable))
+ (dispatch-tables (sb-impl::dispatch-tables readtable))
+ (char-code 0))
+ (with-hash-table-iterator (ht-iterator char-macro-ht)
+ (labels ((grovel-base-chars ()
+ (declare (optimize sb-c::merge-tail-calls))
+ (if (>= char-code sb-int:base-char-code-limit)
+ (grovel-unicode-chars)
+ (let ((reader-fn (svref char-macro-array char-code))
+ (char (code-char (shiftf char-code (1+ char-code)))))
+ (if reader-fn
+ (yield char reader-fn)
+ (grovel-base-chars)))))
+ (grovel-unicode-chars ()
+ (multiple-value-bind (more? char reader-fn) (ht-iterator)
+ (if (not more?)
+ (values nil nil nil nil nil)
+ (yield char reader-fn))))
+ (yield (char reader-fn)
+ (let ((disp-ht))
+ (cond
+ ((setq disp-ht (cdr (assoc char dispatch-tables)))
+ (let* ((disp-fn (get-macro-character char readtable))
+ (sub-char-alist))
+ (maphash (lambda (k v)
+ (push (cons k v) sub-char-alist))
+ disp-ht)
+ (values t char disp-fn t sub-char-alist)))
+ (t
+ (values t char reader-fn nil nil))))))
+ #'grovel-base-chars))))
+
+#+clozure
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-alist (ccl::rdtab.alist readtable)))
+ (lambda ()
+ (if char-macro-alist
+ (destructuring-bind (char . defn) (pop char-macro-alist)
+ (if (consp defn)
+ (values t char (car defn) t (cdr defn))
+ (values t char defn nil nil)))
+ (values nil nil nil nil nil)))))
+
+;;; Written on ACL 8.0.
+#+allegro
+(defun %make-readtable-iterator (readtable)
+ (declare (optimize speed)) ; for TCO
+ (check-type readtable readtable)
+ (let* ((macro-table (first (excl::readtable-macro-table readtable)))
+ (dispatch-tables (excl::readtable-dispatch-tables readtable))
+ (table-length (length macro-table))
+ (idx 0))
+ (labels ((grovel-macro-chars ()
+ (if (>= idx table-length)
+ (grovel-dispatch-chars)
+ (let ((read-fn (svref macro-table idx))
+ (oidx idx))
+ (incf idx)
+ (if (or (eq read-fn #'excl::read-token)
+ (eq read-fn #'excl::read-dispatch-char)
+ (eq read-fn #'excl::undefined-macro-char))
+ (grovel-macro-chars)
+ (values t (code-char oidx) read-fn nil nil)))))
+ (grovel-dispatch-chars ()
+ (if (null dispatch-tables)
+ (values nil nil nil nil nil)
+ (destructuring-bind (disp-char sub-char-table)
+ (first dispatch-tables)
+ (setf dispatch-tables (rest dispatch-tables))
+ ;;; Kludge. We can't fully clear dispatch tables
+ ;;; in %CLEAR-READTABLE.
+ (when (eq (svref macro-table (char-code disp-char))
+ #'excl::read-dispatch-char)
+ (values t
+ disp-char
+ (svref macro-table (char-code disp-char))
+ t
+ (loop for subch-fn across sub-char-table
+ for subch-code from 0
+ when subch-fn
+ collect (cons (code-char subch-code)
+ subch-fn))))))))
+ #'grovel-macro-chars)))
+
+
+#-(or sbcl clozure allegro)
+(eval-when (:compile-toplevel)
+ (let ((*print-pretty* t))
+ (simple-style-warn
+ "~&~@< ~@;~A has not been ported to ~A. ~
+ We fall back to a portable implementation of readtable iterators. ~
+ This implementation has to grovel through all available characters. ~
+ On Unicode-aware implementations this may come with some costs.~@:>"
+ (package-name '#.*package*) (lisp-implementation-type))))
+
+#-(or sbcl clozure allegro)
+(defun %make-readtable-iterator (readtable)
+ (check-type readtable readtable)
+ (let ((char-code 0))
+ #'(lambda ()
+ (prog ()
+ :GROVEL
+ (when (< char-code char-code-limit)
+ (let* ((char (code-char char-code))
+ (fn (get-macro-character char readtable)))
+ (incf char-code)
+ (when (not fn) (go :GROVEL))
+ (multiple-value-bind (disp? alist)
+ (handler-case ; grovel dispatch macro characters.
+ (values t
+ ;; Only grovel upper case characters to
+ ;; avoid duplicates.
+ (loop for code from 0 below char-code-limit
+ for subchar = (let ((ch (code-char code)))
+ (when (or (not (alpha-char-p ch))
+ (upper-case-p ch))
+ ch))
+ for disp-fn = (and subchar
+ (get-dispatch-macro-character
+ char subchar readtable))
+ when disp-fn
+ collect (cons subchar disp-fn)))
+ (error () nil))
+ (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 non-terminating-p disp? table)
+ (if (symbolp entry-designator)
+ (list entry-designator)
+ entry-designator)
+ (let ((iter (gensym "ITER+"))
+ (more? (gensym "MORE?+"))
+ (rt (gensym "READTABLE+")))
+ `(let ((,rt ,readtable))
+ (with-readtable-iterator (,iter ,rt)
+ (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))
+ (let ,(when non-terminating-p
+ ;; FIXME: N-T-P should be incorporated in iterators.
+ `((,non-terminating-p
+ (nth-value 1 (get-macro-character ,char ,rt)))))
+ , at body))))))))
+
+;;;; Misc
+
+;;; This should return an implementation's actual standard readtable
+;;; object only if the implementation makes the effort to guard against
+;;; modification of that object. Otherwise it should better return a
+;;; copy.
+(define-cruft %standard-readtable ()
+ "Return the standard readtable."
+ #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
+ #+ :common-lisp (copy-readtable nil))
+
+;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
+;;; readtable's dispatch table properly.
+;;; Same goes for Allegro but that does not seem to provide a
+;;; setter for their readtable's dispatch tables. Hence this ugly
+;;; workaround.
+(define-cruft %clear-readtable (readtable)
+ "Make all macro characters in READTABLE be constituents."
+ #+ :sbcl
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (setf (sb-impl::dispatch-tables readtable) nil))
+ #+ :allegro
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
+ (setf (cdr dispatch-tables) nil)
+ (setf (caar dispatch-tables) #\Backspace)
+ (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil))))
+ #+ :common-lisp
+ (do-readtable (char readtable readtable)
+ (set-syntax-from-char char #\A readtable)))
+
+;;; See Clozure Trac Ticket 601. This is supposed to be removed at
+;;; some point in the future.
+(define-cruft %get-dispatch-macro-character (char subchar rt)
+ "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
+ #+ :ccl (ignore-errors
+ (get-dispatch-macro-character char subchar rt))
+ #+ :common-lisp (get-dispatch-macro-character char subchar rt))
+
+;;; Allegro stores READ-TOKEN as reader macro function of each
+;;; constituent character.
+(define-cruft %get-macro-character (char rt)
+ "Ensure ANSI behaviour for GET-MACRO-CHARACTER."
+ #+ :allegro (let ((fn (get-macro-character char rt)))
+ (cond ((not fn) nil)
+ ((function= fn #'excl::read-token) nil)
+ (t fn)))
+ #+ :common-lisp (get-macro-character char rt))
+
+
+;;;; Specialized PRINT-OBJECT for named readtables.
+
+;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
+;;; that specializes on READTABLE is actually forbidden. It's quite
+;;; likely to work (modulo package-locks) on most implementations,
+;;; though.
+
+;;; We don't need this on Allegro CL's as we hook into their
+;;; named-readtable facility, and they provide such a method already.
+#-allegro
+(without-package-lock (:common-lisp)
+ (defmethod print-object :around ((rt readtable) stream)
+ (let ((name (readtable-name rt)))
+ (if name
+ (print-unreadable-object (rt stream :type nil :identity t)
+ (format stream "~A ~S" :named-readtable name))
+ (call-next-method)))))
\ No newline at end of file
Added: trunk/lib/named-readtables/define-api.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/define-api.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,63 @@
+
+(in-package :named-readtables)
+
+(defmacro define-api (name lambda-list type-list &body body)
+ (flet ((parse-type-list (type-list)
+ (let ((pos (position '=> type-list)))
+ (assert pos () "You forgot to specify return type (`=>' missing.)")
+ (values (subseq type-list 0 pos)
+ `(values ,@(nthcdr (1+ pos) type-list) &optional)))))
+ (multiple-value-bind (body decls docstring)
+ (parse-body body :documentation t :whole `(define-api ,name))
+ (multiple-value-bind (arg-typespec value-typespec)
+ (parse-type-list type-list)
+ (multiple-value-bind (reqs opts rest keys)
+ (parse-ordinary-lambda-list lambda-list)
+ (declare (ignorable reqs opts rest keys))
+ `(progn
+ (declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
+ (locally
+ ;;; Muffle the annoying "&OPTIONAL and &KEY found in
+ ;;; the same lambda list" style-warning
+ #+sbcl (declare (sb-ext:muffle-conditions style-warning))
+ (defun ,name ,lambda-list
+ ,docstring
+
+ #+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
+
+ , at decls
+
+ ;; SBCL will interpret the ftype declaration as
+ ;; assertion and will insert type checks for us.
+ #-sbcl
+ (progn
+ ;; CHECK-TYPE required parameters
+ ,@(loop for req-arg in reqs
+ for req-type = (pop type-list)
+ do (assert req-type)
+ collect `(check-type ,req-arg ,req-type))
+
+ ;; CHECK-TYPE optional parameters
+ ,@(loop initially (assert (or (null opts)
+ (eq (pop type-list) '&optional)))
+ for (opt-arg . nil) in opts
+ for opt-type = (pop type-list)
+ do (assert opt-type)
+ collect `(check-type ,opt-arg ,opt-type))
+
+ ;; CHECK-TYPE rest parameter
+ ,@(when rest
+ (assert (eq (pop type-list) '&rest))
+ (let ((rest-type (pop type-list)))
+ (assert rest-type)
+ `((dolist (x ,rest)
+ (check-type x ,rest-type)))))
+
+ ;; CHECK-TYPE key parameters
+ ,@(loop initially (assert (or (null keys)
+ (eq (pop type-list) '&key)))
+ for ((keyword key-arg) . nil) in keys
+ for (nil key-type) = (find keyword type-list :key #'car)
+ collect `(check-type ,key-arg ,key-type)))
+
+ , at body))))))))
\ No newline at end of file
Added: trunk/lib/named-readtables/doc/named-readtables.html
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/doc/named-readtables.html Thu Oct 22 16:10:10 2009
@@ -0,0 +1,463 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
+<html>
+
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
+ <title>EDITOR-HINTS.NAMED-READTABLES</title>
+ <style type="text/css">
+ pre { padding:5px; background-color:#e0e0e0 }
+ h3, h4 { text-decoration: underline; }
+ a { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
+ a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
+ a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
+ a.none { text-decoration: none; padding: 0; }
+ a.none:visited { text-decoration: none; padding: 0; }
+ a.none:hover { text-decoration: none; border: none; padding: 0; }
+ a.none:focus { text-decoration: none; border: none; padding: 0; }
+ a.noborder { text-decoration: none; padding: 0; }
+ a.noborder:visited { text-decoration: none; padding: 0; }
+ a.noborder:hover { text-decoration: none; border: none; padding: 0; }
+ a.noborder:focus { text-decoration: none; border: none; padding: 0; }
+ pre.none { padding:5px; background-color:#ffffff }
+ </style>
+</head>
+
+<body bgcolor=white>
+
+<h2> EDITOR-HINTS.NAMED-READTABLES</h2>
+
+<h5> by Tobias C Rittweiler </h5>
+
+<font color=red>Download:</font> <br> <br>
+
+
+ <code>darcs get http://common-lisp.net/~trittweiler/darcs/editor-hints/named-readtables/</code> (to be changed)
+
+<br> <br><h3><a class=none name="contents">Contents</a></h3>
+<ol>
+ <li> <a href="#what_are_named-readtables?">What are Named-Readtables?</a>
+ <li> <a href="#notes_on_the_api">Notes on the API</a>
+ <li> <a href="#important_api_idiosyncrasies">Important API idiosyncrasies</a>
+ <li> <a href="#preregistered_readtables">Preregistered Readtables</a>
+ <li> <a href="#examples">Examples</a>
+ <li> <a href="#acknowledgements">Acknowledgements</a>
+
+
+ <li><a href="#dictionary">Dictionary</a>
+ <ol>
+ <li><a href="#COPY-NAMED-READTABLE"><code>COPY-NAMED-READTABLE</code></a>
+ <li><a href="#DEFREADTABLE"><code>DEFREADTABLE</code></a>
+ <li><a href="#ENSURE-READTABLE"><code>ENSURE-READTABLE</code></a>
+ <li><a href="#FIND-READTABLE"><code>FIND-READTABLE</code></a>
+ <li><a href="#IN-READTABLE"><code>IN-READTABLE</code></a>
+ <li><a href="#LIST-ALL-NAMED-READTABLES"><code>LIST-ALL-NAMED-READTABLES</code></a>
+ <li><a href="#MAKE-READTABLE"><code>MAKE-READTABLE</code></a>
+ <li><a href="#MERGE-READTABLES-INTO"><code>MERGE-READTABLES-INTO</code></a>
+ <li><a href="#NAMED-READTABLE-DESIGNATOR"><code>NAMED-READTABLE-DESIGNATOR</code></a>
+ <li><a href="#READER-MACRO-CONFLICT"><code>READER-MACRO-CONFLICT</code></a>
+ <li><a href="#READTABLE-DOES-ALREADY-EXIST"><code>READTABLE-DOES-ALREADY-EXIST</code></a>
+ <li><a href="#READTABLE-DOES-NOT-EXIST"><code>READTABLE-DOES-NOT-EXIST</code></a>
+ <li><a href="#READTABLE-NAME"><code>READTABLE-NAME</code></a>
+ <li><a href="#REGISTER-READTABLE"><code>REGISTER-READTABLE</code></a>
+ <li><a href="#RENAME-READTABLE"><code>RENAME-READTABLE</code></a>
+ <li><a href="#UNREGISTER-READTABLE"><code>UNREGISTER-READTABLE</code></a>
+
+ </ol>
+</ol> <br> <br><h3><a class=none name="what_are_named-readtables?">What are Named-Readtables?</a></h3>
+ Named-Readtables is a library that provides a namespace for readtables akin to the <br> already-existing namespace of packages. In particular:
+<ul>
+ <li>you can associate readtables with names, and retrieve readtables by names;</li>
+ <li>you can associate source files with readtable names, and be sure that the <br> right readtable is active when compiling/loading the file;</li>
+ <li>similiarly, your development environment now has a chance to automatically <br> determine what readtable should be active while processing source forms on <br> interactive commands. (E.g. think of `C-c C-c' in Slime [yet to be done])</li>
+</ul>
+ Additionally, it also attempts to become a facility for using readtables in a <br> <u>modular</u> way. In particular:
+<ul>
+ <li>it provides a macro to specify the content of a readtable at a glance;</li>
+ <li>it makes it possible to use multiple inheritance between readtables.</li>
+</ul>
+<br> <br><h3><a class=none name="notes_on_the_api">Notes on the API</a></h3>
+ The <code>API</code> heavily imitates the <code>API</code> of packages. This has the nice property that any <br> experienced Common Lisper will take it up without effort.
+<br><br>
+ <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_defpkg.htm"><code>DEFPACKAGE</code></a></code>
+<br><br>
+ <code><a href="#In-Readtable"><code>IN-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_in_pkg.htm"><code>IN-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Merge-Readtables-Into"><code>MERGE-READTABLES-INTO</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_use_pk.htm"><code>USE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Make-Readtable"><code>MAKE-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_mk_pkg.htm"><code>MAKE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Unregister-Readtable"><code>UNREGISTER-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_del_pk.htm"><code>DELETE-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Rename-Readtable"><code>RENAME-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_rn_pkg.htm"><code>RENAME-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Find-Readtable"><code>FIND-READTABLE</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_find_p.htm"><code>FIND-PACKAGE</code></a></code>
+<br><br>
+ <code><a href="#Readtable-Name"><code>READTABLE-NAME</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_pkg_na.htm"><code>PACKAGE-NAME</code></a></code>
+<br><br>
+ <code><a href="#List-All-Named-Readtables"><code>LIST-ALL-NAMED-READTABLES</code></a></code> - <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_list_a.htm"><code>LIST-ALL-PACKAGES</code></a></code>
+<br> <br><h3><a class=none name="important_api_idiosyncrasies">Important API idiosyncrasies</a></h3>
+ There are three major differences between the <code>API</code> of Named-Readtables, and the <code>API</code> <br> of packages.
+<br><br>
+ <code>1.</code> Readtable names are symbols not strings.
+<br><br>
+ Time has shown that the fact that packages are named by strings causes severe <br> headache because of the potential of package names colliding with each other.
+<br><br>
+ Hence, readtables are named by symbols lest to make the situation worse than it <br> already is. Consequently, readtables named <code>CL-ORACLE:SQL-SYNTAX</code> and <br> <code>CL-MYSQL:SQL-SYNTAX</code> can happily coexist next to each other. Or, taken to an extreme, <br> <code>SCHEME:SYNTAX</code> and <code>ELISP:SYNTAX.</code>
+<br><br>
+ If, for example to duly signify the importance of your cool readtable hack, you <br> really think it deserves a global name, you can always resort to keywords.
+<br><br>
+ <code>2.</code> The inheritance is resolved statically, not dynamically.
+<br><br>
+ A package that uses another package will have access to all the other <br> package's exported symbols, even to those that will be added after its <br> definition. I.e. the inheritance is resolved at run-time, that is dynamically.
+<br><br>
+ Unfortunately, we cannot do the same for readtables in a portable manner.
+<br><br>
+ Therefore, we do not talk about "using" another readtable but about <br> "merging" the other readtable's definition into the readtable we are <br> going to define. I.e. the inheritance is resolved once at definition time, that is <br> statically.
+<br><br>
+ (Such merging can more or less be implemented portably albeit at a certain cost. <br> Most of the time, this cost manifests itself at the time a readtable is defined, <br> i.e. once at compile-time, so it may not bother you. Nonetheless, we provide extra <br> support for Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your <br> implementation of choice are welcome, of course.)
+<br><br>
+ <code>3.</code> <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> does not have compile-time effects.
+<br><br>
+ If you define a package via <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_defpkg.htm"><code>DEFPACKAGE</code></a>,</code> you can make that package the currently <br> active package for the subsequent compilation of the same file via <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/m_in_pkg.htm"><code>IN-PACKAGE</code></a>.</code> The <br> same is, however, not true for <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> and <code><a href="#In-Readtable"><code>IN-READTABLE</code></a></code> for the following <br> reason:
+<br><br>
+ It's unlikely that the need for special reader-macros arises for a problem <br> which can be solved in just one file. Most often, you're going to define the <br> reader macro functions, and set up the corresponding readtable in an extra file.
+<br><br>
+ If <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> had compile-time effects, you'd have to wrap each definition <br> of a reader-macro function in an <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a></code> to make its definition available at <br> compile-time. Because that's simply not the common case, <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> does not <br> have a compile-time effect.
+<br><br>
+ If you want to use a readtable within the same file as its definition, wrap the <br> <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> and the reader-macro function definitions in an explicit <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a>.</code>
+<br> <br><h3><a class=none name="preregistered_readtables">Preregistered Readtables</a></h3>
+ - <code>NIL,</code> <code>:STANDARD,</code> and <code>:COMMON-LISP</code> designate the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard_readtable">standard readtable</a></i>.
+<br><br>
+ - <code>:MODERN</code> designates a <u>case-preserving</u> <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard-readtable">standard-readtable</a></i>.
+<br><br>
+ - <code>:CURRENT</code> designates the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#current_readtable">current readtable</a></i>.
+<br> <br><h3><a class=none name="examples">Examples</a></h3>
+<pre>
+ (defreadtable elisp:syntax
+ (:merge :standard)
+ (:macro-char #\? #'elisp::read-character-literal t)
+ (:macro-char #\[ #'elisp::read-vector-literal t)
+ ...
+ (:case :preserve))
+
+ (defreadtable scheme:syntax
+ (:merge :standard)
+ (:macro-char #\[ #'(lambda (stream char)
+ (read-delimited-list #\] stream)))
+ (:macro-char #\# :dispatch)
+ (:dispatch-macro-char #\# #\t #'scheme::read-#t)
+ (:dispatch-macro-char #\# #\f #'scheme::read-#f)
+ ...
+ (:case :preserve))
+
+ (in-readtable elisp:syntax)
+
+ ...
+
+ (in-readtable scheme:syntax)
+
+ ...
+</pre>
+
+<br> <br><h3><a class=none name="acknowledgements">Acknowledgements</a></h3>
+ Thanks to Robert Goldman for making me want to write this library.
+<br><br>
+ Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David <br> Crawford, and Pascal Costanza for being early adopters, providing comments and <br> bugfixes.
+<br> <br>
+<br> <br><h3><a class=none name="dictionary">Dictionary</a></h3>
+
+
+<!-- Entry for COPY-NAMED-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='COPY-NAMED-READTABLE'><b>copy-named-readtable</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Like <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_cp_rdt.htm"><code>COPY-READTABLE</code></a></code> but takes a <code><a href="#Named-Readtable-Designator"><code>NAMED-READTABLE-DESIGNATOR</code></a></code> as argument.
+
+
+</blockquote>
+
+<!-- End of entry for COPY-NAMED-READTABLE -->
+
+
+<!-- Entry for DEFREADTABLE -->
+
+<p><br>[Macro]<br><a class=none name='DEFREADTABLE'><b>defreadtable</b> <i>name &body options</i> => <i>result</i></a><br><br> Description:
+<blockquote>
+
+Define a new named readtable, whose name is given by the symbol <i>name</i>. Or, if <br> a readtable is already registered under that name, redefine that one.
+<br><br>
+The readtable can be populated using the following <i>options</i>:
+<br><br>
+ <code>(:MERGE</code> <i>readtable-designators</i>+)
+<br><br>
+ Merge the readtables designated into the new readtable being defined as per <br> <code><a href="#Merge-Readtables-Into"><code>MERGE-READTABLES-INTO</code></a>.</code>
+<br><br>
+ If no <code>:MERGE</code> clause is given, an empty readtable is used. See <code><a href="#Make-Readtable"><code>MAKE-READTABLE</code></a>.</code>
+<br><br>
+ <code>(:FUZE</code> <i>readtable-designators</i>+)
+<br><br>
+ Like <code>:MERGE</code> except:
+<br><br>
+ Error conditions of type <code><a href="#Reader-Macro-Conflict"><code>READER-MACRO-CONFLICT</code></a></code> that are signaled during the merge <br> operation will be silently <u>continued</u>. It follows that reader macros in earlier <br> entries will be overwritten by later ones.
+<br><br>
+ <code>(:DISPATCH-MACRO-CHAR</code> <i>macro-char</i> <i>sub-char</i> <i>function</i>)
+<br><br>
+ Define a new sub character <i>sub-char</i> for the dispatching macro character <br> <i>macro-char</i>, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set__1.htm"><code>SET-DISPATCH-MACRO-CHARACTER</code></a>.</code> You probably have to define <br> <i>macro-char</i> as a dispatching macro character by the following option first.
+<br><br>
+ <code>(:MACRO-CHAR</code> <i>macro-char</i> <i>function</i> [<i>non-terminating-p</i>])
+<br><br>
+ Define a new macro character in the readtable, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set_ma.htm"><code>SET-MACRO-CHARACTER</code></a>.</code> If <br> <i>function</i> is the keyword <code>:DISPATCH,</code> <i>macro-char</i> is made a dispatching <br> macro character, per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_mk_dis.htm"><code>MAKE-DISPATCH-MACRO-CHARACTER</code></a>.</code>
+<br><br>
+ <code>(:SYNTAX-FROM</code> <i>from-readtable-designator</i> <i>from-char</i> <i>to-char</i>)
+<br><br>
+ Set the character syntax of <i>to-char</i> in the readtable being defined to the <br> same syntax as <i>from-char</i> as per <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/f_set_sy.htm"><code>SET-SYNTAX-FROM-CHAR</code></a>.</code>
+<br><br>
+ <code>(:CASE</code> <i>case-mode</i>)
+<br><br>
+ Defines the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_c.htm#case_sensitivity_mode">case sensitivity mode</a></i> of the resulting readtable.
+<br><br>
+Any number of option clauses may appear. The options are grouped by their type, but <br> in each group the order the options appeared textually is preserved. The following <br> groups exist and are executed in the following order: <code>:MERGE</code> and <code>:FUZE</code> (one group), <br> <code>:CASE,</code> <code>:MACRO-CHAR</code> and <code>:DISPATCH-MACRO-CHAR</code> (one group), finally <code>:SYNTAX-FROM.</code>
+<br><br>
+Notes:
+<br><br>
+ The readtable is defined at load-time. If you want to have it available at <br> compilation time <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a__.htm"><code>-</code></a>-</code> say to use its reader-macros in the same file as its definition <br> <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a__.htm"><code>-</code></a>-</code> you have to wrap the <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> form in an explicit <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/s_eval_w.htm"><code>EVAL-WHEN</code></a>.</code>
+<br><br>
+ On redefinition, the target readtable is made empty first before it's refilled <br> according to the clauses.
+<br><br>
+ <code>NIL,</code> <code>:STANDARD,</code> <code>:COMMON-LISP,</code> <code>:MODERN,</code> and <code>:CURRENT</code> are preregistered readtable <br> names.
+
+
+</blockquote>
+
+<!-- End of entry for DEFREADTABLE -->
+
+
+<!-- Entry for ENSURE-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='ENSURE-READTABLE'><b>ensure-readtable</b> <i>name <tt>&optional</tt> default</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>default</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Looks up the readtable specified by <i>name</i> and returns it if it's found. <br> If it is not found, it registers the readtable designated by <i>default</i> under <br> the name represented by <i>name</i>; or if no default argument is given, it signals <br> an error of type <code><a href="#Readtable-Does-Not-Exist"><code>READTABLE-DOES-NOT-EXIST</code></a></code> instead.
+
+
+</blockquote>
+
+<!-- End of entry for ENSURE-READTABLE -->
+
+
+<!-- Entry for FIND-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='FIND-READTABLE'><b>find-readtable</b> <i>name</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>(OR
+ READTABLE
+ NULL)</code></blockquote> Description:
+<blockquote>
+
+Looks for the readtable specified by <i>name</i> and returns it if it is found. <br> Returns <code>NIL</code> otherwise.
+
+
+</blockquote>
+
+<!-- End of entry for FIND-READTABLE -->
+
+
+<!-- Entry for IN-READTABLE -->
+
+<p><br>[Macro]<br><a class=none name='IN-READTABLE'><b>in-readtable</b> <i>name</i> => <i>result</i></a><br><br> Description:
+<blockquote>
+
+Set <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/v_rdtabl.htm"><code>*READTABLE*</code></a></code> to the readtable referred to by the symbol <i>name</i>.
+
+
+</blockquote>
+
+<!-- End of entry for IN-READTABLE -->
+
+
+<!-- Entry for LIST-ALL-NAMED-READTABLES -->
+
+<p><br>[Function]<br><a class=none name='LIST-ALL-NAMED-READTABLES'><b>list-all-named-readtables</b> <i></i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>result</i>: <code>LIST</code></blockquote> Description:
+<blockquote>
+
+Returns a list of all registered readtables. The returned list is guaranteed to be <br> fresh, but may contain duplicates.
+
+
+</blockquote>
+
+<!-- End of entry for LIST-ALL-NAMED-READTABLES -->
+
+
+<!-- Entry for MAKE-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='MAKE-READTABLE'><b>make-readtable</b> <i><tt>&optional</tt> name <tt>&key</tt> merge</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>merge</i>: <code>LIST</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Creates and returns a new readtable under the specified <i>name</i>.
+<br><br>
+<i>merge</i> takes a list of <code><a href="#Named-Readtable-Designators"><code>NAMED-READTABLE-DESIGNATORS</code></a></code> and specifies the <br> readtables the new readtable is created from. (See the <code>:MERGE</code> clause of <code><a href="#Defreadtable"><code>DEFREADTABLE</code></a></code> <br> for details.)
+<br><br>
+If <i>merge</i> is <code>NIL,</code> an empty readtable is used instead.
+<br><br>
+If <i>name</i> is not given, an anonymous empty readtable is returned.
+<br><br>
+Notes:
+<br><br>
+ An empty readtable is a readtable where each character's syntax is the same as <br> in the <i><a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_s.htm#standard_readtable">standard readtable</a></i> except that each macro character has been made a <br> constituent. Basically: whitespace stays whitespace, everything else is constituent.
+
+
+</blockquote>
+
+<!-- End of entry for MAKE-READTABLE -->
+
+
+<!-- Entry for MERGE-READTABLES-INTO -->
+
+<p><br>[Function]<br><a class=none name='MERGE-READTABLES-INTO'><b>merge-readtables-into</b> <i>result-readtable <tt>&rest</tt> named-readtables</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>result-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>named-readtables</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Copy the contents of each readtable in <i>named-readtables</i> into <br> <i>result-table</i>.
+<br><br>
+If a macro character appears in more than one of the readtables, i.e. if a conflict <br> is discovered during the merge, an error of type <code><a href="#Reader-Macro-Conflict"><code>READER-MACRO-CONFLICT</code></a></code> is signaled.
+
+
+</blockquote>
+
+<!-- End of entry for MERGE-READTABLES-INTO -->
+
+
+<!-- Entry for NAMED-READTABLE-DESIGNATOR -->
+
+<p><br>[Type]<br><a class=none name='NAMED-READTABLE-DESIGNATOR'><b>named-readtable-designator</b></a><br><br> Description:
+<blockquote>
+
+Either a symbol or a readtable itself.
+
+
+</blockquote>
+
+<!-- End of entry for NAMED-READTABLE-DESIGNATOR -->
+
+
+<!-- Entry for READER-MACRO-CONFLICT -->
+
+<p><br>[Condition type]<br><a class=none name='READER-MACRO-CONFLICT'><b>reader-macro-conflict</b></a><br><br> Description:
+<blockquote>
+
+Continuable.
+<br><br>
+This condition is signaled during the merge process if a) a reader macro (be it a <br> macro character or the sub character of a dispatch macro character) is both present <br> in the source as well as the target readtable, and b) if and only if the two <br> respective reader macro functions differ.
+
+
+</blockquote>
+
+<!-- End of entry for READER-MACRO-CONFLICT -->
+
+
+<!-- Entry for READTABLE-DOES-ALREADY-EXIST -->
+
+<p><br>[Condition type]<br><a class=none name='READTABLE-DOES-ALREADY-EXIST'><b>readtable-does-already-exist</b></a><br><br> Description:
+<blockquote>
+
+Continuable.
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-DOES-ALREADY-EXIST -->
+
+
+<!-- Entry for READTABLE-DOES-NOT-EXIST -->
+
+<p><br>[Condition type]<br><a class=none name='READTABLE-DOES-NOT-EXIST'><b>readtable-does-not-exist</b></a><br><br>
+<blockquote>
+
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-DOES-NOT-EXIST -->
+
+
+<!-- Entry for READTABLE-NAME -->
+
+<p><br>[Function]<br><a class=none name='READTABLE-NAME'><b>readtable-name</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>SYMBOL</code></blockquote> Description:
+<blockquote>
+
+Returns the name of the readtable designated by <i>named-readtable</i>, or <code>NIL.</code>
+
+
+</blockquote>
+
+<!-- End of entry for READTABLE-NAME -->
+
+
+<!-- Entry for REGISTER-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='REGISTER-READTABLE'><b>register-readtable</b> <i>name readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>name</i>: <code>SYMBOL</code></blockquote><blockquote><i>readtable</i>: <code>READTABLE</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Associate <i>readtable</i> with <i>name</i>. Returns the readtable.
+
+
+</blockquote>
+
+<!-- End of entry for REGISTER-READTABLE -->
+
+
+<!-- Entry for RENAME-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='RENAME-READTABLE'><b>rename-readtable</b> <i>old-name new-name</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>old-name</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>new-name</i>: <code>SYMBOL</code></blockquote><blockquote><i>result</i>: <code>READTABLE</code></blockquote> Description:
+<blockquote>
+
+Replaces the associated name of the readtable designated by <i>old-name</i> with <br> <i>new-name</i>. If a readtable is already registered under <i>new-name</i>, an <br> error of type <code><a href="#Readtable-Does-Already-Exist"><code>READTABLE-DOES-ALREADY-EXIST</code></a></code> is signaled.
+
+
+</blockquote>
+
+<!-- End of entry for RENAME-READTABLE -->
+
+
+<!-- Entry for UNREGISTER-READTABLE -->
+
+<p><br>[Function]<br><a class=none name='UNREGISTER-READTABLE'><b>unregister-readtable</b> <i>named-readtable</i> => <i>result</i></a><br><br> Argument and Values:<blockquote><i>named-readtable</i>: <code>(OR
+ READTABLE
+ SYMBOL)</code></blockquote><blockquote><i>result</i>: <code>(MEMBER T
+ NIL)</code></blockquote> Description:
+<blockquote>
+
+Remove the association of <i>named-readtable</i>. Returns <code><a href="http://www.lispworks.com/reference/HyperSpec/Body/a_t.htm"><code>T</code></a></code> if successfull, <code>NIL</code> <br> otherwise.
+
+
+</blockquote>
+
+<!-- End of entry for UNREGISTER-READTABLE -->
+
+
+<hr>
+<p>
+This documentation was generated on 2009-9-29 from a Lisp image using some home-brewn,
+duct-taped, <br> evolutionary hacked extension of Edi Weitz'
+<a href="http://weitz.de/documentation-template/">DOCUMENTATION-TEMPLATE</a>.
+</p>
+
+</body>
+</html>
\ No newline at end of file
Added: trunk/lib/named-readtables/named-readtables.asd
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/named-readtables.asd Thu Oct 22 16:10:10 2009
@@ -0,0 +1,50 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
+
+#+sbcl
+(defmethod asdf:perform :around ((o asdf:compile-op)
+ (c asdf::named-readtables-source-file))
+ (let ((sb-ext:*derive-function-types* t))
+ (call-next-method)))
+
+
+(asdf:defsystem :named-readtables
+ :description "Library that creates a namespace for named readtable akin to the namespace of packages."
+ :author "Tobias C. Rittweiler <trittweiler at common-lisp.net>"
+ :version "1.0 (unpublished so far)"
+ :licence "BSD"
+ :default-component-class asdf::named-readtables-source-file
+ :components
+ ((:file "package")
+ (:file "utils" :depends-on ("package"))
+ (:file "define-api" :depends-on ("package" "utils"))
+ (:file "cruft" :depends-on ("package" "utils"))
+ (:file "named-readtables" :depends-on ("package" "utils" "cruft" "define-api"))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :named-readtables))))
+ (asdf:operate 'asdf:load-op :named-readtables-test)
+ (asdf:operate 'asdf:test-op :named-readtables-test))
+
+
+(asdf:defsystem :named-readtables-test
+ :description "Test suite for the Named-Readtables library."
+ :author "Tobias C. Rittweiler <trittweiler at common-lisp.net>"
+ :depends-on (:named-readtables)
+ :components
+ ((:module tests
+ :default-component-class asdf::named-readtables-source-file
+ :serial t
+ :components
+ ((:file "package")
+ (:file "rt" :depends-on ("package"))
+ (:file "tests" :depends-on ("package" "rt"))))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system
+ :named-readtables-test))))
+ (let ((*package* (find-package :named-readtables-test)))
+ (funcall (intern (string '#:do-tests) *package*))))
\ No newline at end of file
Added: trunk/lib/named-readtables/named-readtables.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/named-readtables.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,527 @@
+;;;; -*- Mode:Lisp -*-
+;;;;
+;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;; Copyright (c) 2007, Robert P. Goldman <rpgoldman at sift.info> 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.
+
+ (: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.
+
+ (: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 :FUZE (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))) ; quotify
+ ((: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) 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))
+
+
+(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-table'.
+
+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 "~@<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,
+and b) if and only if 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) ; if this fails, there's a bug in readtable iterators.
+ (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))))
+
+
+;;;;; 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.)
+
+
+(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)))
+
+(defun signal-suspicious-registration-warning (name-expr readtable-expr)
+ (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"
+ (list name-expr name-expr) readtable-expr))
+
+(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.)
+
+ (define-compiler-macro register-readtable (&whole form name readtable)
+ (when (constant-standard-readtable-expression-p readtable)
+ (signal-suspicious-registration-warning name readtable))
+ 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))
+
+
Added: trunk/lib/named-readtables/package.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/package.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,193 @@
+
+(in-package :common-lisp-user)
+
+(defpackage :editor-hints.named-readtables
+ (:use :common-lisp)
+ (:nicknames :named-readtables)
+ (:export
+ #:defreadtable
+ #:in-readtable
+ #:make-readtable
+ #:merge-readtables-into
+ #:find-readtable
+ #:ensure-readtable
+ #:rename-readtable
+ #:readtable-name
+ #:register-readtable
+ #:unregister-readtable
+ #:copy-named-readtable
+ #:list-all-named-readtables
+ ;; Types
+ #:named-readtable-designator
+ ;; Conditions
+ #:reader-macro-conflict
+ #:readtable-does-already-exist
+ #:readtable-does-not-exist
+ )
+ (:documentation
+ "
+* What are Named-Readtables?
+
+ Named-Readtables is a library that provides a namespace for
+ readtables akin to the already-existing namespace of packages. In
+ particular:
+
+ * you can associate readtables with names, and retrieve
+ readtables by names;
+
+ * you can associate source files with readtable names, and be
+ sure that the right readtable is active when compiling/loading
+ the file;
+
+ * similiarly, your development environment now has a chance to
+ automatically determine what readtable should be active while
+ 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
+ a localized way.
+
+ Additionally, it also attempts to become a facility for using
+ readtables in a _modular_ way. In particular:
+
+ * it provides a macro to specify the content of a readtable at a
+ glance;
+
+ * it makes it possible to use multiple inheritance between readtables.
+
+* Notes on the API
+
+ The API heavily imitates the API of packages. This has the nice
+ property that any experienced Common Lisper will take it up without
+ effort.
+
+ DEFREADTABLE - DEFPACKAGE
+
+ IN-READTABLE - IN-PACKAGE
+
+ MERGE-READTABLES-INTO - USE-PACKAGE
+
+ MAKE-READTABLE - MAKE-PACKAGE
+
+ UNREGISTER-READTABLE - DELETE-PACKAGE
+
+ RENAME-READTABLE - RENAME-PACKAGE
+
+ FIND-READTABLE - FIND-PACKAGE
+
+ READTABLE-NAME - PACKAGE-NAME
+
+ LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
+
+* Important API idiosyncrasies
+
+ There are three major differences between the API of Named-Readtables,
+ and the API of packages.
+
+ 1. Readtable names are symbols not strings.
+
+ Time has shown that the fact that packages are named by
+ strings causes severe headache because of the potential of
+ package names colliding with each other.
+
+ Hence, readtables are named by symbols lest to make the
+ situation worse than it already is. Consequently, readtables
+ named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can
+ happily coexist next to each other. Or, taken to an extreme,
+ SCHEME:SYNTAX and ELISP:SYNTAX.
+
+ If, for example to duly signify the importance of your cool
+ readtable hack, you really think it deserves a global name,
+ you can always resort to keywords.
+
+ 2. The inheritance is resolved statically, not dynamically.
+
+ A package that uses another package will have access to all
+ the other package's exported symbols, even to those that will
+ be added after its definition. I.e. the inheritance is
+ resolved at run-time, that is dynamically.
+
+ Unfortunately, we cannot do the same for readtables in a
+ portable manner.
+
+ Therefore, we do not talk about \"using\" another readtable
+ but about \"merging\" the other readtable's definition into
+ the readtable we are going to define. I.e. the inheritance is
+ resolved once at definition time, that is statically.
+
+ (Such merging can more or less be implemented portably albeit
+ at a certain cost. Most of the time, this cost manifests
+ itself at the time a readtable is defined, i.e. once at
+ compile-time, so it may not bother you. Nonetheless, we
+ provide extra support for Sbcl, ClozureCL, and AllegroCL at
+ the moment. Patches for your implementation of choice are
+ welcome, of course.)
+
+ 3. DEFREADTABLE does not have compile-time effects.
+
+ If you define a package via DEFPACKAGE, you can make that
+ package the currently active package for the subsequent
+ compilation of the same file via IN-PACKAGE. The same is,
+ however, not true for DEFREADTABLE and IN-READTABLE for the
+ following reason:
+
+ It's unlikely that the need for special reader-macros arises
+ for a problem which can be solved in just one file. Most
+ often, you're going to define the reader macro functions, and
+ set up the corresponding readtable in an extra file.
+
+ If DEFREADTABLE had compile-time effects, you'd have to wrap
+ each definition of a reader-macro function in an EVAL-WHEN to
+ make its definition available at compile-time. Because that's
+ simply not the common case, DEFREADTABLE does not have a
+ compile-time effect.
+
+ If you want to use a readtable within the same file as its
+ definition, wrap the DEFREADTABLE and the reader-macro
+ function definitions in an explicit EVAL-WHEN.
+
+* Preregistered Readtables
+
+ - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
+
+ - :MODERN designates a _case-preserving_ /standard-readtable/.
+
+ - :CURRENT designates the /current readtable/.
+
+* Examples
+
+ > (defreadtable elisp:syntax
+ > (:merge :standard)
+ > (:macro-char #\\? #'elisp::read-character-literal t)
+ > (:macro-char #\\[ #'elisp::read-vector-literal t)
+ > ...
+ > (:case :preserve))
+ >
+ > (defreadtable scheme:syntax
+ > (:merge :standard)
+ > (:macro-char #\\[ #'(lambda (stream char)
+ > (read-delimited-list #\\] stream)))
+ > (:macro-char #\\# :dispatch)
+ > (:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
+ > (:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
+ > ...
+ > (:case :preserve))
+ >
+ > (in-readtable elisp: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, David Crawford, and Pascal Costanza for being early adopters,
+ providing comments and bugfixes.
+"))
+
+(pushnew :named-readtables *features*)
\ No newline at end of file
Added: trunk/lib/named-readtables/tests/package.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/tests/package.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,12 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defpackage :named-readtables-test
+ (:use :cl :named-readtables)
+ (:import-from :named-readtables
+ #:dispatch-macro-char-p
+ #:do-readtable
+ #:ensure-function
+ #:ensure-dispatch-macro-character
+ #:function=))
\ No newline at end of file
Added: trunk/lib/named-readtables/tests/rt.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/tests/rt.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,256 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+;; (defpackage :rt
+;; (:use #:cl)
+;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+;; #:rem-all-tests #:rem-test)
+;; (:documentation "The MIT regression tester"))
+
+;; (in-package :rt)
+
+(in-package :named-readtables-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+ "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+ "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters."
+ (cond
+ ((eq x y) t)
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (aref x) (aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (finish-output s)
+ (null pending))))
Added: trunk/lib/named-readtables/tests/tests.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/tests/tests.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,322 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :named-readtables-test)
+
+(defun map-alist (car-fn cdr-fn alist)
+ (mapcar #'(lambda (entry)
+ (cons (funcall car-fn (car entry))
+ (funcall cdr-fn (cdr entry))))
+ alist))
+
+(defun length=1 (list)
+ (and list (null (cdr list))))
+
+(defmacro signals-condition-p (name &body body)
+ `(handler-case (prog1 nil , at body)
+ (,(second name) () t)))
+
+(defmacro continue-condition (name &body body)
+ `(handler-bind ((,(second name) #'continue))
+ , at body))
+
+(defun read-with-readtable (name string)
+ (let ((*package* '#.*package*)
+ (*readtable* (find-readtable name)))
+ (values (read-from-string string))))
+
+(defun random-named-readtable ()
+ (let ((readtables (list-all-named-readtables)))
+ (nth (random (length readtables)) readtables)))
+
+
+(defun readtable-content (named-readtable-designator)
+ (let ((readtable (ensure-readtable named-readtable-designator))
+ (result '()))
+ ;; Make sure to canonicalize the order and function designators so
+ ;; we can compare easily.
+ (do-readtable ((char reader-fn ntp disp? table) readtable)
+ (setq table (sort (copy-list table) #'char< :key #'car))
+ (push (list* char
+ (ensure-function reader-fn)
+ ntp
+ (and disp? (list (map-alist #'identity
+ #'ensure-function
+ table))))
+ result))
+ (sort result #'char< :key #'car)))
+
+(defun readtable= (rt1 rt2)
+ (tree-equal (readtable-content rt1) (readtable-content rt2)
+ :test #'(lambda (x y)
+ (if (and (functionp x) (functionp y))
+ (function= x y)
+ (eql x y)))))
+
+
+(defun read-A (stream c)
+ (declare (ignore stream c))
+ :a)
+
+(defun read-A-as-X (stream c)
+ (declare (ignore stream c))
+ :x)
+
+(defun read-B (stream c)
+ (declare (ignore stream c))
+ :b)
+
+(defun read-sharp-paren (stream c n)
+ (declare (ignore stream c n))
+ 'sharp-paren)
+
+(defun read-C (stream c)
+ (declare (ignore stream c))
+ :c)
+
+(defreadtable A
+ (:macro-char #\A #'read-A))
+
+(defreadtable A-as-X
+ (:macro-char #\A #'read-A-as-X))
+
+(defreadtable B
+ (:macro-char #\B #'read-B))
+
+(defreadtable C
+ (:macro-char #\C #'read-C))
+
+(defreadtable A+B+C
+ (:merge A B C))
+
+(defreadtable standard+A+B+C
+ (:merge :standard A+B+C))
+
+(defreadtable sharp-paren
+ (:macro-char #\# :dispatch)
+ (:dispatch-macro-char #\# #\( #'read-sharp-paren))
+
+
+(deftest cruft.1
+ (function= (get-macro-character #\" (copy-readtable nil))
+ (get-macro-character #\" (copy-readtable nil)))
+ t)
+
+(deftest cruft.2
+ (dispatch-macro-char-p #\# (find-readtable :standard))
+ t)
+
+(deftest cruft.3
+ (dispatch-macro-char-p #\# (make-readtable))
+ nil)
+
+(deftest cruft.4
+ (let ((rt (copy-named-readtable :standard)))
+ (ensure-dispatch-macro-character #\# t rt)
+ (dispatch-macro-char-p #\# rt))
+ t)
+
+(deftest cruft.5
+ (let ((rt (make-readtable)))
+ (values
+ (dispatch-macro-char-p #\$ rt)
+ (ensure-dispatch-macro-character #\$ t rt)
+ (dispatch-macro-char-p #\$ rt)))
+ nil t t)
+
+(deftest cruft.6
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (ensure-dispatch-macro-character #\$ t rt)
+ (set-dispatch-macro-character #\$ #\# fn rt)
+ (values
+ (eq fn (get-dispatch-macro-character #\$ #\# rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+(deftest cruft.7
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (set-macro-character #\$ fn t rt)
+ (values
+ (eq fn (get-macro-character #\$ rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+
+(deftest standard.1
+ (read-with-readtable :standard "ABC")
+ ABC)
+
+(deftest standard.2
+ (read-with-readtable :standard "(A B C)")
+ (A B C))
+
+(deftest standard.3
+ (let ((x (find-readtable nil))
+ (y (find-readtable :standard))
+ (z (find-readtable :common-lisp)))
+ (and (eq x y) (eq y z)))
+ t)
+
+
+(deftest modern.1
+ (read-with-readtable :modern "FooF")
+ |FooF|)
+
+
+(deftest empty.1
+ (null (readtable-content (make-readtable)))
+ t)
+
+(deftest empty.2
+ (readtable= (merge-readtables-into (make-readtable) :standard)
+ (find-readtable :standard))
+ t)
+
+(deftest empty.3
+ (let ((rt (copy-named-readtable :standard)))
+ (readtable= (merge-readtables-into (make-readtable) rt)
+ (merge-readtables-into rt (make-readtable))))
+ t)
+
+
+(deftest basics.1
+ (read-with-readtable 'A "A")
+ :a)
+
+(deftest basics.2
+ (read-with-readtable 'A-as-X "A")
+ :x)
+
+(deftest basics.3
+ (read-with-readtable 'A "B")
+ B)
+
+(deftest basics.4
+ (read-with-readtable 'A "(A B C)")
+ |(|)
+
+
+(deftest unregister.1
+ (let ((rt (find-readtable 'A)))
+ (register-readtable 'does-not-exist rt)
+ (values
+ (and (find-readtable 'does-not-exist) t)
+ (unregister-readtable 'does-not-exist)
+ (and (find-readtable 'does-not-exist) t)))
+ t t nil)
+
+
+(deftest name.1
+ (let ((rt (random-named-readtable)))
+ (eq rt (find-readtable (readtable-name rt))))
+ t)
+
+(deftest ensure.1
+ (unwind-protect
+ (let* ((x (ensure-readtable 'does-not-exist (find-readtable 'A)))
+ (y (find-readtable 'A))
+ (z (find-readtable 'does-not-exist)))
+ (and (eq x y) (eq y z)))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+
+(deftest merge.1
+ (values
+ (read-with-readtable 'A+B+C "A")
+ (read-with-readtable 'A+B+C "B")
+ (read-with-readtable 'A+B+C "C"))
+ :a :b :c)
+
+(deftest merge.2
+ (read-with-readtable 'standard+A+B+C "(A B C)")
+ (:a :b :c))
+
+(deftest merge.3
+ (read-with-readtable 'standard+A+B+C "#(A B C)")
+ #(:a :b :c))
+
+(deftest merge.4
+ (let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
+ :standard)))
+ (readtable= 'standard+A+B+C A+B+C+standard))
+ t)
+
+
+(deftest rename.1
+ (unwind-protect
+ (progn (make-readtable 'A* :merge '(A))
+ (rename-readtable 'A* 'A**)
+ (values (and (find-readtable 'A*) t)
+ (and (find-readtable 'A**) t)))
+ (unregister-readtable 'A*)
+ (unregister-readtable 'A**))
+ nil
+ t)
+
+
+(deftest reader-macro-conflict.1
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A 'A-as-X))
+ t)
+
+(deftest reader-macro-conflict.2
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard :standard))
+ nil)
+
+(deftest reader-macro-conflict.3
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A+B+C 'A))
+ nil)
+
+(deftest reader-macro-conflict.4
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard 'sharp-paren))
+ t)
+
+
+(deftest readtable-does-not-exist.1
+ (signals-condition-p 'readtable-does-not-exist
+ (ensure-readtable 'does-not-exist))
+ t)
+
+
+(deftest readtable-does-already-exist.1
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.2
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.3
+ (let ((rt (make-readtable 'does-not-exist :merge '(:standard A B))))
+ (declare (ignore rt))
+ (unwind-protect
+ (read-with-readtable (continue-condition 'readtable-does-already-exist
+ (make-readtable 'does-not-exist
+ :merge '(:standard A C)))
+
+ "(A B C)")
+ (unregister-readtable 'does-not-exist)))
+ (:a B :c))
+
+
+(deftest defreadtable.1
+ (unwind-protect
+ (signals-condition-p 'reader-macro-conflict
+ (eval `(defreadtable does-not-exist (:merge A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+(deftest defreadtable.2
+ (unwind-protect
+ (signals-condition-p 't
+ (eval `(defreadtable does-not-exist (:fuze A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ nil)
+
Added: trunk/lib/named-readtables/utils.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/named-readtables/utils.lisp Thu Oct 22 16:10:10 2009
@@ -0,0 +1,245 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler <tcr at freebits.de>
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro without-package-lock ((&rest package-names) &body body)
+ (declare (ignorable package-names))
+ #+clisp
+ (return-from without-package-lock
+ `(ext:without-package-lock (, at package-names) , at body))
+ #+lispworks
+ (return-from without-package-lock
+ `(let ((hcl:*packages-for-warn-on-redefinition*
+ (set-difference hcl:*packages-for-warn-on-redefinition*
+ '(, at package-names)
+ :key (lambda (package-designator)
+ (if (packagep package-designator)
+ (package-name package-designator)
+ package-designator))
+ :test #'string=)))
+ , at body))
+ `(progn , at body))
+
+;;; Taken from SWANK (which is Public Domain.)
+
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t , at body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ , at body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
+
+;;; Taken from Alexandria (which is Public Domain, or BSD.)
+
+(define-condition simple-style-warning (simple-warning style-warning)
+ ())
+
+(defun simple-style-warn (format-control &rest format-args)
+ (warn 'simple-style-warning
+ :format-control format-control
+ :format-arguments format-args))
+
+(define-condition simple-program-error (simple-error program-error)
+ ())
+
+(defun simple-program-error (message &rest args)
+ (error 'simple-program-error
+ :format-control message
+ :format-arguments args))
+
+(defun required-argument (&optional name)
+ "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+ (error "Required argument ~@[~S ~]missing." name))
+
+(defun ensure-list (list)
+ "If LIST is a list, it is returned. Otherwise returns the list
+designated by LIST."
+ (if (listp list)
+ list
+ (list list)))
+
+(declaim (inline ensure-function)) ; to propagate return type.
+(declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+(defun ensure-function (function-designator)
+ "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+
+(defun parse-body (body &key documentation whole)
+ "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list)
+ "Parses an ordinary lambda-list, returning as multiple values:
+
+ 1. Required parameters.
+ 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 3. Name of the rest parameter, or NIL.
+ 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+ 6. &AUX parameter specifications, normalized into form (NAME INIT).
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+ (let ((state :required)
+ (allow-other-keys nil)
+ (auxp nil)
+ (required nil)
+ (optional nil)
+ (rest nil)
+ (keys nil)
+ (aux nil))
+ (labels ((simple-program-error (format-string &rest format-args)
+ (error 'simple-program-error
+ :format-control format-string
+ :format-arguments format-args))
+ (fail (elt)
+ (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (check-variable (elt what)
+ (unless (and (symbolp elt) (not (constantp elt)))
+ (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
+ what elt lambda-list)))
+ (check-spec (spec what)
+ (destructuring-bind (init suppliedp) spec
+ (declare (ignore init))
+ (check-variable suppliedp what)))
+ (make-keyword (name)
+ "Interns the string designated by NAME in the KEYWORD package."
+ (intern (string name) :keyword)))
+ (dolist (elt lambda-list)
+ (case elt
+ (&optional
+ (if (eq state :required)
+ (setf state elt)
+ (fail elt)))
+ (&rest
+ (if (member state '(:required &optional))
+ (setf state elt)
+ (progn
+ (break "state=~S" state)
+ (fail elt))))
+ (&key
+ (if (member state '(:required &optional :after-rest))
+ (setf state elt)
+ (fail elt)))
+ (&allow-other-keys
+ (if (eq state '&key)
+ (setf allow-other-keys t
+ state elt)
+ (fail elt)))
+ (&aux
+ (cond ((eq state '&rest)
+ (fail elt))
+ (auxp
+ (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (t
+ (setf auxp t
+ state elt))
+ ))
+ (otherwise
+ (when (member elt '#.(set-difference lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux)))
+ (simple-program-error
+ "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (case state
+ (:required
+ (check-variable elt "required parameter")
+ (push elt required))
+ (&optional
+ (cond ((consp elt)
+ (destructuring-bind (name &rest tail) elt
+ (check-variable name "optional parameter")
+ (if (cdr tail)
+ (check-spec tail "optional-supplied-p parameter")
+ (setf elt (append elt '(nil))))))
+ (t
+ (check-variable elt "optional parameter")
+ (setf elt (cons elt '(nil nil)))))
+ (push elt optional))
+ (&rest
+ (check-variable elt "rest parameter")
+ (setf rest elt
+ state :after-rest))
+ (&key
+ (cond ((consp elt)
+ (destructuring-bind (var-or-kv &rest tail) elt
+ (cond ((consp var-or-kv)
+ (destructuring-bind (keyword var) var-or-kv
+ (unless (symbolp keyword)
+ (simple-program-error "Invalid keyword name ~S in ordinary ~
+ lambda-list:~% ~S"
+ keyword lambda-list))
+ (check-variable var "keyword parameter")))
+ (t
+ (check-variable var-or-kv "keyword parameter")
+ (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
+ (if (cdr tail)
+ (check-spec tail "keyword-supplied-p parameter")
+ (setf tail (append tail '(nil))))
+ (setf elt (cons var-or-kv tail))))
+ (t
+ (check-variable elt "keyword parameter")
+ (setf elt (list (list (make-keyword elt) elt) nil nil))))
+ (push elt keys))
+ (&aux
+ (if (consp elt)
+ (destructuring-bind (var &optional init) elt
+ (declare (ignore init))
+ (check-variable var "&aux parameter"))
+ (check-variable elt "&aux parameter"))
+ (push elt aux))
+ (t
+ (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
+ (values (nreverse required) (nreverse optional) rest (nreverse keys)
+ allow-other-keys (nreverse aux))))
\ No newline at end of file
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Thu Oct 22 16:10:10 2009
@@ -152,11 +152,12 @@
}
File f = new File(uri);
baseDir = fixDirPath(f.getParentFile().getParent());
- libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator;
+ libDir = baseDir;
}
lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)");
lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)");
lispEngine.eval("(pushnew #P\"" + libDir + "cl-utilities-1.2.4/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "named-readtables/\" asdf:*central-registry* :test #'equal)");
lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)");
lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)");
}
@@ -168,7 +169,6 @@
lispEngine.eval("(pushnew :snow-cells *features*)");
lispEngine.eval("(asdf:oos 'asdf:load-op :snow)");
-
//lispEngine.eval("(snow:install-graphical-debugger) (ohmygod)");
//lispEngine.eval("(snow::inspect-object (snow::new \"javax.swing.JButton\"))");
init = true;
Modified: trunk/src/java/snow/example/example.lisp
==============================================================================
--- trunk/src/java/snow/example/example.lisp (original)
+++ trunk/src/java/snow/example/example.lisp Thu Oct 22 16:10:10 2009
@@ -1,4 +1,5 @@
(in-package :snow)
+(in-readtable snow:syntax)
(defmodel my-model ()
((a :accessor aaa :initform (c-in "4"))
@@ -33,7 +34,7 @@
(label :binding (make-bean-data-binding *object* "property1")
:layout "wrap")
(label :text "EL binding")
- (label :binding (make-el-data-binding "bean.nested.property1")
+ (label :binding ${bean.nested.property1}
:layout "wrap")
(label :text "cells bindings: aaa and bbb")
(label :binding (make-cells-data-binding (c? (aaa *cells-object*))))
@@ -47,7 +48,7 @@
(text-field :binding (make-bean-data-binding *object* "property1")
:layout "growx, wrap")
(label :text "set nested.property1")
- (text-field :binding (make-el-data-binding "bean.nested.property1")
+ (text-field :binding ${bean.nested.property1}
:layout "growx, wrap")
(button :text "Test!"
:layout "wrap"
Modified: trunk/src/lisp/snow/compile-system.lisp
==============================================================================
--- trunk/src/lisp/snow/compile-system.lisp (original)
+++ trunk/src/lisp/snow/compile-system.lisp Thu Oct 22 16:10:10 2009
@@ -3,16 +3,13 @@
(unwind-protect
(unless
(progn
- #|(pushnew #P"snow/" asdf:*central-registry* :test #'equal)
- (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal)
- (pushnew #P"cl-utilities-1.2.4/" asdf:*central-registry* :test #'equal)
- (pushnew #P"cells/" asdf:*central-registry* :test #'equal)
- (pushnew #P"cells/utils-kt/" asdf:*central-registry* :test #'equal)
- (pushnew :snow-cells *features*)|#
(jstatic "initAux" "snow.Snow")
- (format t "asdf:*central-registry*: ~A" asdf:*central-registry*)
-
+ (format t "asdf:*central-registry*: ~S" asdf:*central-registry*)
+ (pushnew :snow-cells *features*)
+ (format t "compiling snow...")
(asdf:oos 'asdf:compile-op :snow)
+ (format t "success~%")
t)
- (format t "failed"))
+ (format t "failed~%"))
+ (terpri)
(quit))
\ No newline at end of file
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Thu Oct 22 16:10:10 2009
@@ -128,16 +128,31 @@
;;For EL data bindings we reuse simple-data-binding, since its 'variable' can
;;really be any JGoodies ValueModel
-(defun make-el-data-binding (el-expr)
+(defun make-el-data-binding (obj path)
+ (make-instance 'simple-data-binding
+ :variable (new "snow.binding.BeanPropertyPathBinding"
+ obj (apply #'jvector "java.lang.String" path))))
+
+(defun make-el-data-binding-from-expression (el-expr)
+ (print el-expr)
(let* ((splitted-expr (split-sequence #\. el-expr))
(obj (funcall *bean-factory* (car splitted-expr)))
(path (cdr splitted-expr)))
- (make-instance 'simple-data-binding
- :variable (new "snow.binding.BeanPropertyPathBinding"
- obj (apply #'jvector "java.lang.String" path)))))
+ (make-el-data-binding obj path)))
-;(defun make-bean-property-path-data-binding (object path)
-;)
+(defreadtable snow:syntax
+ (:merge :standard)
+ (:macro-char #\$ :dispatch)
+ (:dispatch-macro-char
+ #\$ #\{
+ #'(lambda (stream char number)
+ (declare (ignore char number))
+ `(make-el-data-binding-from-expression
+ ,(with-output-to-string (str)
+ (loop
+ :for ch := (read-char stream) :then (read-char stream)
+ :until (char= ch #\})
+ :do (write-char ch str)))))))
;;Default binding types
#|(defun default-data-binding-types ()
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Thu Oct 22 16:10:10 2009
@@ -30,7 +30,7 @@
(defpackage :snow
- (:use :common-lisp :java :cl-utilities #+snow-cells :cells)
+ (:use :common-lisp :java :cl-utilities :named-readtables #+snow-cells :cells)
(:shadow #+snow-cells #:dbg)
(:export
;;Widgets
@@ -38,19 +38,24 @@
#:frame
#:label
#:panel
+ #:text-area
#:text-field
;;Common operations on widgets
#:hide
#:pack
#:show
+ ;;Data binding
+ #:make-var
+ #:var
;;Various
#:install-graphical-debugger
#:*parent*
#:self
+ #:syntax
#:with-widget
;;Java
#:invoke
#:new))
(defpackage :snow-user
- (:use :common-lisp :snow :java :ext #+snow-cells :cells))
\ No newline at end of file
+ (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells))
\ No newline at end of file
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Thu Oct 22 16:10:10 2009
@@ -32,7 +32,7 @@
(asdf:defsystem :snow
:serial t
:version "0.2"
- :depends-on (:cl-utilities #+snow-cells :cells)
+ :depends-on (:cl-utilities :named-readtables #+snow-cells :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
More information about the snow-cvs
mailing list