peter
/
UNSLISP
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

read.scm: more complete support for special numbers

This commit is contained in:
Peter McGoron 2024-10-13 21:21:27 -04:00
parent a769fd2511
commit b9a1460115
1 changed files with 123 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
read.scm
View File

@ -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")