read.scm: more complete support for special numbers

read.scm

@@ -325,6 +325,7 @@
         ((eq? op 'type) 'ident)
         ((eq? op 'location) location)
         ((eq? op 'value) name)
+        ((eq? op 'display) ((car args) name))
         (else (error 'read:ident "invalid operation" op args))))))
 
 (define read:ident-builder
@@ -378,6 +379,13 @@
    (list readtable:exclude-from-identifiers
          (list #\| %bol %eol #\' #\; #f))))
 
+;;; "Reduced" identifiers for use in #MATH().
+(define readtable:reduced-identifier
+  (readtable:process
+   readtable:identifier
+   (list readtable:exclude-from-identifiers
+         '(#\~ #\@ #\# #\$ #\% #\^ #\& #\* #\- #\= #\+ #\< #\> #\/ #\?))))
+
 ;;; Read an identifier starting with CHAR.
 (define read:read-ident
   (lambda (table char acc port)
@@ -582,6 +590,26 @@
 ;;; PREFIXES* SIGN? (RADIX+ ("." RADIX+)? | "." RADIX+) ("e" RADIX+)? "i"?
 ;;; Prefixes are handled by the "#" reader.
 
+(define read:number
+  (lambda (main sign exactness decimal exp-char exp-digits imaginary? location)
+    (lambda (op . args)
+      (cond
+        ((eq? op 'type) 'number)
+        ((eq? op 'display)
+         ((car args)
+          (list 'number main sign exactness decimal
+                exp-char exp-digits imaginary? location)))
+        ((eq? op (quote main)) main)
+        ((eq? op (quote sign)) sign)
+        ((eq? op (quote exactness)) exactness)
+        ((eq? op (quote decimal)) decimal)
+        ((eq? op (quote exp-char)) exp-char)
+        ((eq? op (quote exp-digits)) exp-digits)
+        ((eq? op (quote imaginary?)) imaginary?)
+        ((eq? op (quote radix)) radix)
+        ((eq? op (quote location)) location)
+        (else (error 'number 'invalid op))))))
+
 ;;; Incremental builder for a number, driven by the lexer.
 ;;; TODO: how will this be turned into a number, in the end?
 (define read:number-builder
@@ -607,6 +635,8 @@
           (cond
             ((eq? op 'push!) (apply append-part args))
             ((eq? op 'sign!) (set! sign (car args)))
+            ((eq? op 'sign) sign)
+            ((eq? op 'location) location)
             ((eq? op 'finalize)
              (if (not exactness)
                  (set! exactness 'exact))
@@ -616,9 +646,10 @@
                  (set! decimal '(0)))
              (if (null? exp-digits)
                  (set! exp-digits '(0)))
-             (list 'basic-number
+             (read:number main sign exactness decimal exp-char
-                   main sign exactness decimal exp-char exp-digits imaginary?))
+                          exp-digits imaginary? location))
             ((eq? op 'exactness!) (set! exactness (car args)))
+            ((eq? op 'exactness) exactness)
             ((eq? op 'radix-table!) (set! radix-table (car args)))
             ((eq? op 'set-imaginary!)
              (set! imaginary? #t))
@@ -641,14 +672,27 @@
             ((eq? op 'radix-table) radix-table)
             (else (error 'number-builder 'invalid op args))))))))
 
+(define read:imaginary-number
+  (lambda (sign loc . number-builder-cell)
+    (read:number '() sign (if (null? number-builder-cell)
+                              'exact
+                              ((car number-builder-cell) 'exactness))
+                 '() #\e '() #t loc)))
+
 (define read:special-number
-  (lambda (type sign location)
+  (lambda (type sign location imaginary? . number-builder-cell)
-    (lambda (op)
+    (let ((exactness (if (null? number-builder-cell)
-      (cond
+                         'exact
-        ((eq? op 'type) type)
+                         ((car number-builder-cell) 'exactness))))
-        ((eq? op 'sign) sign)
+      (lambda (op . args)
-        ((eq? op 'location) location)
+        (cond
-        (else (error 'special-numbe 'invalid op))))))
+          ((eq? op 'type) type)
+          ((eq? op 'display)
+           ((car args)
+            (list 'special-number type sign exactness imaginary?)))
+          ((eq? op 'sign) sign)
+          ((eq? op 'location) location)
+          (else (error 'special-numbe 'invalid op)))))))
 
 (define readtable:return-number
   (lambda (_ char acc port)
@@ -677,6 +721,27 @@
            (number-builder 'set-imaginary!)
            (number-builder 'finalize)))))
 
+(define read:general-radix-converter
+  (lambda (char)
+    (cond
+      ((eqv? char #\0) 0)
+      ((eqv? char #\1) 1)
+      ((eqv? char #\2) 2)
+      ((eqv? char #\3) 3)
+      ((eqv? char #\4) 4)
+      ((eqv? char #\5) 5)
+      ((eqv? char #\6) 6)
+      ((eqv? char #\7) 7)
+      ((eqv? char #\8) 8)
+      ((eqv? char #\9) 9)
+      ((eqv? char #\a) 10)
+      ((eqv? char #\b) 11)
+      ((eqv? char #\c) 12)
+      ((eqv? char #\d) 13)
+      ((eqv? char #\e) 14)
+      ((eqv? char #\f) 15)
+      (else (error 'general-radix-converter char)))))
+
 ;;; Generate a lexer given a list of numbers in the radix.
 (define readtable:for-radix
   (lambda (radix-list)
@@ -684,7 +749,7 @@
      readtable:number-main-table
      (list readtable:update radix-list
            (lambda (table char number-builder port)
-             (number-builder 'push! char)
+             (number-builder 'push! (read:general-radix-converter char))
              (readtable:next table number-builder port))))))
 
 (define readtable:for-bin
@@ -697,6 +762,33 @@
   (readtable:for-radix '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
                              #\a #\b #\c #\d #\e #\f)))
 
+(define read:possible-special-number
+  (lambda (_ char number-builder port)
+    (let ((ident (readtable:act readtable:reduced-identifier
+                                char
+                                (read:ident-builder
+                                 (number-builder 'location))
+                                port)))
+      (let ((loc (ident 'location))
+            (str (ident 'value))
+            (sign (number-builder 'sign)))
+        (cond
+          ((equal? str "nan.0") (read:special-number 'nan sign loc #f number-builder))
+          ((equal? str "nan.0i") (read:special-number 'nan sign loc #t number-builder))
+          ((equal? str "inf.0") (read:special-number 'inf sign loc #f number-builder))
+          ((equal? str "inf.0i") (read:special-number 'inf sign loc #t number-builder))
+          ((equal? str "i") (read:imaginary-number sign loc number-builder))
+          (else (error 'possible-special-number 'invalid str)))))))
+
+(define readtable:possible-special-number
+  (readtable:process
+   (readtable:empty/default (lambda (_ char number-builder port)
+                              (readtable:act (number-builder 'radix-table)
+                                             char
+                                             number-builder
+                                             port)))
+   (list readtable:update (list #\i #\n) read:possible-special-number)))
+
 ;;; Read the sign at the start of a number.
 (define readtable:read-sign
   (readtable:process
@@ -709,7 +801,7 @@
    (list readtable:update (list #\+ #\-)
          (lambda (_ char number-builder port)
            (number-builder 'sign! char)
-           (readtable:next (number-builder 'radix-table)
+           (readtable:next readtable:possible-special-number
                            number-builder
                            port)))
    (list readtable:update #\_ readtable:skip)))
@@ -811,6 +903,7 @@
            (set! finalized? #t)
            (set! value (car args))
            (set! toplevel #f))
+          ((eq? op 'display) ((car args) value))
           ((eq? op 'finalize->ident)
            (set! name (name 'finalize->ident)))
           ((eq? op 'value)
@@ -989,10 +1082,16 @@
         (let ((val (return-ident 'value))
               (loc (return-ident 'location)))
           (cond
-            ((equal? val "+inf.0") (read:special-number 'inf #\+ loc))
+            ((equal? val "+inf.0") (read:special-number 'inf #\+ loc #f))
-            ((equal? val "-inf.0") (read:special-number 'inf #\- loc))
+            ((equal? val "+inf.0i") (read:special-number 'inf #\+ loc #t))
-            ((equal? val "+nan.0") (read:special-number 'nan #\+ loc))
+            ((equal? val "-inf.0") (read:special-number 'inf #\- loc #f))
-            ((equal? val "-nan.0") (read:special-number 'nan #\- loc))
+            ((equal? val "-inf.0i") (read:special-number 'inf #\- loc #t))
+            ((equal? val "+nan.0") (read:special-number 'nan #\+ loc #f))
+            ((equal? val "+nan.0i") (read:special-number 'nan #\+ loc #t))
+            ((equal? val "-nan.0") (read:special-number 'nan #\- loc #t))
+            ((equal? val "-nan.0i") (read:special-number 'nan #\- loc #f))
+            ((equal? val "+i") (read:imaginary-number #\+ loc))
+            ((equal? val "-i") (read:imaginary-number #\- loc))
             (else val))))))
    (list readtable:update '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
          (lambda (_ char ident-builder port)
@@ -1066,12 +1165,9 @@
                                  (if (not (null? (intset:in used-counters cur-cntr)))
                                      (list 'def cur-cntr '= returned)
                                      returned)))))))
-                    ((procedure? value)
+                    ;; Must pass UNCYCLE to DISPLAY in order to preserve
-                     (let ((type (value 'type)))
+                    ;; state.
-                       (cond
+                    ((procedure? value) (value 'display uncycle))
-                         ((eq? type 'ident) (value 'value))
-                         ((eq? type 'datum-label) (uncycle (value 'value)))
-                         (else (vector 'unrepresentable type)))))
                     (else value)))))
         (uncycle value)))))
 
@@ -1133,4 +1229,9 @@
 (read-all "-inf.0")
 (read-all "+nan.0")
 (read-all "-100.5e5")
-
+(read-all "#b+nan.0")
+(read-all "#i+nan.0")
+(read-all "#e-inf.0")
+(read-all "+inf.0i")
+(read-all "+i")
+(read-all "++i")