From b94e12ee33090d398caeac957de83c5039225272 Mon Sep 17 00:00:00 2001
From: Peter McGoron <code@mcgoron.com>
Date: Fri, 27 Sep 2024 15:40:30 -0400
Subject: [PATCH] read: hash constants and directives

---
 read.scm | 49 +++++++++++++++++++++++++++++++++++++------------
 set.scm  |  2 +-
 2 files changed, 38 insertions(+), 13 deletions(-)

diff --git a/read.scm b/read.scm
index c430240..df2f97c 100644
--- a/read.scm
+++ b/read.scm
@@ -35,7 +35,6 @@
 ;;; All tokens are procedure-encapsulated objects, since the reader should
 ;;; never return a literal procedure. Each procedure has a TYPE message.
 
-
 (load "chez-compat.scm")
 (load "util.scm")
 (load "set.scm")
@@ -515,16 +514,6 @@
                                      port))))))
     loop))
 
-;;; Encapsulate LINKED-LIST object with an additional value for the
-;;; toplevel table.
-(define linked-list/toplevel:new
-  (lambda (toplevel)
-    (let ((ll (linked-list:new)))
-      (lambda (op . args)
-        (cond
-          ((eq? op 'toplevel) toplevel)
-          (else (apply ll op args)))))))
-
 (define read:datum-label
   (lambda (location toplevel)
     (let ((finalized? #f)
@@ -597,9 +586,42 @@
       (port 'restore-mutable! mutable))
     (readtable:next toplevel #f port)))
 
+;;; String map from constants to procedures with formal arguments
+;;; (TOPLEVEL PORT)
+;;; with TOPLEVEL being the current toplevel table and PORT being the
+;;; current port being read from.
+;;; 
+;;; Each one must return something. Directives that return nothing must
+;;; call the toplevel again.
+(define read:hash-constants
+  (smap:insert-many
+   '()
+   (cons "true" (lambda unused #t))
+   (cons "false" (lambda unused #f))
+   (cons "t" (lambda unused #t))
+   (cons "f" (lambda unused #f))
+   (cons "!fold-case"
+         (lambda (toplevel port)
+           (port 'fold-case! #t)
+           (readtable:act toplevel (port 'read) #f port)))
+   (cons "!no-fold-case"
+         (lambda (toplevel port)
+           (port 'fold-case! #f)
+           (readtable:act toplevel (port 'read) #f port)))))
+
+(define read:read-hash-constants
+  (lambda (_ char acc port)
+    (let ((ident (readtable:read-ident #f char #f port)))
+      (let ((container (smap:search read:hash-constants
+                                    (ident 'value))))
+        (if (null? container)
+            (error 'read-hash-constants 'unknown-constant
+                   (ident 'value))
+            ((map:val container) acc port))))))
+
 (define readtable:hash
   (readtable:process
-   (readtable:empty/default (readtable:error 'hash "unimplemented"))
+   (readtable:empty/default read:read-hash-constants)
    (list readtable:update #\| (readtable:jump/next readtable:block-comment))
    (list readtable:update #\; readtable:datum-comment)
    (list readtable:update-list readtable:digits ; Datum labels
@@ -712,3 +734,6 @@
 (read-all "#(a b #(c #|close#|comment|#|#y))")
 (read-all "(this has a #;(call with (current continuation)) datum comment)")
 (read-all "#0=(#0# not unix)")
+(read-all "#!no-fold-case #!fold-case #!NO-FOLD-CASE #false")
+(read-all "#!fold-case #TRUE")
+
diff --git a/set.scm b/set.scm
index 52d10b6..f096121 100644
--- a/set.scm
+++ b/set.scm
@@ -463,7 +463,7 @@
 (define smap:insert-many
   (lambda (smap . pairs)
     (fold (lambda (pair smap)
-            (smap:insert smap (car pair) (cdr pair)))
+            (car (smap:insert smap (car pair) (cdr pair))))
           smap
           pairs)))