[editor-hints-devel] Patch to support cmucl/unicode

[Raymond Toy]

The patch below adds support for cmucl/unicode.  This basically adds an
implementation of %make-readtable-iterator, updates %clear-readtable for
cmucl (like sbcl), a fix for %get-dispatch-macro-character, a fix for
%get-macro-character (like allegro).

With these changes (and a small change in named-readtables.lisp  that
has already been mentioned by Stas Boukarev last month. 

With these changes cmucl passes all 36 of the tests.

Oh, one thing.  I noticed that in %clear-readtable, the last sexp is
#+common-lisp.  CMUCL has the :common-lisp feature, so the table is set
twice.  Perhaps this is oversight and the reader conditional should be
#-(or allegro sbcl cmu)?

Ray

Change log:

 * Add implementation of %make-readtable-iterator for cmucl/unicode.
 * Implement %clear-readtable for cmucl.

 * Make %get-dispatch-macro-character return NIL where cmucl actually
   has #'lisp::dispatch-char-error.  It seems named-readtables wants
   this.
 * Update %get-macro-character for cmucl, which behaves like allegro
   here.


diff -u --recursive ./cruft.lisp
/Volumes/share2/src/sourceforge/matlisp/matlisp-cvs/lib-src/named-readtables-0.9/cruft.lisp
--- ./cruft.lisp    2009-10-10 04:19:32.000000000 -0400
+++
/Volumes/share2/src/sourceforge/matlisp/matlisp-cvs/lib-src/named-readtables-0.9/cruft.lisp   
2011-01-28 00:49:30.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))