readtable: when adding sequences to the readtable, push the last

read character back to the character reader before executing the
action.

This fixes the issue where sequences eat characters in front of them.

1 files changed, 16 insertions, 3 deletions

diff --git a/read.scm b/read.scm
index cd81daf..224a910 100644
--- a/read.scm
+++ b/read.scm
@@ -70,7 +70,7 @@
                      (set! offset #f))
                    (set! offset (- offset 1)))
                (set! pushback-buffer (cons ch pushback-buffer))))
-            (else (error "read->port: invalid" args))))))))
+            (else (error "read->port: invalid" (cons op args)))))))))
 
 ;;; ;;;;;;;;;;;;;;
 ;;; Character maps
@@ -272,6 +272,19 @@
               (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))))))
+
 ;;; Add ACTION as the action to be taken in TABLE following SEQ.
 ;;; The action is wrapped in an empty PASS table with ACTION as the default
 ;;; action. This normalizes the character ACTION is passed.
@@ -281,7 +294,7 @@
                  ((char? seq) (list seq))
                  ((string? seq) (string->list seq))
                  (else seq))))
-      (table 'update seq (readtable:pass/blank action)))))
+      (table 'update seq (readtable:sequence-wrapper action)))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;
 ;;; Default readtables
@@ -321,7 +334,7 @@
              ch)))
      "test")))
 
-(let ((true-reader (%list->read (string->list "#true#f"))))
+(let ((true-reader (%list->read (string->list "#t#false#true"))))
   (display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
   (newline)
   (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))