readtable: case folding

2 files changed, 62 insertions, 37 deletions

diff --git a/README.rst b/README.rst
index ebc68a0..7fa167d 100644
--- a/README.rst
+++ b/README.rst
@@ -19,12 +19,12 @@ designed to be used by a severely limited Scheme interpreter, which
 * has fixnums only
 * only uses immutable strings
 * does not use "load" recursively
-* uses R3RS essental procedures only (with some exceptions)
+* uses R3RS essential procedures only (with some exceptions)
 
 The goal is to have the compiler run under the MiniScheme in ``miniscm``
 in DOS, and then run in GLLV to compile itself.
 
-A proper implementation must have
+A proper implementation must have, in addition to R3RS,
 
 * ``open-input-port``, ``read-char``
 * ``open-output-port``, ``write-char``
@@ -32,7 +32,6 @@ A proper implementation must have
 * ``and``, ``or``
 * ``error``
 
-If your system supports any macro system at all, ``cond-expand``,
-``and``, and ``or`` can be implemented. ``error`` can be implemented
-as in SRFI-23 : https://srfi.schemers.org/srfi-23/srfi-23.html .
-
+Hopefully your implementation has input and output ports (there's no other
+way to write a compiler). Everything else can be expressed in terms of
+macros or R3RS essential procedures.
diff --git a/read.scm b/read.scm
index 224a910..edea2b5 100644
--- a/read.scm
+++ b/read.scm
@@ -26,6 +26,7 @@
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Port reader wrapper
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define port->read-function
@@ -39,38 +40,50 @@
 ;;; (READ): Read the next character in the stream. Returns #F on EOF.
 ;;; (PUSH CHAR): Push CHAR such that it will be the next character read
 ;;; when (READ) is called.
+;;; (FOLD-CASE?): Returns a boolean if case folding is enabled.
+;;; (FOLD-CASE! BOOL): Sets the case folding to BOOL.
 (define port->read
   (lambda (read-function filename)
     (let ((line-number 1)
           (offset 0)
-          (pushback-buffer '()))
-      (let ((update-position
-             (lambda (ch)
-               (cond
-                 ((or (eof-object? ch) (not ch)) (set! ch #f))
-                 ((eqv? ch #\newline)
-                  (set! line-number (+ 1 line-number)) (set! offset 0))
-                 (offset (set! offset (+ 1 offset))))
-               ch)))
-        (lambda (op . args)
-          (cond
-            ((eq? op 'pos) (list filename line-number offset))
-            ((eq? op 'read)
-             (update-position
-              (if (null? pushback-buffer)
-                  (read-function)
-                  (let ((ch (car pushback-buffer)))
-                    (set! pushback-buffer (cdr pushback-buffer))
-                    ch))))
-            ((eq? op 'push)
-             (let ((ch (car args)))
-               (if (eqv? ch #\newline)
-                   (begin
-                     (set! line-number (- line-number 1))
-                     (set! offset #f))
-                   (set! offset (- offset 1)))
-               (set! pushback-buffer (cons ch pushback-buffer))))
-            (else (error "read->port: invalid" (cons op args)))))))))
+          (pushback-buffer '())
+          (fold-case? #f))
+      (letrec ((update-position!
+                (lambda (ch)
+                  (cond
+                    ((eqv? ch #\newline)
+                     (set! line-number (+ 1 line-number)) (set! offset 0))
+                    (offset (set! offset (+ 1 offset))))))
+               (process
+                (lambda (ch)
+                  (update-position! ch)
+                  (cond
+                    ((or (eof-object? ch) (not ch)) ch)
+                    (fold-case? (char-downcase ch))
+                    (else ch))))
+               (port
+                (lambda (op . args)
+                  (cond
+                    ((eq? op 'pos) (list filename line-number offset))
+                    ((eq? op 'read)
+                     (process
+                      (if (null? pushback-buffer)
+                          (read-function)
+                          (let ((ch (car pushback-buffer)))
+                            (set! pushback-buffer (cdr pushback-buffer))
+                            ch))))
+                    ((eq? op 'push)
+                     (let ((ch (car args)))
+                       (if (eqv? ch #\newline)
+                           (begin
+                             (set! line-number (- line-number 1))
+                             (set! offset #f))
+                           (set! offset (- offset 1)))
+                       (set! pushback-buffer (cons ch pushback-buffer))))
+                    ((eq? op 'fold-case?) fold-case?)
+                    ((eq? op 'fold-case!) (set! fold-case? (car args)))
+                    (else (error "read->port: invalid" (cons op args)))))))
+        port))))
 
 ;;; ;;;;;;;;;;;;;;
 ;;; Character maps
@@ -315,10 +328,19 @@
 (define readtable:top
   (readtable:update-many-sequence
    readtable:empty
+   (cons "#!fold-case"
+         (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))
-   (cons "#trouble" (readtable:return-value 15))))
+   (cons "#true" (readtable:return-value #t))))
 
 ;;; ;;;;;;;;;;;
 ;;; Test reader
@@ -334,8 +356,12 @@
              ch)))
      "test")))
 
-(let ((true-reader (%list->read (string->list "#t#false#true"))))
+(let ((true-reader (%list->read (string->list "#!fold-case#TRUE#!no-fold-case#TRUE"))))
   (display (list "first:" (readtable:top (true-reader 'read) #f true-reader)))
   (newline)
   (display (list "second: " (readtable:top (true-reader 'read) #f true-reader)))
+  (newline)
+  (display (list "third: " (readtable:top (true-reader 'read) #f true-reader)))
+  (newline)
+  (display (list "fourth: " (readtable:top (true-reader 'read) #f true-reader)))
   (newline))