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 @@ ...@@ -108,7 +108,7 @@
;;; CCL has a bug that prevents the portable form below from working ;;; 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 ;;; (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) (define-cruft dispatch-macro-char-p (char rt)
"Is CHAR a dispatch macro character in RT?" "Is CHAR a dispatch macro character in RT?"
#+ :ccl #+ :ccl
...@@ -123,14 +123,8 @@ ...@@ -123,14 +123,8 @@
(error () nil))) (error () nil)))
;; (defun macro-char-p (char rt) ;; (defun macro-char-p (char rt)
;; (let ((reader-fn (get-macro-character char rt))) ;; (let ((reader-fn (%get-macro-character char rt)))
;; (and reader-fn ;; (and reader-fn t)))
;; ;; 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) ;; (defun standard-macro-char-p (char rt)
;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt) ;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
...@@ -161,31 +155,33 @@ ...@@ -161,31 +155,33 @@
(dispatch-tables (sb-impl::dispatch-tables readtable)) (dispatch-tables (sb-impl::dispatch-tables readtable))
(char-code 0)) (char-code 0))
(with-hash-table-iterator (ht-iterator char-macro-ht) (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)) (declare (optimize sb-c::merge-tail-calls))
(if (>= char-code sb-int:base-char-code-limit) (if (>= char-code sb-int:base-char-code-limit)
(grovel2) (grovel-unicode-chars)
(let ((entry (svref char-macro-array char-code))) (let ((reader-fn (svref char-macro-array char-code))
(setq char-code (1+ char-code)) (char (code-char (shiftf char-code (1+ char-code)))))
(if entry (if reader-fn
(values t (code-char (1- char-code)) entry nil nil) (yield char reader-fn)
(grovel1))))) (grovel-base-chars)))))
(grovel2 () ; grovel unicode macro characters (grovel-unicode-chars ()
(multiple-value-bind (more? char reader-fn) (ht-iterator) (multiple-value-bind (more? char reader-fn) (ht-iterator)
(if (not more?) (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) (values nil nil nil nil nil)
(let* ((disp-ch (caar dispatch-tables)) (yield char reader-fn))))
(disp-ht (cdar dispatch-tables)) (yield (char reader-fn)
(disp-fn (get-macro-character disp-ch readtable)) (let ((disp-ht))
(cond
((setq disp-ht (cdr (assoc char dispatch-tables)))
(let* ((disp-fn (get-macro-character char readtable))
(sub-char-alist)) (sub-char-alist))
(setq dispatch-tables (cdr dispatch-tables)) (maphash (lambda (k v)
(maphash (lambda (k v) (push (cons k v) sub-char-alist)) disp-ht) (push (cons k v) sub-char-alist))
(values t disp-ch disp-fn t sub-char-alist))))) disp-ht)
#'grovel1)))) (values t char disp-fn t sub-char-alist)))
(t
(values t char reader-fn nil nil))))))
#'grovel-base-chars))))
#+clozure #+clozure
(defun %make-readtable-iterator (readtable) (defun %make-readtable-iterator (readtable)
...@@ -203,28 +199,31 @@ ...@@ -203,28 +199,31 @@
(defun %make-readtable-iterator (readtable) (defun %make-readtable-iterator (readtable)
(declare (optimize speed)) ; for TCO (declare (optimize speed)) ; for TCO
(check-type readtable readtable) (check-type readtable readtable)
(let* ((+macro-attr+ 1) ; discovered through "reverse-engineering" (let* ((macro-table (first (excl::readtable-macro-table readtable)))
(attribute-table (first (excl::readtable-attribute-table readtable)))
(macro-table (first (excl::readtable-macro-table readtable)))
(dispatch-tables (excl::readtable-dispatch-tables readtable)) (dispatch-tables (excl::readtable-dispatch-tables readtable))
(table-length (length attribute-table)) (table-length (length macro-table))
(idx 0)) (idx 0))
(assert (= table-length (length macro-table)))
(labels ((grovel-macro-chars () (labels ((grovel-macro-chars ()
(if (>= idx table-length) (if (>= idx table-length)
(grovel-dispatch-chars) (grovel-dispatch-chars)
(let ((attr (svref attribute-table idx)) (let ((read-fn (svref macro-table idx))
(oidx idx)) (oidx idx))
(incf idx) (incf idx)
(if (= attr +macro-attr+) (if (or (eq read-fn #'excl::read-token)
(values t (code-char oidx) (svref macro-table oidx) nil nil) (eq read-fn #'excl::read-dispatch-char)
(grovel-macro-chars))))) (eq read-fn #'excl::undefined-macro-char))
(grovel-macro-chars)
(values t (code-char oidx) read-fn nil nil)))))
(grovel-dispatch-chars () (grovel-dispatch-chars ()
(if (null dispatch-tables) (if (null dispatch-tables)
(values nil nil nil nil nil) (values nil nil nil nil nil)
(destructuring-bind (disp-char sub-char-table) (destructuring-bind (disp-char sub-char-table)
(first dispatch-tables) (first dispatch-tables)
(setf dispatch-tables (rest 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 (values t
disp-char disp-char
(svref macro-table (char-code disp-char)) (svref macro-table (char-code disp-char))
...@@ -233,9 +232,9 @@ ...@@ -233,9 +232,9 @@
for subch-code from 0 for subch-code from 0
when subch-fn when subch-fn
collect (cons (code-char subch-code) collect (cons (code-char subch-code)
subch-fn))))))) subch-fn))))))))
#'grovel-macro-chars) #'grovel-macro-chars)))
))
#-(or sbcl clozure allegro) #-(or sbcl clozure allegro)
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
...@@ -305,8 +304,6 @@ ...@@ -305,8 +304,6 @@
;;;; Misc ;;;; Misc
(declaim (special *standard-readtable*))
;;; This should return an implementation's actual standard readtable ;;; This should return an implementation's actual standard readtable
;;; object only if the implementation makes the effort to guard against ;;; object only if the implementation makes the effort to guard against
;;; modification of that object. Otherwise it should better return a ;;; modification of that object. Otherwise it should better return a
...@@ -316,16 +313,47 @@ ...@@ -316,16 +313,47 @@
#+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable* #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
#+ :common-lisp (copy-readtable nil)) #+ :common-lisp (copy-readtable nil))
;;; 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. ;;; 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) (define-cruft %clear-readtable (readtable)
"Make all macro characters in READTABLE be consituents." "Make all macro characters in READTABLE be constituents."
#+ :common-lisp #+ :sbcl
(progn (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) (do-readtable (char readtable)
(set-syntax-from-char char #\A readtable *standard-readtable*)) (set-syntax-from-char char #\A readtable))
#+sbcl (setf (sb-impl::dispatch-tables readtable) nil) (let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
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. ;;;; Specialized PRINT-OBJECT for named readtables.
......
This diff is collapsed.
...@@ -189,13 +189,19 @@ Notes: ...@@ -189,13 +189,19 @@ Notes:
"Creates and returns a new readtable under the specified `name'. "Creates and returns a new readtable under the specified `name'.
`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the `merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
readtables the new readtable is created from. (See the :MERGE clause readtables the new readtable is created from. (See the :MERGE clause of
of DEFREADTABLE for details.) If `merge' is NIL, an empty readtable is DEFREADTABLE for details.)
used instead.
An empty readtable is a readtable where the character syntax of each If `merge' is NIL, an empty readtable is used instead.
character is like in the /standard readtable/ except that each
standard macro character has been made a constituent." 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) (cond ((not name-supplied-p)
(copy-readtable *empty-readtable*)) (copy-readtable *empty-readtable*))
((reserved-readtable-name-p name) ((reserved-readtable-name-p name)
...@@ -265,7 +271,8 @@ READER-MACRO-CONFLICT is signaled." ...@@ -265,7 +271,8 @@ READER-MACRO-CONFLICT is signaled."
(defun ensure-dispatch-macro-character (char &optional non-terminating-p (defun ensure-dispatch-macro-character (char &optional non-terminating-p
(readtable *readtable*)) (readtable *readtable*))
(unless (dispatch-macro-char-p char readtable) (if (dispatch-macro-char-p char readtable)
t
(make-dispatch-macro-character char non-terminating-p readtable))) (make-dispatch-macro-character char non-terminating-p readtable)))
(define-api copy-named-readtable (define-api copy-named-readtable
...@@ -339,15 +346,15 @@ This condition is signaled during the merge process if a) a reader macro ...@@ -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, 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.")) and b) if and only if the two respective reader macro functions differ."))
(defun check-reader-macro-conflict (from to char &optional subchar) (defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn) (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))))) (and to-fn (not (function= to-fn from-fn)))))
(when (if subchar (when (if subchar
(conflictp (safe-get-dispatch-macro-character char subchar from) (conflictp (%get-dispatch-macro-character char subchar from)
(safe-get-dispatch-macro-character char subchar to)) (%get-dispatch-macro-character char subchar to))
(conflictp (get-macro-character char from) (conflictp (%get-macro-character char from)
(get-macro-character char to))) (%get-macro-character char to)))
(cerror (format nil "Overwrite ~@C in ~A." char to) (cerror (format nil "Overwrite ~@C in ~A." char to)
'reader-macro-conflict 'reader-macro-conflict
:from-readtable from :from-readtable from
...@@ -355,13 +362,6 @@ and b) if and only if the two respective reader macro functions differ.")) ...@@ -355,13 +362,6 @@ and b) if and only if the two respective reader macro functions differ."))
:macro-char char :macro-char char
:sub-char subchar)))) :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 ;;; Although there is no way to get at the standard readtable in
;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make ;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
......
...@@ -5,7 +5,8 @@ ...@@ -5,7 +5,8 @@
(defpackage :named-readtables-test (defpackage :named-readtables-test
(:use :cl :named-readtables) (:use :cl :named-readtables)
(:import-from :named-readtables (:import-from :named-readtables
#:*empty-readtable* #:dispatch-macro-char-p
#:do-readtable #:do-readtable
#:ensure-function #:ensure-function
#:ensure-dispatch-macro-character
#:function=)) #:function=))
\ No newline at end of file
...@@ -8,6 +8,9 @@ ...@@ -8,6 +8,9 @@
(funcall cdr-fn (cdr entry)))) (funcall cdr-fn (cdr entry))))
alist)) alist))
(defun length=1 (list)
(and list (null (cdr list))))
(defmacro signals-condition-p (name &body body) (defmacro signals-condition-p (name &body body)
`(handler-case (prog1 nil ,@body) `(handler-case (prog1 nil ,@body)
(,(second name) () t))) (,(second name) () t)))
...@@ -98,6 +101,48 @@ ...@@ -98,6 +101,48 @@
(get-macro-character #\" (copy-readtable nil))) (get-macro-character #\" (copy-readtable nil)))
t) 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 (deftest standard.1
(read-with-readtable :standard "ABC") (read-with-readtable :standard "ABC")
ABC) ABC)
...@@ -124,7 +169,12 @@ ...@@ -124,7 +169,12 @@
t) t)
(deftest empty.2 (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) (readtable= (merge-readtables-into (make-readtable) rt)
(merge-readtables-into rt (make-readtable)))) (merge-readtables-into rt (make-readtable))))
t) t)
...@@ -188,11 +238,6 @@ ...@@ -188,11 +238,6 @@
#(:a :b :c)) #(:a :b :c))
(deftest merge.4 (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) (let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
:standard))) :standard)))
(readtable= 'standard+A+B+C 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