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

Various additions.

* The recent addition of empty readtables broke named-readtables
  fundamentally. Thanks for David Crawford for pointing that out.

  I had to accomodate MERGE-READTABLES-INTO now that the neutral
  element is no longer the standard readtable, but an empty
  readtable.

* We no make the readtable empty first when redefining it via a
  DEFREADTABLE form. Then the content is refilled.

* MERGE-READTABLES-INTO now signals a new error
  READER-MACRO-CONFLICT if a macro character is present
  in more than one of the argument readtables.

  DEFREADTABLE turns READER-MACRO-CONFLICT into a warning.

* Fix expansion of DEFREADTABLE so calls to MERGE-READTABLES-INTO
  properly quote readtable names.

* Add WITHOUT-PACKAGE-LOCK for our :AROUND method of PRINT-OBJECT
  specializing on READTABLE.

* Update docstrings accordingly.

darcs-hash:20090919175636-f5546-c5f68eb6d7fe114afee170aa225e95ea80e6291a.gz
parent 9c7fb975
......@@ -98,6 +98,44 @@
"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
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
;; CCL has a bug that prevents the portable form below from
;; working. Patch has been sent upstream. (2009-09-19.)
#+ :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 (prog1 t
(get-dispatch-macro-character char #\x rt))
(error () nil)))
;; (defun macro-char-p (char rt)
;; (let ((reader-fn (get-macro-character char rt)))
;; (and reader-fn
;; ;; Allegro stores READ-TOKEN as reader macro function of each
;; ;; constituent character.
;; #+allegro
;; (let ((read-token-fn
;; (load-time-value (get-macro-character #\A *standard-readtable*))))
;; (not (eq reader-fn read-token-fn))))))
;; (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
......@@ -193,12 +231,13 @@
#-(or sbcl clozure allegro)
(eval-when (:compile-toplevel)
(simple-style-warn
"~A hasn't 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 comes with some costs."
(package-name *package*) (lisp-implementation-type)))
(let ((*print-pretty* t))
(simple-style-warn
"~@<~A hasn't 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 comes with some costs.~@:>"
(package-name *package*) (lisp-implementation-type))))
#-(or sbcl clozure allegro)
(defun %make-readtable-iterator (readtable)
......@@ -242,6 +281,19 @@
(,iter)
(unless ,more? (return ,result))
,@body))))))
;;;; Misc
(declaim (special *standard-readtable*))
(defun %clear-readtable (readtable)
"Make all macro characters in READTABLE be consituents."
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable *standard-readtable*))
;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable)
;;;; Specialized PRINT-OBJECT for named readtables.
......@@ -259,5 +311,5 @@
(let ((name (readtable-name rt)))
(if name
(print-unreadable-object (rt stream :type nil :identity t)
(format stream "~A ~S" (string :named-readtable) name))
(format stream "~A ~S" :named-readtable name))
(call-next-method)))))
\ No newline at end of file
......@@ -20,18 +20,10 @@
;;; TODO:
;;;
;;; * Remove redefinition style-warning in DEFREADTABLE
;;;
;;; * Add style-warning if redefined readtable contains entries
;;; not specified in the DEFREADTABLE form (cf. SBCL's DEFPACKAGE)
;;;
;;; * Add style-warning if :MERGE overwrites entries
;;;
;;; * Add :FUZE that's like :MERGE without the style-warnings
;;;
;;; * Think about MAKE-DISPATCHING-MACRO-CHARACTER in DEFREADTABLE
;;;;;; DEFREADTABLE &c.
(defmacro defreadtable (name &body options)
......@@ -43,12 +35,13 @@ The readtable can be populated using the following `options':
(:MERGE `readtable-designators'+)
Merge the readtables designated into the new readtable, using
MERGE-READTABLES-INTO.
Note that the process of merging readtables is _not_ commutative, so
that reader macros in earlier entries will be overwritten by later
ones.
Merge the readtables designated into the new readtable being defined
as per MERGE-READTABLES-INTO.
Error conditions of type READER-MACRO-CONFLICT that are signaled
during the merge operation are continued and warnings are signaled
instead. It follows that reader macros in earlier entries will be
_overwritten_ by later ones.
If no :MERGE clause is given, an empty readtable is used. See
MAKE-READTABLE.
......@@ -88,6 +81,9 @@ Notes:
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.
"
......@@ -98,14 +94,12 @@ Notes:
(flet ((process-option (option var)
(destructure-case option
((:merge &rest readtable-designators)
`(merge-readtables-into ,var ,@readtable-designators))
`(merge-readtables-into ,var
,@(mapcar #'(lambda (x) `',x) readtable-designators))) ; quotify
((: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)
;; FIXME: This is not perfect as SBCL signals an
;; error on already existing dispatch macros. I sent
;; an appropriate patch upstream.
`(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)
......@@ -130,17 +124,25 @@ Notes:
(error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
(t
`(eval-when (:load-toplevel :execute)
(handler-bind ((readtable-does-already-exist
#'(lambda (c)
(simple-style-warn
"Overwriting previously existing readtable ~S."
(existing-readtable-name c))
(continue c))))
(handler-bind ((reader-macro-conflict
#'(lambda (c)
(warn "~@<Overwriting ~C~@[~C~] in ~A ~
with entry from ~A.~@:>"
(conflicting-macro-char c)
(conflicting-dispatch-sub-char c)
(to-readtable c)
(from-readtable c))
(continue c))))
;; The (FIND-READTABLE ...) is important for proper
;; redefinition semantics, as redefining has to modify the
;; already existing readtable object.
(let ((readtable (or (find-readtable ',name)
(make-readtable ',name))))
(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
......@@ -162,7 +164,8 @@ Notes:
(%frob-swank-readtable-alist *package* *readtable*))
))
;;; KLUDGE:
;;; 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.
;;;
......@@ -178,7 +181,6 @@ Notes:
(and (string= pkg-name1 pkg-name2)
(eq rt1 rt2)))))))))
(declaim (special *standard-readtable* *empty-readtable*))
......@@ -199,8 +201,12 @@ standard macro character has been made a constituent."
(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 (cerror "Overwrite existing readtable."
'readtable-does-already-exist :readtable-name name))))
(and rt (prog1 nil
(cerror "Overwrite existing readtable."
'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!)
......@@ -209,6 +215,7 @@ standard macro character has been made a constituent."
(ensure-readtable (first merge-list))
*empty-readtable*))
(rest merge-list))))
(register-readtable name result))))))
(defun rename-readtable (named-readtable-designator new-name)
......@@ -233,37 +240,32 @@ is signaled."
(defun merge-readtables-into (result-table &rest named-readtable-designators)
"Copy the contents of each readtable in `named-readtable-designators'
into `result-table'. Because the readtables are merged in turn, macro
definitions in readtables appearing later in the list will overwrite
reader-macros appearing earlier."
(flet ((merge-into (rt1 rt2)
;;; FIXME: document why STANDARD-FOO-CHAR-P
(do-readtable ((char reader-fn disp? table) rt2)
(unless (standard-macro-char-p char rt2)
(let ((non-terminating-p (nth-value 1 (get-macro-character char rt2))))
(set-macro-character char reader-fn non-terminating-p rt1)))
(when disp?
(loop for (subchar . subfn) in table do
(unless (standard-dispatch-macro-char-p char subchar rt2)
(set-dispatch-macro-character char subchar subfn rt1)))))
rt1))
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 disp? table) from)
(let ((non-terminating-p (nth-value 1 (get-macro-character char 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))
(setf result-table (ensure-readtable result-table))
(dolist (table (mapcar #'ensure-readtable named-readtable-designators))
(merge-into result-table table))
result-table))
(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*)))))
(defun ensure-dispatch-macro-character (char &optional non-terminating-p
(readtable *readtable*))
(unless (dispatch-macro-char-p char readtable)
(make-dispatch-macro-character char non-terminating-p readtable)))
(defun list-all-named-readtables ()
"Returns a list of all registered readtables. The returned list is
......@@ -285,7 +287,7 @@ guaranteed to be fresh, but may contain duplicates."
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor missing-readtable-name
:type named-readtable-designatord))
:type named-readtable-designator))
(:report (lambda (condition stream)
(format stream "A readtable named ~S does not exist."
(missing-readtable-name condition)))))
......@@ -294,12 +296,69 @@ guaranteed to be fresh, but may contain duplicates."
((readtable-name :initarg :readtable-name
:initform (required-argument)
:accessor existing-readtable-name
:type named-readtable-designatord))
: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 (as
per EQ.)"))
(defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn)
(and to-fn
(not (eq 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)))
(break "from = ~S, to = ~S, char = ~S, subchar = ~S"
from to char subchar)
(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
......@@ -320,16 +379,11 @@ guaranteed to be fresh, but may contain duplicates."
;;; is out of scope of this library, though. So we just threaten
;;; with nasal demons.
;;;
(defvar *standard-readtable* (%standard-readtable))
(defvar *standard-readtable*
(%standard-readtable))
(defvar *empty-readtable*
(let ((readtable (copy-readtable nil)))
(do-readtable (char readtable)
(set-syntax-from-char char #\A readtable *standard-readtable*))
;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;; readtable's dispatch table properly.
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
readtable))
(%clear-readtable (copy-readtable nil)))
(defvar *case-preserving-standard-readtable*
(let ((readtable (copy-readtable nil)))
......
......@@ -19,8 +19,9 @@
;; Types
#:named-readtable-designator
;; Conditions
#:readtable-does-not-exist
#:reader-macro-conflict
#:readtable-does-already-exist
#:readtable-does-not-exist
)
(:documentation
"
......@@ -150,7 +151,7 @@
- NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
- :MODERM designates a _case-preserving_ /standard-readtable/.
- :MODERN designates a _case-preserving_ /standard-readtable/.
- :CURRENT designates the /current readtable/.
......@@ -178,6 +179,8 @@
> ...
>
> (in-readtable scheme:syntax)
>
> ...
* Acknowledgements
......
......@@ -16,6 +16,14 @@
:format-control format-control
:format-arguments format-args))
(defmacro without-package-lock ((&rest package-names) &body body)
(declare (ignorable package-names))
#+clisp (return-from without-package-lock
`(ext:without-package-lock (,@package-names) ,@body))
`(progn ,@body))
;;; Taken from SWANK (which is Public Domain.)
(defmacro destructure-case (value &rest patterns)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment