attempt to read numbers with a readtable

Saving this because I might use it. The implementation is fragile.

SCHEME numbers are in infix notation, so forcing them into the
readtable implementation (which works best for prefix operators) is
like fitting a square peg into a round hole.

I'm going to try tokenizing the expression and parsing using an
operator-precedence parser (things like "+", "@", and "." are infix
operators).

2 files changed, 374 insertions, 7 deletions

diff --git a/README.rst b/README.rst
index abb5f5a..fc6671a 100644
--- a/README.rst
+++ b/README.rst
@@ -20,6 +20,7 @@ designed to be used by a severely limited Scheme interpreter, which
 * only uses immutable strings
 * does not use "load" recursively
 * uses R3RS essential procedures/syntax only (with some exceptions)
+* lacks quasiquote
 
 The goal is to have the compiler run under the MiniScheme in ``miniscm``
 in DOS, and then run in GLLV to compile itself.
diff --git a/read.scm b/read.scm
index 1007c00..73ecab2 100644
--- a/read.scm
+++ b/read.scm
@@ -54,6 +54,16 @@
     (lambda ()
       (read-char port))))
 
+(define string->read-function
+  (lambda (str)
+    (let ((index -1)
+          (length (string-length str)))
+      (lambda ()
+        (if (= index length)
+            #f
+            (begin
+              (set! index (+ 1 index))
+              (string-ref str index)))))))
 ;;; READ:
 ;;; 
 ;;; Stream readers contain mutable state. This is the case-folding mode
@@ -67,9 +77,13 @@
 ;;; (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)
+  (lambda (read-function filename . location)
+    (let ((line-number (if (null? location)
+                           1
+                           (car location)))
+          (offset (if (null? location)
+                      0
+                      (cadr location)))
           (pushback-buffer '())
           (datum-labels '())
           (fold-case? #f))
@@ -104,7 +118,7 @@
                 (lambda (ch)
                   (update-position! ch)
                   (cond
-                    ((or (eof-object? ch) (not ch)) ch)
+                    ((or (eof-object? ch) (not ch)) #f)
                     (fold-case? (char-downcase ch))
                     (else ch))))
                (port
@@ -290,6 +304,8 @@
 ;;; Identifier reader
 ;;; ;;;;;;;;;;;;;;;;;
 
+;;; Container for an IDENT object. Stores the VALUE as a string, and the
+;;; LOCATION as a list.
 (define read:ident
   (lambda (name location)
     (lambda (op . args)
@@ -298,6 +314,20 @@
         ((eq? op 'value) name)
         (else (error 'read:ident "invalid operation" op args))))))
 
+;;; Convert a read identifier to a reader.
+(define read:ident->port
+  (lambda (ident old-port)
+    (apply port->read
+           (string->read-function (ident 'value))
+           (old-port 'location))))
+
+;;; Create an IDENT-BUILDER object. This object encapsulates pushing
+;;; characters to create an ident, and stores the location of the start
+;;; of the identifier.
+;;; 
+;;; Inherits from LINKED-LIST.
+;;; 
+;;; (FINALIZE->IDENT): Return an IDENT object.
 (define read:ident-builder
   (lambda (location . start-char)
     (let ((char-list (linked-list:new)))
@@ -593,6 +623,339 @@
       (port 'restore-mutable! mutable))
     (readtable:next toplevel #f port)))
 
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Number reader.
+;;; 
+;;; Numbers are not written fully parenthesized. Instead, they are written
+;;; with prefix, infix, and postfix operators.
+;;; 
+;;; Parsing algorithm:
+;;; 
+;;; 1) If the current character is "#", read the next character and add
+;;;    that as a prefix. Goto 1.
+;;; 2) Read a real.
+;;; 3) If the next character is a "+" or "-", then the number is a
+;;;    complex number. Read a real and check for EOF, and return. Otherwise
+;;;    go to the next step.
+;;; 4) If the next character is "i", then the number is purely imaginary.
+;;;    Check that the next character is EOF and return.
+;;;    Otherwise go to the next step.
+;;; 5) If the next character is "@", the charcter is a complex number in
+;;;    polar form. Read the next number and check that afterwards is EOF.
+;;;    Return.
+;;; 6) If the next character is EOF, return the number.
+;;; 7) Return an error.
+;;; 
+;;; Real reading algorithm:
+;;; 
+;;; 1) If there is a sign, read it.
+;;; 2) If what follows is "inf.0" or "nan.0", return that. If what follows
+;;;    is "i", return that.
+;;; 3) Read in the radix.
+;;; 4) If there is a ".", read it and continue to read in the radix (the
+;;;    number may now be inexact).
+;;; 5) If an exponent marker is found, read that and read in the radix.
+;;; 6) If there is a "/", the number is a rational. Repeat reading a real.
+
+;;; A "special number", which is NAN.0 or INF.0.
+(define read:special-number
+  (lambda (location sign type)
+    (lambda (op . args)
+      (cond
+        ((eq? op 'location) location)
+        ((eq? op 'sign) sign)
+        ((eq? op 'type) type)))))
+
+;;; An integer number.
+(define read:integer-number
+  (lambda (location radix exactness sign as-string)
+    (if (not exactness)
+        (set! exactness 'exact))
+    (if (not radix)
+        (set! radix 'decimal))
+
+    (lambda (op . args)
+      (cond
+        ((eq? op 'location) location)
+        ((eq? op 'type) 'integer)
+        ((eq? op 'exactness) exactness)
+        ((eq? op 'radix) radix)
+        ((eq? op 'as-string) as-string)
+        ((eq? op 'sign) sign)
+        (else (error 'integer 'invalid op args))))))
+
+;;; A complex number.
+(define read:complex-number
+  (lambda (location real imaginary)
+    (lambda (op . args)
+      (cond
+        ((eq? op 'location) location)
+        ((eq? op 'type) 'complex)
+        ((eq? op 'real-part) real)
+        ((eq? op 'imaginary-part) imaginary)
+        (else (error 'complex-number 'invalid op args))))))
+
+;;; Create a purely imaginary number.
+(define read:purely-imaginary
+  (lambda (location exactness sign)
+    (read:complex-number
+     location
+     (read:integer-number #f 'decimal 'exact '+ "0")
+     (read:integer-number #f 'decimal exactness sign "1"))))
+
+(define read:exponential-builder
+  (lambda (whole-part fractional-part float-type)
+    (let ((exponential-part (linked-list:new)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'push!) (exponential-part 'push! (car args)))
+          (else (error 'exponential-builder 'invalid op args)))))))
+
+;;; Create a fractional/rational number.
+(define read:fractional-builder
+  (lambda (whole-part fractional-or-rational)
+    (let ((fractional-part (linked-list:new)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'push!) (fractional-part 'push! (car args)))
+          ((eq? op 'type) fractional-or-rational)
+          ((eq? op '->exponential)
+           (if (eq? fractional-or-rational 'rational)
+               (error 'fractional-builder "cannot add exponent part to a rational"))
+           (apply read:exponential-part
+                  whole-part
+                  (read:integer-number #f #f #f
+                                       (list->string (body '->list)))
+                  args))
+          (else (error 'fractional-builder 'invalid op args)))))))
+
+;;; Builds an integer without fractional components or exponent.
+(define read:integer-builder
+  (lambda ()
+    (let ((body (linked-list:new)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'push!) (body 'push-tail! (car args)))
+          ((eq? op '->fractional) (apply read:fractional-builder
+                                         body
+                                         'fractional
+                                         args))
+          ((eq? op '->rational) (apply read:fractional-builder
+                                       body
+                                       'rational
+                                       args))
+          ((eq? op '->exponential) (apply read:exponential-builder
+                                          body
+                                          #f
+                                          args))
+          (else (error 'invalid 'integer-builder op args)))))))
+
+;;; NUMBER-BUILDER:
+;;; Contains the state of the current number. Encapsulates the current
+;;; number's type, etc.
+;;; 
+;;; (RADIX!): Set the radix to BINARY, OCTAL, DECIMAL, or HEX.
+;;; (EXACTNESS!): Set the exactness to EXACT or INEXACT.
+;;; (SIGN!): Set the sign to + or -.
+(define read:number-builder
+  (lambda (location)
+    (let ((radix #f)
+          (exactness #f)
+          (sign '+)
+          (number (read:integer-builder)))
+      (lambda (op . args)
+        (cond
+          ((eq? op 'radix!) (set! radix (car args)))
+          ((eq? op 'exactness!) (set! exactness (car args)))
+          ((eq? op 'sign!) (set! sign (car args)))
+          ((eq? op '->nan.0) (read:special-number location sign 'nan.0))
+          ((eq? op '->inf.0) (read:special-number location sign 'inf.0))
+          ((eq? op 'with-imaginary-unit)
+           (set! number '->complex sign exactness)
+           (number 'push! 1)
+           (number 'finalize! sign exactness))
+          ((eq? op 'make-fractional!)
+           (if (not exactness)
+               (set! exactness 'inexact))
+           (set! number (number '->fractional exactness sign))
+           (set! sign #f))
+          ((eq? op 'make-rational!)
+           (set! number (number '->rational exactness sign))
+           (set! exactness #f)
+           (set! sign #f))
+          ((eq? op 'make-exponential!)
+           (if (not exactness)
+               (set! exactness 'inexact))
+           (set! number (number '->exponential exactness sign (car args))))
+          (else (error 'invalid op args)))))))
+
+;;; Operate on the NUMBER-BUILDER and then continue reading in the table.
+(define read:operate-pass
+  (lambda operation
+    (lambda (table _ number-builder port)
+      (number-builder operation)
+      (readtable:next table acc port))))
+
+(define readtable:make-complex
+  (lambda (_ char number-builder port)
+    (set! char (cond
+                 ((eq? char #\+) '+)
+                 ((eq? char #\-) '-)
+                 (else (error 'make-complex 'invalid-char char))))
+    (number-builder 'make-complex! char)
+    (let ((final-number (readtable:read-sign-for-number number-builder port)))
+      (let ((final-char (port 'read)))
+        (if (not (eqv? final-char #\i))
+            (error 'make-complex "invalid complex number"
+                   final-char
+                   number-builder
+                   port)
+            (let ((final-char (port 'read)))
+              (if final-char
+                  (error 'make-complex "invalid complex number"
+                         final-char
+                         number-builder
+                         port)
+                  final-number)))))))
+
+(define readtable:make-polar
+  (lambda (_ char number-builder port)
+    (number-builder 'make-complex-polar!)
+    (let ((final-number (readtable:read-sign-for-number number-builder port)))
+      (let ((final-char (port 'read)))
+        (if final-char
+            (error 'make-polar
+                   "invalid polar number"
+                   final-char
+                   number-builder
+                   port)
+            final-number)))))
+
+(define readtable:finalize-number
+  (lambda (_ __ number-builder ___)
+    (number-builder 'finalize!)))
+
+(define readtable:possible-imaginary
+  (readtable:empty/default (readtable:error 'possible-imaginary
+                                            "unexpected character"))
+  (list readtable:update #\+ read:make-complex)
+  (list readtable:update #\- read:make-complex)
+  (list readtable:update #f read:finalize-number)
+  (list readtable:udpate #\@ read:make-polar))
+
+;;; Add a value of the radix to the number builder, and continue reading
+;;; from the same table.
+(define read:add-radix-value
+  (lambda (table char acc port)
+    (acc 'push! char)
+    (readtable:next table acc port)))
+
+;;; The basic integer body reader. This handles all characters in the
+;;; number that are NOT a part of the radix. Things like ".", "/", etc.
+;;; 
+;;; This implements SRFI-169, which allows for skipped underscores inside
+;;; of a number. Multiple underscores are explicitly allowed, but other
+;;; non-conforming syntax is not necessarily allowed. If it is, it is
+;;; coincidental.
+(define readtable:integer-body-base
+  (readtable:process
+   (readtable:empty/default (readtable:jump readtable:possible-imaginary))
+   (list readtable:update #f read:finalize-number)
+   (list readtable:update #\_ readtable:skip)
+   (list readtable:update #\. (read:operate-pass 'make-fractional!))
+   (list readtable:update #\/ (read:operate-pass 'make-rational!))
+   (list readtable:update-list
+         (list #\e #\s #\f #\d #\l)
+         (read:operate-pass 'make-exponential!))))
+
+;;; Generate a readtable that accepts all characters in the list
+;;; VALID-RADIX as radix characters.
+(define readtable:integer-body-for-radix
+  (lambda (valid-radix)
+    (readtable:process
+     readtable:integer-body-base
+     (list readtable:update-list valid-radix read:add-radix-value))))
+
+;;; Read the rest of a special number value (i.e. "nf.0" after reading
+;;; "i") and return the special number container, erroring out if there
+;;; is unread data.
+(define readtable:rest-of-special-or-error
+  (lambda (rest-of-string conversion-function error-message)
+    (lambda (_ char number-builder port)
+      (let ((ident (readtable:read-ident #f char #f port)))
+        (if (equal? (ident 'value) rest-of-string)
+            (if (port 'peek)
+                (number-builder conversion-function)
+                (error 'rest-of-special 'not-at-eof
+                       rest-of-string number-builder port))
+            (error 'rest-of-special 'unknown-identifier
+                   rest-of-string (ident 'value)
+                   number-builder port))))))
+
+;;; Read a special number starting with "i", either INF.0 or I.
+(define readtable:special-number-starting/i
+  (readtable:process
+   (readtable:empty/default
+    (readtable:error 'special-number-starting/i 'invalid-after))
+   (list readtable:update #f
+         (lambda (_ __ number-builder ___)
+           (number-builder '->imaginary-unit)))
+   (list readtable:update #\n (readtable:rest-of-special-or-error
+                               "nf.0"
+                               '->inf.0
+                               'inf.0))))
+
+;;; Checks for "special" numbers, +NAN.0, +INF.0, +I, etc.
+(define readtable:check-for-special-number
+  (readtable:process
+   (readtable:empty/default (readtable:jump readtable:read-integer))
+   (list readtable:update #\n
+         (readtable:rest-of-special-or-error "nan.0"
+                                             '->nan.0
+                                             'nan.0))
+   (list readtalbe:update #\i readtable:special-number-starting/i)))
+
+;;; Read the sign in front of a number. Scheme identifiers can start with
+;;; + or - and ++1 or --1 are identifiers (for example). This reader only
+;;; reads one sign at most.
+(define readtable:read-sign-for-number
+  (let ((operate
+         (lambda operation
+           (lambda (_ __ number-builder port)
+             (apply number-builder operation)
+             (readtable:next readtable:check-for-special-number
+                             number-builder
+                             port)))))
+    (readtable:process
+     (readtable:empty/default (readtable:jump readtable:check-for-special-number))
+     (list readtable:update #\+ (operate 'sign! '+))
+     (list readtable:update #\- (operate 'sign! '-)))))
+
+;;; Read a numeric prefix code #B0101, #XFF, etc.
+(define readtable:number-prefix-code
+  (let ((update-prefix
+         (lambda operations
+           (lambda (_ __ number-builder port)
+             (apply number-builder operations)
+             (readtable:next readtable:number-start
+                             number-builder
+                             port)))))
+    (readtable:process
+     (readtable:empty/default (readtable:error 'invalid-number-prefix))
+     (list readtable:update #\b (update-radix 'radix! 'binary))
+     (list readtable:update #\o (update-radix 'radix! 'octal))
+     (list readtable:update #\d (update-radix 'radix! 'decimal))
+     (list readtable:update #\x (update-radix 'radix! 'hex))
+     (list readtable:update #\i (update-exactness 'exactness! 'inexact))
+     (list readtalbe:update #\e (update-exactness 'exactness! 'exact)))))
+
+;;; Read numeric prefixes, and skip to reading a number in the absence
+;;; of a sign.
+(define readtable:number-start
+  (readtable:process
+   (readtable:empty/default readtable:read-sign-for-number)
+   (list readtable:update #\# (readtable:jump/next readtable:number-prefix-code))))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Handling hash messages
 ;;; 
@@ -631,10 +994,13 @@
     (let ((ident (readtable:read-ident #f char #f port)))
       (let ((container (smap:search read:hash-messages
                                     (ident 'value))))
-        ;; TODO: check if the hash message starts a number.
         (if (null? container)
-            (error 'read-hash-messages 'unknown-constant
-                   (ident 'value))
+            ;; Numbers are parsed as identifiers, and then re-parsed.
+            (let ((port (read:ident->port ident port)))
+              (port 'fold-case! #t)
+              (readtable:next read:number-prefix
+                              (read:number-builder (port 'location))
+                              port))
             ((map:val container) acc port))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;