Ticket #339: ccl.with-readtable-iterator.diff

lib/ccl-export-syms.lisp

@@ -637 +637 @@
      unmap-octet-vector
      ;; Miscellany
      heap-utilization
+     with-readtable-iterator
                                       
      ) "CCL"
    )

level-1/l1-reader.lisp

@@ -2149 +2149 @@
         (push (cons sub-ch fn) (cdr def))))
     t))
 
+(defun %make-readtable-iterator (readtable)
+  (let ((char-macro-alist (rdtab.alist readtable)))
+    (lambda ()
+      (if char-macro-alist
+          (destructuring-bind (char . defn) (pop char-macro-alist)
+            (if (consp defn)
+                (values t char (car defn) t (cdr defn))
+                (values t char defn nil nil)))
+          (values nil nil nil nil nil)))))
+
+(defmacro with-readtable-iterator ((name readtable) &body body)
+  "While executing BODY, bind NAME to a macro that iterates over
+   READTABLE's macros.  Each invocation of NAME yields five values:
+
+   VALUE? CHAR FUNCTION DISPATCH? DISPATCH-ALIST
+
+   VALUE? is true until the iterator runs out of items.  CHAR is the
+   macro character.  FUNCTION is the primary value of
+   `get-macro-character' for CHAR.  DISPATCH? is true if and only if
+   CHAR is a dispatching macro character.  DISPATCH-ALIST is an alist
+   mapping sub-characters to their respective values of
+   `get-dispatch-macro-character', and is NIL unless DISPATCH?.
+
+   The consequences of modifying READTABLE after entering BODY and
+   before the final invocation of NAME or final use of a
+   DISPATCH-ALIST are undefined."
+  (let ((it (gensym)))
+    `(let ((,it (%make-readtable-iterator ,readtable)))
+       (macrolet ((,name () `(funcall ,',it)))
+         ,@body))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;                              Reader                                  ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;