read: character constants

1 files changed, 52 insertions, 5 deletions

diff --git a/read.scm b/read.scm
index bb84f0c..66b3962 100644
--- a/read.scm
+++ b/read.scm
@@ -593,6 +593,13 @@
       (port 'restore-mutable! mutable))
     (readtable:next toplevel #f port)))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Handling hash messages
+;;; 
+;;; A "hash message" is any identifier that immediately follows a "#".
+;;; This can be a constant, a part of a constant (like for numbers), or
+;;; a directive (like #!FOLD-CASE).
+
 ;;; String map from constants to procedures with formal arguments
 ;;; (TOPLEVEL PORT)
 ;;; with TOPLEVEL being the current toplevel table and PORT being the
@@ -600,7 +607,7 @@
 ;;; 
 ;;; Each one must return something. Directives that return nothing must
 ;;; call the toplevel again.
-(define read:hash-constants
+(define read:hash-messages
   (smap:insert-many
    '()
    (cons "true" (lambda unused #t))
@@ -619,21 +626,60 @@
            (port 'fold-case! #f)
            (readtable:act toplevel (port 'read) #f port)))))
 
-(define read:read-hash-constants
+(define read:read-hash-messages
   (lambda (_ char acc port)
     (let ((ident (readtable:read-ident #f char #f port)))
-      (let ((container (smap:search read:hash-constants
+      (let ((container (smap:search read:hash-messages
                                     (ident 'value))))
+        ;; TODO: check if the hash message starts a number.
         (if (null? container)
-            (error 'read-hash-constants 'unknown-constant
+            (error 'read-hash-messages 'unknown-constant
                    (ident 'value))
             ((map:val container) acc port))))))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;
+;;; Characters
+;;; 
+;;; For completeness, this adds a few more newline characters that are C
+;;; escape sequences but are not standard Scheme.
+
+(define read:named-characters
+  (smap:insert-many
+   '()
+   (cons "null" (integer->char 0))
+   (cons "alarm" (integer->char #x7))
+   (cons "backspace" (integer->char #x8))
+   (cons "tab" (integer->char #x9))
+   (cons "newline" (integer->char #xA))
+   (cons "vertical-tab" (integer->char #xB))
+   (cons "form-feed" (integer->char #xC))
+   (cons "return" (integer->char #xD))
+   (cons "escape" (integer->char #x1B))
+   (cons "space" (integer->char #x20))
+   (cons "delete" (integer->char #x7F))))
+
+(define readtable:character
+  (lambda (_ char __ port)
+    (let ((char (port 'read)))
+      (let ((ident (readtable:read-ident #f char #f port)))
+        (let ((container (smap:search read:named-characters
+                                    (ident 'value))))
+          (display (ident 'value))
+          (newline)
+          (cond
+            ((and (null? container)
+                (= (string-length (ident 'value)) 1))
+             (string-ref (ident 'value) 0))
+            ((null? container) (error 'character 'unknown-character ident))
+            (else (map:val container))))))))
+
 (define readtable:hash
   (readtable:process
-   (readtable:empty/default read:read-hash-constants)
+   (readtable:empty/default read:read-hash-messages)
+   ;; TODO: add whitespace to fail
    (list readtable:update #\| (readtable:jump/next readtable:block-comment))
    (list readtable:update #\; readtable:datum-comment)
+   (list readtable:update #\\ readtable:character)
    (list readtable:update-list readtable:digits ; Datum labels
          (lambda (_ char toplevel port)
            (readtable:act readtable:datum-label-next
@@ -747,3 +793,4 @@
 (read-all "#!no-fold-case #!fold-case #!NO-FOLD-CASE #false")
 (read-all "#!fold-case #TRUE")
 (read-all "#u8(x y z w)")
+(read-all "#\\newline")