From b9a14601154382e3034cdb7ebd2a08029e711618 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Sun, 13 Oct 2024 21:21:27 -0400 Subject: [PATCH] read.scm: more complete support for special numbers --- read.scm | 145 ++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 123 insertions(+), 22 deletions(-) diff --git a/read.scm b/read.scm index 53d7f6f..e1542b4 100644 --- a/read.scm +++ b/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 - main sign exactness decimal exp-char exp-digits imaginary?)) + (read:number main sign exactness decimal exp-char + 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 (op) - (cond - ((eq? op 'type) type) - ((eq? op 'sign) sign) - ((eq? op 'location) location) - (else (error 'special-numbe 'invalid op)))))) + (lambda (type sign location imaginary? . number-builder-cell) + (let ((exactness (if (null? number-builder-cell) + 'exact + ((car number-builder-cell) 'exactness)))) + (lambda (op . args) + (cond + ((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)) - ((equal? val "+nan.0") (read:special-number 'nan #\+ loc)) - ((equal? val "-nan.0") (read:special-number 'nan #\- loc)) + ((equal? val "+inf.0") (read:special-number 'inf #\+ loc #f)) + ((equal? val "+inf.0i") (read:special-number 'inf #\+ loc #t)) + ((equal? val "-inf.0") (read:special-number 'inf #\- loc #f)) + ((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) - (let ((type (value 'type))) - (cond - ((eq? type 'ident) (value 'value)) - ((eq? type 'datum-label) (uncycle (value 'value))) - (else (vector 'unrepresentable type))))) + ;; Must pass UNCYCLE to DISPLAY in order to preserve + ;; state. + ((procedure? value) (value 'display uncycle)) (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")