readtable: case folding

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.

read.scm

@@ -26,6 +26,7 @@
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Port reader wrapper
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define port->read-function
@@ -39,24 +40,33 @@
 ;;; (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
+          (pushback-buffer '())
+          (fold-case? #f))
+      (letrec ((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)))
+                    (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)
-             (update-position
+                     (process
                       (if (null? pushback-buffer)
                           (read-function)
                           (let ((ch (car pushback-buffer)))
@@ -70,7 +80,10 @@
                              (set! offset #f))
                            (set! offset (- offset 1)))
                        (set! pushback-buffer (cons ch pushback-buffer))))
-            (else (error "read->port: invalid" (cons op args)))))))))
+                    ((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))