Readtable: fix propagation of default handlers in trie paths

Previous version did (ACTION 'UPDATE (CDR REST) ACTION) when a new
action had to be made. This caused default actions to propagate
through the trie.

While this isn't bad (it causes #TRU to be equal to #TRUE when that
was the last prefix in the tree), it can cause unexpected errors at
runtime, and no program should ever depend on its behavior.

The current solution is to make a new PASS readtable with a default
error action.

1 files changed, 56 insertions, 43 deletions

diff --git a/read.scm b/read.scm
index 440d910..8724e3c 100644
--- a/read.scm
+++ b/read.scm
@@ -159,6 +159,41 @@
               (else (error "readtable:exec: invalid" args))))))
       exec)))
 
+
+;;; ;;;;;;;;;;;;;;;
+;;; Default actions
+;;; ;;;;;;;;;;;;;;;
+
+(define readtable:update-many
+  (lambda (table . pairs)
+    (fold (lambda (pair table)
+            (readtable:add-sequence table (car pair)
+                                    (cdr pair)))
+          table
+          pairs)))
+
+;;; Signal error on this action.
+(define readtable:error-action
+  (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.
+;;; 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))))
+
+;;; Ignore everything and return a constant.
+(define readtable:return-value
+  (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
@@ -190,6 +225,21 @@
          (with-default-action
              (lambda (new-default-action)
                (readtable:new new-default-action charmap)))
+         (empty-pass/error
+          (lambda ()
+            (readtable:pass:new
+             (readtable:new (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)
@@ -198,11 +248,7 @@
                                (charmap:update
                                 charmap
                                 (car rest)
-                                (lambda (_ oldnode)
-                                  (if (null? oldnode)
-                                      (action 'update (cdr rest) action)
-                                      ((map:val oldnode)
-                                       'update (cdr rest) action))))))))
+                                (update-oldnode (cdr rest) action))))))
          (table
           (lambda (op . args)
             (cond
@@ -212,7 +258,7 @@
               ((eq? op 'with-default-action) (apply with-default-action
                                                     args))
               ((eq? op 'update) (apply update args))
-              (else (error "readtable: invalid" args))))))
+              (else (error "readtable: invalid" (cons op args)))))))
       table)))
 
 ;;; Add ACTION as the action to be taken in TABLE following SEQ.
@@ -224,40 +270,6 @@
                  (else seq))))
       (table 'update seq action))))
 
-;;; ;;;;;;;;;;;;;;;
-;;; Default actions
-;;; ;;;;;;;;;;;;;;;
-
-(define readtable:update-many
-  (lambda (table . pairs)
-    (fold (lambda (pair table)
-            (readtable:add-sequence table (car pair)
-                                    (cdr pair)))
-          table
-          pairs)))
-
-;;; Signal error on this action.
-(define readtable:error-action
-  (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.
-;;; 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))))
-
-;;; Ignore everything and return a constant.
-(define readtable:return-value
-  (lambda (value)
-    (readtable:exec:new
-     (lambda (table char acc port)
-       value))))
-
 ;;; ;;;;;;;;;;;;;;;;;;;
 ;;; Default readtables
 ;;; ;;;;;;;;;;;;;;;;;;;
@@ -285,7 +297,6 @@
 ;;; ;;;;;;;;;;;
 ;;; Test reader
 ;;; ;;;;;;;;;;;
-
 (define %list->read
   (lambda (seq)
     (port->read
@@ -297,6 +308,8 @@
              ch)))
      "test")))
 
-(let ((true-reader (%list->read (list #\# #\t #\r #\u #\e #\f))))
+(let ((true-reader (%list->read (string->list "#tro#f"))))
   (display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
-  (display (list "second: " (readtable:top (true-reader 'read) #f true-reader))))
+  (newline)
+  (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))
+  (newline))