diff -Bbdur /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/cruft.lisp /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/cruft.lisp --- /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/cruft.lisp 2012-01-12 00:27:27.094435814 -0500 +++ /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/cruft.lisp 2012-01-11 14:03:38.000000000 -0500 @@ -235,8 +235,55 @@ subch-fn)))))))) #'grovel-macro-chars))) +;; This really only needed for CMUCL with unicode support. Without +;; unicode, the default implementation is probably fast enough. +#+(and cmu unicode) +(defun %make-readtable-iterator (readtable) + (let ((char-macro-ht (lisp::character-macro-hash-table readtable)) + (dispatch-tables (lisp::dispatch-tables readtable)) + (char-code 0)) + (with-hash-table-iterator (ht-iterator char-macro-ht) + (labels ((grovel-base-chars () + (if (>= char-code lisp::attribute-table-limit) + (grovel-unicode-chars) + (let* ((char (code-char (shiftf char-code (1+ char-code)))) + ;; Need %get-macro-character here, not + ;; get-macro-character because we want NIL + ;; to be returned instead of + ;; #'lisp::read-token. + (reader-fn (%get-macro-character char readtable))) + (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)) + (if (< (char-code char) lisp::attribute-table-limit) + (let ((disp (lisp::char-dispatch-table-table disp-ht))) + (dotimes (k lisp::attribute-table-limit) + (let ((f (aref disp k))) + (unless (eq f #'lisp::dispatch-char-error) + (push (cons (code-char k) f) + sub-char-alist))))) + (let ((disp-ht (lisp::char-dispatch-table-hash-table disp-ht))) + (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)))) -#-(or sbcl clozure allegro) +#-(or sbcl clozure allegro (and cmu unicode)) (eval-when (:compile-toplevel) (let ((*print-pretty* t)) (simple-style-warn @@ -246,7 +293,7 @@ On Unicode-aware implementations this may come with some costs.~@:>" (package-name '#.*package*) (lisp-implementation-type)))) -#-(or sbcl clozure allegro) +#-(or sbcl clozure allegro (and cmu unicode)) (defun %make-readtable-iterator (readtable) (check-type readtable readtable) (let ((char-code 0)) @@ -325,6 +372,11 @@ (do-readtable (char readtable) (set-syntax-from-char char #\A readtable)) (setf (sb-impl::dispatch-tables readtable) nil)) + #+:cmu + (prog1 readtable + (do-readtable (char readtable) + (set-syntax-from-char char #\A readtable)) + (setf (lisp::dispatch-tables readtable) nil)) #+ :allegro (prog1 readtable (do-readtable (char readtable) @@ -343,17 +395,28 @@ "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)) + #+cmu + (let ((f (get-dispatch-macro-character char subchar rt))) + ;; CMUCL returns #'lisp::dispatch-char-error, and named-readtables + ;; wants nil in those cases. + (unless (eq f #'lisp::dispatch-char-error) + f)) + #-(or :ccl :cmu) (get-dispatch-macro-character char subchar rt)) ;;; Allegro stores READ-TOKEN as reader macro function of each -;;; constituent character. +;;; constituent character. CMUCL does the same. (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)) + #+cmu + (let ((fn (get-macro-character char rt))) + (cond ((not fn) nil) + ((function= fn #'lisp::read-token) nil) + (t fn))) + #-(or :allegro cmu) (get-macro-character char rt)) ;;;; Specialized PRINT-OBJECT for named readtables. diff -Bbdur /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/define-api.lisp /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/define-api.lisp --- /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/define-api.lisp 2012-01-12 00:27:27.094435814 -0500 +++ /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/define-api.lisp 2012-01-11 00:11:11.000000000 -0500 @@ -38,12 +38,12 @@ collect `(check-type ,req-arg ,req-type)) ;; CHECK-TYPE optional parameters - ,@(loop initially (assert (or (null opts) + ,@(progn (assert (or (null opts) (eq (pop type-list) '&optional))) - for (opt-arg . nil) in opts + (loop for (opt-arg . nil) in opts for opt-type = (pop type-list) do (assert opt-type) - collect `(check-type ,opt-arg ,opt-type)) + collect `(check-type ,opt-arg ,opt-type))) ;; CHECK-TYPE rest parameter ,@(when rest diff -Bbdur /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/named-readtables.lisp /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/named-readtables.lisp --- /home/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/named-readtables.lisp 2012-01-12 00:27:27.106470029 -0500 +++ /tmp/devon/quicklisp/dists/quicklisp/software/named-readtables-20101006-darcs/named-readtables.lisp 2012-01-10 23:52:19.000000000 -0500 @@ -132,9 +132,9 @@ (cond ((not readtable) (setq readtable (make-readtable ',name))) (t - (setq readtable (%clear-readtable readtable)) (simple-style-warn "Overwriting already existing readtable ~S." - readtable))) + readtable) + (setq readtable (%clear-readtable readtable)))) ,@(loop for option in merge-clauses collect (process-option option 'readtable)) ,@(loop for option in case-clauses