From 3f56b03f1a145e8ce567609a65e5e2a41ae26e7e Mon Sep 17 00:00:00 2001
From: Peter McGoron <code@mcgoron.com>
Date: Sat, 7 Sep 2024 19:41:22 -0400
Subject: [PATCH] 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.
---
 read.scm | 19 ++++++++++++++++---
 1 file 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)))