Commit 6f02ab5e authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

* Finished.

* Fix readtable-iteration bugs on Allegro and SBCL

* Add some more tests

* Update documentation

darcs-hash:20090929202208-f5546-7215b739d453b6db930659e70366c7e4d8cc8ce6.gz
parent d275bbb3
......@@ -108,7 +108,7 @@
;;; 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..
;;; if not declared inline.
(define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?"
#+ :ccl
......@@ -123,14 +123,8 @@
(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))))))
;; (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)
......@@ -161,31 +155,33 @@
(dispatch-tables (sb-impl::dispatch-tables readtable))
(char-code 0))
(with-hash-table-iterator (ht-iterator char-macro-ht)
(labels ((grovel1 () ; grovel base macro characters
(labels ((grovel-base-chars ()
(declare (optimize sb-c::merge-tail-calls))
(if (>= char-code sb-int:base-char-code-limit)
(grovel2)
(let ((entry (svref char-macro-array char-code)))
(setq char-code (1+ char-code))
(if entry
(values t (code-char (1- char-code)) entry nil nil)
(grovel1)))))
(grovel2 () ; grovel unicode macro characters
(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?)
(grovel3)
(values t char reader-fn nil nil))))
(grovel3 () ; grovel dispatch macro characters
(if (null dispatch-tables)
(values nil nil nil nil nil)
(let* ((disp-ch (caar dispatch-tables))
(disp-ht (cdar dispatch-tables))
(disp-fn (get-macro-character disp-ch readtable))
(sub-char-alist))
(setq dispatch-tables (cdr dispatch-tables))
(maphash (lambda (k v) (push (cons k v) sub-char-alist)) disp-ht)
(values t disp-ch disp-fn t sub-char-alist)))))
#'grovel1))))
(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)
......@@ -203,39 +199,42 @@
(defun %make-readtable-iterator (readtable)
(declare (optimize speed)) ; for TCO
(check-type readtable readtable)
(let* ((+macro-attr+ 1) ; discovered through "reverse-engineering"
(attribute-table (first (excl::readtable-attribute-table readtable)))
(macro-table (first (excl::readtable-macro-table readtable)))
(let* ((macro-table (first (excl::readtable-macro-table readtable)))
(dispatch-tables (excl::readtable-dispatch-tables readtable))
(table-length (length attribute-table))
(table-length (length macro-table))
(idx 0))
(assert (= table-length (length macro-table)))
(labels ((grovel-macro-chars ()
(if (>= idx table-length)
(grovel-dispatch-chars)
(let ((attr (svref attribute-table idx))
(let ((read-fn (svref macro-table idx))
(oidx idx))
(incf idx)
(if (= attr +macro-attr+)
(values t (code-char oidx) (svref macro-table oidx) nil nil)
(grovel-macro-chars)))))
(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))
(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)
))
;;; 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)
......@@ -305,8 +304,6 @@
;;;; Misc
(declaim (special *standard-readtable*))
;;; 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
......@@ -316,16 +313,47 @@
#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
#+ :common-lisp (copy-readtable nil))
;;; FIXME: Alas, on SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
;;; 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 consituents."
#+ :common-lisp
(progn
"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 *standard-readtable*))
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil)
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.
......
This diff is collapsed.
......@@ -189,13 +189,19 @@ Notes:
"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.
readtables the new readtable is created from. (See the :MERGE clause of
DEFREADTABLE for details.)
An empty readtable is a readtable where the character syntax of each
character is like in the /standard readtable/ except that each
standard macro character has been made a constituent."
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)
......@@ -255,8 +261,8 @@ READER-MACRO-CONFLICT is signaled."
(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)))))
(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))
......@@ -265,8 +271,9 @@ READER-MACRO-CONFLICT is signaled."
(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)))
(if (dispatch-macro-char-p char readtable)
t
(make-dispatch-macro-character char non-terminating-p readtable)))
(define-api copy-named-readtable
(named-readtable)
......@@ -339,15 +346,15 @@ This condition is signaled during the merge process if a) a reader 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 (safe-get-dispatch-macro-character char subchar from)
(safe-get-dispatch-macro-character char subchar to))
(conflictp (get-macro-character char from)
(get-macro-character char to)))
(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
......@@ -355,13 +362,6 @@ and b) if and only if the two respective reader macro functions differ."))
:macro-char char
:sub-char subchar))))
;;; See Ticket 601. This is supposed to be removed at some point in
;;; the future.
(defun safe-get-dispatch-macro-character (char subchar rt)
#+ccl (ignore-errors
(get-dispatch-macro-character char subchar rt))
#-ccl (get-dispatch-macro-character char subchar rt))
;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
......
......@@ -5,7 +5,8 @@
(defpackage :named-readtables-test
(:use :cl :named-readtables)
(:import-from :named-readtables
#:*empty-readtable*
#:dispatch-macro-char-p
#:do-readtable
#:ensure-function
#:ensure-dispatch-macro-character
#:function=))
\ No newline at end of file
......@@ -8,6 +8,9 @@
(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 ,@body)
(,(second name) () t)))
......@@ -98,6 +101,48 @@
(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)
......@@ -124,7 +169,12 @@
t)
(deftest empty.2
(let ((rt (copy-readtable (find-readtable :standard))))
(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)
......@@ -188,11 +238,6 @@
#(:a :b :c))
(deftest merge.4
(readtable= (merge-readtables-into (make-readtable) :standard)
(find-readtable :standard))
t)
(deftest merge.5
(let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
:standard)))
(readtable= 'standard+A+B+C A+B+C+standard))
......
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