readtable: simplify

After taking a look at the R7RS syntax and how Chicken parses
directives, I realized that it's easier to have "#!", "#\\", etc.
parse identifiers instead of baking in trie actions. This is slightly
slower but completely removes the trie concept from the readtable,
which simplifies the implementation and removes many corner cases
involving combining readtables with different action types.

read.scm

@@ -13,12 +13,6 @@
 
 ;;; R7RS reader. This is the lexer-parser end, so it returns tokens and
 ;;; not concrete objects.
-;;; 
-;;; The reader is based on a readtable that acts (in some instances) like
-;;; a trie. The reader reads a character and looks it up in the readtable.
-;;; The actions stored in the readtable are either opaque execution actions
-;;; or transparent "pass" actions that jump to a new readtable to read more
-;;; characters.
 
 (load "chez-compat.scm")
 (load "util.scm")
@@ -26,7 +20,6 @@
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Port reader wrapper
-
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define port->read-function
@@ -96,251 +89,134 @@
       ((= x y) '=)
       (else '>))))
 
-(define char<=>
+;;; Comparison on characters extended to #F, which is less than all
+;;; characters.
+(define char*<=>
   (lambda (x y)
-    (integer<=> (char->integer x)
+    (cond
-                (char->integer y))))
+      ((and (not x) y) '<)
+      ((and x (not y)) '>)
+      ((and (not x) (not y) '=))
+      (else (integer<=> (char->integer x)
+                        (char->integer y))))))
 
-(define %charmap:<=> (set:<=>-to-map char<=>))
+(define %charmap:<=> (set:<=>-to-map char*<=>))
 (define %charmap:update (set:update %charmap:<=>))
 
 (define charmap:update (map:update %charmap:update))
 (define charmap:insert (map:insert %charmap:update))
 (define charmap:search (map:search %charmap:<=>))
 
-(define charmap:insert-many
+;;; ;;;;;;;;;;;;;;;;;;;;;;
-  (lambda (cmap . pairs)
-    (fold (lambda (pair cmap)
-            (car (charmap:insert cmap (car pair) (cdr pair))))
-          cmap
-          pairs)))
-
-;;; ;;;;;;;;;;
 ;;; Readtable constructors
-;;; 
+;;; ;;;;;;;;;;;;;;;;;;;;;;
-;;; Readtable actions are objects with the following messages:
-;;; 
-;;; (STEP TABLE CHAR ACC PORT): Act on CHAR from TABLE with accumulated
-;;; value ACC and PORT.
-;;; (UPDATE REST ACTION): Return a new readtable action which is the
-;;; action of reading REST and executing ACTION after that. This should
-;;; preserve the previous action as much as possible.
-;;; ;;;;;;;;;;
 
-;;; Pass to new readtable.
+;;; (READTABLE:NEW DEFAULT-ACTION CHARMAP)
-;;; 
+(define readtable:new cons)
-;;; STEP reads the next character in the sequence and jumps to TABLE
-;;; modifying ACC.
-;;; 
-;;; On UPDATE:
-;;; If (NULL? REST), return PASS with a TABLE updated with its default
-;;; action to be ACTION.
-;;; If (PAIR? REST), return PASS with (TABLE UPDATE REST ACTION).
-(define readtable:pass:new
-  (lambda (table)
-    (let ((step
-           (lambda (oldtable char acc port)
-             (table (port 'read) acc port)))
-          (update
-           (lambda (rest action)
-             (readtable:pass:new
-              (if (null? rest)
-                  (table 'with-default-action action)
-                  (table 'update rest action))))))
-      (lambda (op . args)
-        (cond
-          ((eq? op 'update) (apply update args))
-          ((eq? op 'step) (apply step args))
-          (else (error "readtable:pass: invalid" args)))))))
 
-;;; Create a new PASS with a blank TABLE with DEFAULT-ACTION as the
+(define %readtable:default-action car)
-;;; default action.
+(define %readtable:charmap cdr)
-(define readtable:pass/blank
+
+;;; Run the action in TABLE assigned to CHAR, or the default action of
+;;; TABLE if there is no entry for CHAR.
+(define readtable:act
+  (lambda (table char acc port)
+    (let ((node (charmap:search (%readtable:charmap table)
+                                char)))
+      (let ((action (if (null? node)
+                        (%readtable:default-action table)
+                        (map:val node))))
+        (action table char acc port)))))
+
+;;; Return a new readtable where CHAR is bound to ACTION.
+(define readtable:update
+  (lambda (table char action)
+    (readtable:new (%readtable:default-action table)
+                   (car (charmap:insert
+                         (%readtable:charmap table) char action)))))
+
+;;; Construct new readtable with no characters in its map and
+;;; DEFAULT-ACTION as the default action.
+(define readtable:empty/default
   (lambda (default-action)
-    (readtable:pass:new (readtable:new default-action '()))))
+    (readtable:new default-action '())))
 
-;;; Execute an action.
+;;; Each value in FUNCTIONS is a list (PROCEDURE ARGS...) which is called
-;;; 
+;;; like (PROCEDURE TABLE ARGS...) and returns a table.
-;;; STEP calls PROC with the same arguments.
+(define readtable:process
-;;; 
+  (lambda (table . functions)
-;;; On UPDATE:
+    (fold (lambda (function table)
-;;; If (NULL? REST), then replace this action with ACTION.
+            (apply (car function) table (cdr function)))
-;;; If (PAIR? REST), return PASS with an empty table with this object
-;;; as the default action, and run (UPDATE REST ACTION) on it.
-(define readtable:exec:new
-  (lambda (proc)
-    (letrec
-        ((update
-          (lambda (rest action)
-            (if (null? rest)
-                action
-                ((readtable:pass:new (readtable:new exec '()))
-                 'update rest action))))
-         (exec
-          (lambda (op . args)
-            (cond
-              ((eq? op 'update) (apply update args))
-              ((eq? op 'step) (apply proc args))
-              (else (error "readtable:exec: invalid" args))))))
-      exec)))
-
-
-;;; ;;;;;;;;;;;;;;;
-;;; Default actions
-;;; ;;;;;;;;;;;;;;;
-
-;;; Add multiple literal sequences to the readtable.
-(define readtable:update-many-sequence
-  (lambda (table . pairs)
-    (fold (lambda (pair table)
-            (readtable:add-sequence table (car pair)
-                                    (cdr pair)))
           table
-          pairs)))
+          functions)))
 
-;;; Signal error on this action.
+;;; ;;;;;;;;;;;;;;;;;;
-(define readtable:error-action
+;;; Default readtables
-  (lambda (emsg)
+;;; ;;;;;;;;;;;;;;;;;;
-    (readtable:exec:new
-     (lambda (table char acc port)
-       (error emsg (list table char acc port))))))
 
-;;; Create an EXEC action that discards the current character.
+;;; Discard the current character and continue reading the readtable.
-;;; This should not be a PASS action, because PASS actions emulate
-;;; a trie, which is not cyclic.
 (define readtable:skip
-  (readtable:exec:new
   (lambda (table char acc port)
-     (table 'run (port 'read) acc port))))
+    (readtable:act table (port 'read) acc port)))
 
-;;; Ignore everything and return a constant.
+;;; Push back CHAR and return ACC.
-(define readtable:return-value
+(define readtable:return-acc-keep-char
-  (lambda (value)
-    (readtable:exec:new
-     (lambda (table char acc port)
-       value))))
-
-;;; Define a new readtable.
-;;; 
-;;; (X) where (CHAR? X): Execute the action associated with X, or the
-;;; default action.
-;;; 
-;;; (WITH-DEFAULT-ACTION NEW-ACTION): Return a readtable with the same
-;;; backing table but with NEW-ACTION as the default action.
-;;; 
-;;; (UPDATE REST ACTION): Update the action taken by the total application
-;;; of REST to be ACTION. REST must be a pair.
-(define readtable:new
-  (lambda (default-action charmap)
-    (letrec
-        ((lookup?
-          (lambda (char)
-            (let ((node (charmap:search charmap char)))
-              (if (null? node)
-                  #f
-                  (map:val node)))))
-         (lookup
-          (lambda (char)
-            (or (lookup? char) default-action)))
-         (run*
-          (lambda (handler char acc port)
-            (handler 'step table char acc port)))
-         (run
-          (lambda (char acc port)
-            (run* (lookup char) char acc port)))
-         (with-default-action
-             (lambda (new-default-action)
-               (readtable:new new-default-action charmap)))
-         (empty-pass/error
-          (lambda ()
-            (readtable:pass/blank (readtable:error-action
-                                   "reading long name"))))
-         (update-oldnode
-          (lambda (rest action)
-            (lambda (_ oldnode)
-              (if (null? rest)
-                  action
-                  (let ((replaced (if (null? oldnode)
-                                      (empty-pass/error)
-                                      (map:val oldnode))))
-                    (replaced 'update rest action))))))
-         (update
-          (lambda (rest action)
-            (if (null? rest)
-                (error "readtable update: invalid" (list rest action))
-                (readtable:new default-action
-                               (charmap:update
-                                charmap
-                                (car rest)
-                                (update-oldnode (cdr rest) action))))))
-         (table
-          (lambda (op . args)
-            (cond
-              ((not op)
-               (apply run* default-action op args))
-              ((char? op) (apply run op args))
-              ((eq? op 'with-default-action) (apply with-default-action
-                                                    args))
-              ((eq? op 'update) (apply update args))
-              (else (error "readtable: invalid" (cons op args)))))))
-      table)))
-
-;;; Wrap ACTION in a readtable, and push bach the currently read character
-;;; before calling ACTION.
-;;; 
-;;; This is designed for readtable actions that already know what they
-;;; are matching against.
-(define readtable:sequence-wrapper
-  (lambda (action)
-    (readtable:pass/blank
-     (readtable:exec:new
   (lambda (table char acc port)
     (port 'push char)
-        (action 'step table #f #f port))))))
+    acc))
 
-;;; Add ACTION as the action to be taken in TABLE following SEQ.
+;;; Push CHAR to ACC and continue reading from TABLE.
-;;; The action is wrapped in an empty PASS table with ACTION as the default
+(define readtable:push-acc
-;;; action. This normalizes the character ACTION is passed.
+  (lambda (table char acc port)
-(define readtable:add-sequence
+    (readtable:act table (port 'read) (cons char acc) port)))
-  (lambda (table seq action)
-    (let ((seq (cond
-                 ((char? seq) (list seq))
-                 ((string? seq) (string->list seq))
-                 (else seq))))
-      (table 'update seq (readtable:sequence-wrapper action)))))
 
-;;; ;;;;;;;;;;;;;;;;;;;
+;;; Define a readtable that constructs an identifier by accepting all
-;;; Default readtables
+;;; characters that are not listed.
-;;; ;;;;;;;;;;;;;;;;;;;
+(define readtable:exclude-from-identifiers
+  (lambda (table excluded)
+    (fold (lambda (char table)
+            (readtable:update table char readtable:return-acc-keep-char))
+          table
+          excluded)))
 
-(define readtable:empty
+;;; ASCII whitespace.
-  (readtable:new (readtable:error-action "no more actions")
+(define readtable:ASCII-whitespace
-                 '()))
+  (list #\newline
+        #\space
+        (integer->char #x09)
+        (integer->char #x0B)
+        (integer->char #x0C)
+        (integer->char #x0D)))
 
-;;; Ignore all characters until newline.
+;;; Readtable for identifiers.
-(define readtable:read-line-comment
+(define readtable:identifier
-  (readtable:new
+  (readtable:process
-   readtable:skip
+   (readtable:empty/default readtable:push-acc)
-   (charmap:insert-many '()
+   (list readtable:exclude-from-identifiers
-                        (list
+         readtable:ASCII-whitespace)
-                         (cons #\newline (readtable:return-value #f))))))
+   (list readtable:exclude-from-identifiers
+         (list #\| #\( #\) #\' #\; #f))))
 
+;;; Read an identifier starting with CHAR.
+(define readtable:read-ident
+  (lambda (table char acc port)
+    (reverse (readtable:act readtable:identifier
+                            (port 'read) (list char) port))))
+
+;;; Add all chars in TO-SKIP to TABLE as skipped characters. Used for
+;;; whitespace.
+(define readtable:add-all-as-skip
+  (lambda (table to-skip)
+    (fold (lambda (char table)
+            (readtable:update table char readtable:skip))
+          table
+          to-skip)))
+
+;;; Toplevel reader.
 (define readtable:top
-  (readtable:update-many-sequence
+  (readtable:process
-   readtable:empty
+   (readtable:empty/default readtable:read-ident)
-   (cons "#!fold-case"
+   (list readtable:add-all-as-skip readtable:ASCII-whitespace)))
-         (readtable:exec:new
-          (lambda (table char acc port)
-            (port 'fold-case! #t)
-            '())))
-   (cons "#!no-fold-case"
-         (readtable:exec:new
-          (lambda (table char acc port)
-            (port 'fold-case! #f)
-            '())))
-   (cons "#t" (readtable:return-value #t))
-   (cons "#f" (readtable:return-value #f))
-   (cons "#true" (readtable:return-value #t))))
 
 ;;; ;;;;;;;;;;;
 ;;; Test reader
@@ -356,12 +232,13 @@
              ch)))
      "test")))
 
-(let ((true-reader (%list->read (string->list "#!fold-case#TRUE#!no-fold-case#TRUE"))))
+(let ((true-reader (%list->read (string->list "xyzw    abcd    x!"))))
-  (display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
+  (display (list "first:" (readtable:act
+                           readtable:top (true-reader 'read) #f true-reader)))
   (newline)
-  (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))
+  (display (list "second: " (readtable:act
+                             readtable:top (true-reader 'read) #f true-reader)))
   (newline)
-  (display (list "third: " (readtable:top (true-reader 'read) #f true-reader)))
+  (display (list "third: " (readtable:act
-  (newline)
+                            readtable:top (true-reader 'read) #f true-reader)))
-  (display (list "fourth: " (readtable:top (true-reader 'read) #f true-reader)))
   (newline))

util.scm

@@ -33,3 +33,18 @@
       ((not (f (car lst))) #f)
       (else (all f (cdr lst))))))
 
+;;; (REVAPPEND L1 ... LN) returns L{N-1}, L{N-2}, ... reversed and
+;;; appended to LN, in that order.
+(define revappend
+  (letrec ((loop
+            (lambda (lst1 lst2)
+              (if (null? lst1)
+                  lst2
+                  (loop (cdr lst1) (cons (car lst1) lst2))))))
+    (lambda lists
+      (cond
+        ((null? lists) '())
+        ((null? (cdr lists)) (car lists))
+        (else
+         (apply revappend (loop (car lists) (cadr lists))
+                (cddr lists)))))))