conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

the reader now understands some complex numbers.

This commit is contained in:
Abdulaziz Ghuloum 2008-06-02 00:01:59 -07:00
parent a492d318e1
commit be37f629c5
4 changed files with 333 additions and 528 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

309
scheme/ikarus.reader.ss
View File

@ -20,6 +20,7 @@
annotation-expression annotation-source annotation-expression annotation-source
annotation-stripped) annotation-stripped)
(import (import
(only (ikarus.string-to-number) define-string->number-parser)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (ikarus system $pairs)
@ -255,8 +256,8 @@
(die/p p 'tokenize "invalid syntax" (die/p p 'tokenize "invalid syntax"
(string-append ".." (string c)))]))] (string-append ".." (string c)))]))]
[else [else
(cons 'datum (cons 'datum
(tokenize-decimal-no-digits p '(#\.) #f))])))) (dot p '(#\.) 10 #f #f))]))))
(define tokenize-char* (define tokenize-char*
(lambda (i str p d) (lambda (i str p d)
(cond (cond
@ -566,17 +567,17 @@
[else (die/p p 'tokenize [else (die/p p 'tokenize
(format "invalid sequence #v~a" c))]))] (format "invalid sequence #v~a" c))]))]
[(memq c '(#\e #\E)) [(memq c '(#\e #\E))
(cons 'datum (tokenize-exactness-mark p (list c #\#) 'e))] (cons 'datum (parse-string p (list c #\#) 10 #f 'e))]
[(memq c '(#\i #\I)) [(memq c '(#\i #\I))
(cons 'datum (tokenize-exactness-mark p (list c #\#) 'i))] (cons 'datum (parse-string p (list c #\#) 10 #f 'i))]
[(memq c '(#\b #\B)) [(memq c '(#\b #\B))
(cons 'datum (tokenize-radix-mark p (list c #\#) 2))] (cons 'datum (parse-string p (list c #\#) 2 2 #f))]
[(memq c '(#\x #\X)) [(memq c '(#\x #\X))
(cons 'datum (tokenize-radix-mark p (list c #\#) 16))] (cons 'datum (parse-string p (list c #\#) 16 16 #f))]
[(memq c '(#\o #\O)) [(memq c '(#\o #\O))
(cons 'datum (tokenize-radix-mark p (list c #\#) 8))] (cons 'datum (parse-string p (list c #\#) 8 8 #f))]
[(memq c '(#\d #\D)) [(memq c '(#\d #\D))
(cons 'datum (tokenize-radix-mark p (list c #\#) 10))] (cons 'datum (parse-string p (list c #\#) 10 10 #f))]
[($char= #\@ c) [($char= #\@ c)
(when (eq? (port-mode p) 'r6rs-mode) (when (eq? (port-mode p) 'r6rs-mode)
(die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode" (die/p-1 p 'tokenize "fasl syntax is invalid in #!r6rs mode"
@ -586,233 +587,30 @@
[else [else
(die/p-1 p 'tokenize (die/p-1 p 'tokenize
(format "invalid syntax #~a" c))]))) (format "invalid syntax #~a" c))])))
(define (tokenize-exactness-mark p ls exact?)
(let ([c (read-char p)]) (define (num-error p str ls)
(cond (die/p-1 p 'read "invalid numeric sequence"
[(eof-object? c) (num-error p "eof object" ls)] (list->string (reverse ls))))
[(radix-digit c 10) =>
(lambda (d) (define-syntax port-config
(tokenize-integer p (cons c ls) exact? 10 d))] (syntax-rules (GEN-TEST GEN-ARGS FAIL)
[(char=? c #\.) [(_ GEN-ARGS k . rest) (k (p ac) . rest)]
(tokenize-decimal-no-digits p (cons c ls) exact?)] [(_ FAIL (p ac))
[(char=? c #\-) (num-error p "invalid numeric sequence" ac)]
(- (tokenize-integer-no-digits p (cons c ls) exact? 10))] [(_ GEN-TEST var next (p ac) eof-case char-case)
[(char=? c #\+) (let ([c (peek-char p)])
(tokenize-integer-no-digits p (cons c ls) exact? 10)] (if (or (eof-object? c) (delimiter? c))
[(char=? c #\#) eof-case
(let ([c1 (read-char p)]) (let ([var c])
(cond (define-syntax next
[(eof-object? c1) (syntax-rules ()
(num-error p "eof object" (cons c ls))] [(_ who args (... ...))
[(memv c1 '(#\b #\B)) (who p (cons (get-char p) ac) args (... ...))]))
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 2)] char-case)))]))
[(memv c1 '(#\x #\X))
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 16)] (define-string->number-parser port-config
[(memv c1 '(#\o #\O)) (parse-string digit+ sign dot))
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 8)]
[(memv c1 '(#\d #\D))
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 10)]
[else (num-error p "invalid sequence" (cons* c1 c ls))]))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-radix-mark p ls radix)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c radix) =>
(lambda (d)
(tokenize-integer p (cons c ls) #f radix d))]
[(char=? c #\.)
(unless (= radix 10)
(num-error p "invalid decimal" (cons c ls)))
(tokenize-decimal-no-digits p (cons c ls) #f)]
[(char=? c #\-)
(- (tokenize-integer-no-digits p (cons c ls) #f radix))]
[(char=? c #\+)
(tokenize-integer-no-digits p (cons c ls) #f radix)]
[(char=? c #\#)
(let ([c1 (read-char p)])
(cond
[(eof-object? c1)
(num-error p "eof object" (cons c ls))]
[(memv c1 '(#\e #\E))
(tokenize-radix/exactness-marks p (cons c1 (cons c ls))
'e radix)]
[(memv c1 '(#\i #\I))
(tokenize-radix/exactness-marks p (cons c1 (cons c ls))
'i radix)]
[else (num-error p "invalid sequence" (cons* c1 c ls))]))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-radix/exactness-marks p ls exact? radix)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c radix) =>
(lambda (d)
(tokenize-integer p (cons c ls) exact? radix d))]
[(char=? c #\.)
(unless (= radix 10)
(num-error p "invalid decimal" (cons c ls)))
(tokenize-decimal-no-digits p (cons c ls) exact?)]
[(char=? c #\-)
(- (tokenize-integer-no-digits p (cons c ls) exact? radix))]
[(char=? c #\+)
(tokenize-integer-no-digits p (cons c ls) exact? radix)]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-integer p ls exact? radix ac)
(define (tokenize-denom-start p ls exact? radix num)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c radix) =>
(lambda (d)
(tokenize-denom p (cons c ls) exact? radix num d))]
[(char=? c #\-)
(tokenize-denom-no-digits p (cons c ls) exact? radix (- num))]
[(char=? c #\+)
(tokenize-denom-no-digits p (cons c ls) exact? radix num)]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-denom-no-digits p ls exact? radix num)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c radix) =>
(lambda (d)
(tokenize-denom p (cons c ls) exact? radix num d))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-denom p ls exact? radix num ac)
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(read-char p)
(if (= ac 0)
(num-error p "zero denominator" ls)
(convert/exact exact? (/ num ac)))]
[(radix-digit c radix) =>
(lambda (d)
(read-char p)
(tokenize-denom p (cons c ls) exact? radix num
(+ (* radix ac) d)))]
[(delimiter? c)
(if (= ac 0)
(num-error p "zero denominator" ls)
(convert/exact exact? (/ num ac)))]
[else (num-error p "invalid sequence" (cons c ls))])))
(let ([c (peek-char p)])
(cond
[(eof-object? c) (convert/exact exact? ac)]
[(radix-digit c radix) =>
(lambda (d)
(read-char p)
(tokenize-integer p (cons c ls) exact? radix
(+ (* ac radix) d)))]
[(char=? c #\.)
(unless (= radix 10)
(num-error p "invalid decimal" (cons c ls)))
(read-char p)
(tokenize-decimal p (cons c ls) exact? ac 0)]
[(char=? c #\/)
(read-char p)
(tokenize-denom-start p (cons #\/ ls) exact? radix ac)]
[(memv c '(#\e #\E)) ; exponent
(read-char p)
(unless (= radix 10)
(num-error p "invalid decimal" (cons c ls)))
(let ([ex (tokenize-exponent-start p (cons c ls))])
(convert/exact (or exact? 'i)
(* ac (expt radix ex))))]
[(delimiter? c)
(convert/exact exact? ac)]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-exponent-start p ls)
(define (tokenize-exponent-no-digits p ls)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c 10) =>
(lambda (d)
(tokenize-exponent p (cons c ls) d))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-exponent p ls ac)
(let ([c (peek-char p)])
(cond
[(eof-object? c) ac]
[(radix-digit c 10) =>
(lambda (d)
(read-char p)
(tokenize-exponent p (cons c ls)
(+ (* ac 10) d)))]
[(delimiter? c) ac]
[else (num-error p "invalid sequence" (cons c ls))])))
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c 10) =>
(lambda (d)
(tokenize-exponent p (cons c ls) d))]
[(char=? c #\-)
(- (tokenize-exponent-no-digits p (cons c ls)))]
[(char=? c #\+)
(tokenize-exponent-no-digits p (cons c ls))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-decimal p ls exact? ac exp)
(let ([c (peek-char p)])
(cond
[(eof-object? c)
(let ([ac (* ac (expt 10 exp))])
(convert/exact (or exact? 'i) ac))]
[(radix-digit c 10) =>
(lambda (d)
(read-char p)
(tokenize-decimal p (cons c ls) exact?
(+ (* ac 10) d) (- exp 1)))]
[(memv c '(#\e #\E))
(read-char p)
(let ([ex (tokenize-exponent-start p (cons c ls))])
(let ([ac (* ac (expt 10 (+ exp ex)))])
(convert/exact (or exact? 'i) ac)))]
[(delimiter? c)
(let ([ac (* ac (expt 10 exp))])
(convert/exact (or exact? 'i) ac))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-decimal-no-digits p ls exact?)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "eof object" ls)]
[(radix-digit c 10) =>
(lambda (d)
(tokenize-decimal p (cons c ls) exact? d -1))]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (convert/exact exact? n)
(if (eq? exact? 'i)
(exact->inexact n)
n))
(define (radix-digit c radix)
(case radix
[(10)
(cond
[(char<=? #\0 c #\9)
(fx- (char->integer c) (char->integer #\0))]
[else #f])]
[(16)
(cond
[(char<=? #\0 c #\9)
(fx- (char->integer c) (char->integer #\0))]
[(char<=? #\a c #\f)
(fx- (char->integer c) (fx- (char->integer #\a) 10))]
[(char<=? #\A c #\F)
(fx- (char->integer c) (fx- (char->integer #\A) 10))]
[else #f])]
[(8)
(cond
[(char<=? #\0 c #\7)
(fx- (char->integer c) (char->integer #\0))]
[else #f])]
[(2)
(case c
[(#\0) 0]
[(#\1) 1]
[else #f])]
[else (die 'radix-digit "invalid radix" radix)]))
(define (read-char* p ls str who ci? delimited?) (define (read-char* p ls str who ci? delimited?)
(let f ([i 0] [ls ls]) (let f ([i 0] [ls ls])
(cond (cond
@ -836,37 +634,6 @@
(die/p-1 p 'tokenize (die/p-1 p 'tokenize
(format "invalid ~a: ~s" who (format "invalid ~a: ~s" who
(list->string (reverse (cons c ls)))))]))]))) (list->string (reverse (cons c ls)))))]))])))
(define (tokenize-integer/nan/inf-no-digits p ls)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "invalid eof" ls)]
[(radix-digit c 10) =>
(lambda (d)
(tokenize-integer p (cons c ls) #f 10 d))]
[(char=? c #\.)
(tokenize-decimal-no-digits p (cons c ls) #f)]
[(memv c '(#\i #\I))
(read-char* p (cons #\i ls) "nf.0" "number sequence" #t #t)
+inf.0]
[(memv c '(#\n #\N))
(read-char* p (cons #\i ls) "an.0" "number sequence" #t #t)
+nan.0]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (tokenize-integer-no-digits p ls exact? radix?)
(let ([c (read-char p)])
(cond
[(eof-object? c) (num-error p "invalid eof" ls)]
[(radix-digit c (or radix? 10)) =>
(lambda (d)
(tokenize-integer p (cons c ls) exact? (or radix? 10) d))]
[(char=? c #\.)
(when (and radix? (not (= radix? 10)))
(num-error p "invalid decimal" (cons c ls)))
(tokenize-decimal-no-digits p (cons c ls) exact?)]
[else (num-error p "invalid sequence" (cons c ls))])))
(define (num-error p str ls)
(die/p-1 p 'read "invalid numeric sequence"
(list->string (reverse ls))))
(define (tokenize-hashnum p n) (define (tokenize-hashnum p n)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
@ -948,10 +715,10 @@
'(macro . unquote-splicing)] '(macro . unquote-splicing)]
[else '(macro . unquote)]))] [else '(macro . unquote)]))]
[($char= #\# c) (tokenize-hash p)] [($char= #\# c) (tokenize-hash p)]
[(radix-digit c 10) => [(char<=? #\0 c #\9)
(lambda (d) (let ([d (fx- (char->integer c) (char->integer #\0))])
(cons 'datum (cons 'datum
(tokenize-integer p (list c) #f 10 d)))] (digit+ p (list c) 10 #f +1 d)))]
[(initial? c) [(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))]) (let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))] (cons 'datum (string->symbol (list->string ls))))]
@ -965,7 +732,7 @@
[(delimiter? c) '(datum . +)] [(delimiter? c) '(datum . +)]
[else [else
(cons 'datum (cons 'datum
(tokenize-integer/nan/inf-no-digits p '(#\+)))]))] (sign p '(#\+) 10 #f +1))]))]
[(memq c '(#\-)) [(memq c '(#\-))
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
@ -978,7 +745,7 @@
(cons 'datum (string->symbol str))))] (cons 'datum (string->symbol str))))]
[else [else
(cons 'datum (cons 'datum
(- (tokenize-integer/nan/inf-no-digits p '(#\-))))]))] (sign p '(#\-) 10 #f -1))]))]
[($char= #\. c) [($char= #\. c)
(tokenize-dot p)] (tokenize-dot p)]
[($char= #\| c) [($char= #\| c)

547
scheme/ikarus.string-to-number.ss
View File

@ -1,283 +1,324 @@
(library (ikarus.string-to-number) (library (ikarus.string-to-number)
(export string->number) (export string->number define-string->number-parser)
(import (except (ikarus) string->number)) (import (except (ikarus) string->number))
(module (string->number) (define who 'string->number)
(define who 'string->number) (define (do-sn/ex sn ex ac)
(define (do-sn/ex sn ex ac) (* sn (if (eq? ex 'i) (inexact ac) ac)))
(* sn (if (eq? ex 'i) (inexact ac) ac))) (define (do-dec-sn/ex sn ex ac)
(define (do-dec-sn/ex sn ex ac) (* sn (if (eq? ex 'e) ac (inexact ac))))
(* sn (if (eq? ex 'e) ac (inexact ac)))) (define (digit c r)
(define (digit c r) (let ([n (fx- (char->integer c) (char->integer #\0))])
(let ([n (fx- (char->integer c) (char->integer #\0))]) (cond
(cond [(and (fx>=? n 0) (fx< n r)) n]
[(and (fx>=? n 0) (fx< n r)) n] [(eqv? r 16)
[(eqv? r 16) (let ([n (fx- (char->integer c) (char->integer #\a))])
(let ([n (fx- (char->integer c) (char->integer #\a))])
(cond
[(and (fx>=? n 0) (fx< n 6)) (+ n 10)]
[else
(let ([n (fx- (char->integer c) (char->integer #\A))])
(cond
[(and (fx>=? n 0) (fx< n 6)) (+ n 10)]
[else #f]))]))]
[else #f])))
(module (define-parser)
(define-syntax gen-empty
(syntax-rules (eof)
[(_ C Ca) (C FAIL Ca)]
[(_ C Ca [(eof) then] . rest) then]
[(_ C Ca other . rest) (gen-empty C Ca . rest)]))
(define-syntax gen-char
(syntax-rules (eof =>)
[(_ C Ca c) (C FAIL Ca)]
[(_ C Ca c [(eof) then] . rest)
(gen-char C Ca c . rest)]
[(_ C Ca c [(test . args) => result then] . rest)
(cond (cond
[(test c . args) => [(and (fx>=? n 0) (fx< n 6)) (+ n 10)]
(lambda (result) then)] [else
[else (gen-char C Ca c . rest)])] (let ([n (fx- (char->integer c) (char->integer #\A))])
[(_ C Ca c [ls then] . rest) (cond
(if (memv c 'ls) [(and (fx>=? n 0) (fx< n 6)) (+ n 10)]
then [else #f]))]))]
(gen-char C Ca c . rest))])) [else #f])))
(define-syntax gen-clause
(syntax-rules () (module (define-parser)
[(_ (Ca ...) C next fail name (arg* ...) (clause* ...)) (define-syntax gen-empty
(define (name Ca ... arg* ...) (syntax-rules (eof)
(define-syntax fail [(_ C Ca) (C FAIL Ca)]
(syntax-rules () [(_ C Ca [(eof) then] . rest) then]
[(_) (C FAIL (Ca ...))])) [(_ C Ca other . rest) (gen-empty C Ca . rest)]))
(cond (define-syntax gen-char
[(C GEN-EOF? (Ca ...)) (syntax-rules (eof =>)
(gen-empty C (Ca ...) clause* ...)] [(_ C Ca c) (C FAIL Ca)]
[else [(_ C Ca c [(eof) then] . rest)
(let ([c (C GEN-REF (Ca ...))]) (gen-char C Ca c . rest)]
(define-syntax next [(_ C Ca c [(test . args) => result then] . rest)
(syntax-rules () (cond
[(_ who args (... ...)) [(test c . args) =>
(C GEN-NEXT (Ca ...) who args (... ...))])) (lambda (result) then)]
(gen-char C (Ca ...) c clause* ...))]))])) [else (gen-char C Ca c . rest)])]
(define-syntax define-parser [(_ C Ca c [ls then] . rest)
(syntax-rules () (if (memv c 'ls)
then
(gen-char C Ca c . rest))]))
(define-syntax gen-clause
(syntax-rules ()
[(_ (Ca ...) C next fail name (arg* ...) (clause* ...))
(define (name Ca ... arg* ...)
(define-syntax fail
(syntax-rules ()
[(_) (C FAIL (Ca ...))]))
(C GEN-TEST c next (Ca ...)
(gen-empty C (Ca ...) clause* ...)
(gen-char C (Ca ...) c clause* ...)))]))
(define-syntax define-parser^
(lambda (x)
(define (lookup ls1 ls2)
(lambda (var)
(let f ([ls1 ls1] [ls2 ls2])
(cond
[(null? ls1)
(error 'define-parser "cannot find" var)]
[(bound-identifier=? var (car ls1))
(car ls2)]
[else (f (cdr ls1) (cdr ls2))]))))
(syntax-case x ()
[(_ (entries ...) config next fail [(_ (entries ...) config next fail
orig*
[name* (arg** ...) clause** ...] ...) [name* (arg** ...) clause** ...] ...)
(begin (with-syntax ([(mapped-entries ...)
(module M (entries ...) (map
(config GEN-ARGS (lookup
gen-clause config next fail name* (car (syntax->datum #'orig*))
(arg** ...) #'(name* ...))
(clause** ...)) #'(entries ...))])
...) #'(begin
(import M))]))) (config GEN-ARGS
gen-clause config next fail name*
(arg** ...)
(clause** ...))
...
(define entries mapped-entries)
...))])))
(define-syntax define-parser
(lambda (x)
(syntax-case x ()
[(_ definer next fail [name* (arg** ...) clause** ...] ...)
(with-syntax ([orig*
(datum->syntax #'foo (list #'(name* ...)))])
#'(define-syntax definer
(syntax-rules ()
[(_ config (entries (... ...)))
(define-parser^ (entries (... ...)) config next fail
orig*
[name* (arg** ...) clause** ...] ...)])))]))))
(define-syntax string-config
(syntax-rules (GEN-EOF? GEN-REF GEN-ARGS GEN-NEXT FAIL)
[(_ GEN-EOF? (s n i)) (fx=? i n)]
[(_ GEN-REF (s n i)) (string-ref s i)]
[(_ GEN-ARGS k . rest) (k (s n i) . rest)]
[(_ GEN-NEXT (s n i) who . rest)
(who s n (fx+ i 1) . rest)]
[(_ FAIL (s n i)) #f]))
(define-parser (do-parse) string-config next fail
(ratio+ (r ex sn num ac) (define-parser define-string->number-parser next fail
[(eof)
(if (= ac 0)
(fail)
(do-sn/ex sn ex (/ num ac)))]
[(digit r) => d
(next ratio+ r ex sn num (+ (* ac r) d))]
[(#\+)
(if (= ac 0)
(fail)
(let ([real (do-sn/ex sn ex (/ num ac))])
(next im:sign r real ex +1)))]
[(#\-)
(if (= ac 0)
(fail)
(let ([real (do-sn/ex sn ex (/ num ac))])
(next im:sign r real ex -1)))]
[(#\i)
(if (= ac 0)
(fail)
(make-rectangular 0 (do-sn/ex sn ex (/ num ac))))])
(im:ratio+ (r real ex sn num ac) (ratio+ (r ex sn num ac)
[(digit r) => d [(eof)
(next im:ratio+ r real ex sn num (+ (* ac r) d))] (if (= ac 0)
[(#\i) (fail)
(if (= ac 0) (do-sn/ex sn ex (/ num ac)))]
(fail) [(digit r) => d
(next im:done (next ratio+ r ex sn num (+ (* ac r) d))]
(make-rectangular real (do-sn/ex sn ex (/ num ac)))))]) [(#\+)
(if (= ac 0)
(fail)
(let ([real (do-sn/ex sn ex (/ num ac))])
(next im:sign r real ex +1)))]
[(#\-)
(if (= ac 0)
(fail)
(let ([real (do-sn/ex sn ex (/ num ac))])
(next im:sign r real ex -1)))]
[(#\i)
(if (= ac 0)
(fail)
(make-rectangular 0 (do-sn/ex sn ex (/ num ac))))])
(im:done (n) (im:ratio+ (r real ex sn num ac)
[(eof) n]) [(digit r) => d
(next im:ratio+ r real ex sn num (+ (* ac r) d))]
[(#\i)
(if (= ac 0)
(fail)
(next im:done
(make-rectangular real (do-sn/ex sn ex (/ num ac)))))])
(ratio (r ex sn num) (im:done (n)
[(digit r) => d [(eof) n])
(next ratio+ r ex sn num d)])
(im:ratio (r real ex sn num) (ratio (r ex sn num)
[(digit r) => d [(digit r) => d
(next im:ratio+ r real ex sn num d)]) (next ratio+ r ex sn num d)])
(exponent+digit (r ex sn ac exp1 exp2 exp-sign) (im:ratio (r real ex sn num)
[(eof) [(digit r) => d
(do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))] (next im:ratio+ r real ex sn num d)])
[(digit r) => d
(next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)])
(exponent+sign (r ex sn ac exp1 exp-sign) (exponent+digit (r ex sn ac exp1 exp2 exp-sign)
[(digit r) => d [(eof)
(next exponent+digit r ex sn ac exp1 d exp-sign)]) (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]
[(digit r) => d
(next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)])
(exponent (r ex sn ac exp1) (exponent+sign (r ex sn ac exp1 exp-sign)
[(digit r) => d [(digit r) => d
(next exponent+digit r ex sn ac exp1 d +1)] (next exponent+digit r ex sn ac exp1 d exp-sign)])
[(#\+) (next exponent+sign r ex sn ac exp1 +1)]
[(#\-) (next exponent+sign r ex sn ac exp1 -1)])
(digit+dot (r ex sn ac exp) (exponent (r ex sn ac exp1)
[(eof) [(digit r) => d
(do-dec-sn/ex sn ex (* ac (expt 10 exp)))] (next exponent+digit r ex sn ac exp1 d +1)]
[(digit r) => d [(#\+) (next exponent+sign r ex sn ac exp1 +1)]
(next digit+dot r ex sn (+ (* ac r) d) (- exp 1))] [(#\-) (next exponent+sign r ex sn ac exp1 -1)])
[(#\+)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next im:sign r real ex +1))]
[(#\-)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next im:sign r real ex -1))]
[(#\i)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next im:done (make-rectangular 0.0 real)))]
[(#\e)
(if (fx=? r 10)
(next exponent r ex sn ac exp)
(fail))])
(digit+ (r ex sn ac) (digit+dot (r ex sn ac exp)
[(eof) (do-sn/ex sn ex ac)] [(eof)
[(digit r) => d (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]
(next digit+ r ex sn (+ (* ac r) d))] [(digit r) => d
[(#\/) (next ratio r ex sn ac)] (next digit+dot r ex sn (+ (* ac r) d) (- exp 1))]
[(#\.) [(#\+)
(if (fx=? r 10) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next digit+dot r ex sn ac 0) (next im:sign r real ex +1))]
(fail))] [(#\-)
[(#\+) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(let ([real (do-sn/ex sn ex ac)]) (next im:sign r real ex -1))]
(next im:sign r real ex +1))] [(#\i)
[(#\-) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(let ([real (do-sn/ex sn ex ac)]) (next im:done (make-rectangular 0.0 real)))]
(next im:sign r real ex -1))] [(#\e)
[(#\i) (if (fx=? r 10)
(make-rectangular 0 (do-sn/ex sn ex ac))] (next exponent r ex sn ac exp)
[(#\e) (fail))])
(if (fx=? r 10)
(next exponent r ex sn ac 0)
(fail))])
(im:digit+ (r real ex sn ac) (digit+ (r ex sn ac)
[(digit r) => d [(eof) (do-sn/ex sn ex ac)]
(next im:digit+ r real ex sn (+ (* ac r) d))] [(digit r) => d
[(#\/) (next digit+ r ex sn (+ (* ac r) d))]
(next im:ratio r real ex sn ac)] [(#\/) (next ratio r ex sn ac)]
[(#\i) [(#\.)
(next im:done (make-rectangular real (do-sn/ex sn ex ac)))]) (if (fx=? r 10)
(next digit+dot r ex sn ac 0)
(fail))]
[(#\+)
(let ([real (do-sn/ex sn ex ac)])
(next im:sign r real ex +1))]
[(#\-)
(let ([real (do-sn/ex sn ex ac)])
(next im:sign r real ex -1))]
[(#\i)
(make-rectangular 0 (do-sn/ex sn ex ac))]
[(#\e)
(if (fx=? r 10)
(next exponent r ex sn ac 0)
(fail))])
(sign-i (r ex sn) (im:digit+ (r real ex sn ac)
[(eof) [(digit r) => d
(make-rectangular (next im:digit+ r real ex sn (+ (* ac r) d))]
(if (eq? ex 'i) 0.0 0) [(#\/)
sn)] (next im:ratio r real ex sn ac)]
[(#\n) (next sign-in r sn)]) [(#\i)
(sign-in (r sn) (next im:done (make-rectangular real (do-sn/ex sn ex ac)))])
[(#\f) (next sign-inf r sn)])
(sign-inf (r sn)
[(#\.) (next sign-inf. r sn)])
(sign-inf. (r sn)
[(#\0) (next sign-inf.0 r sn)])
(sign-inf.0 (r sn)
[(eof) (* sn +inf.0)]
[(#\i)
(next im:done (make-rectangular 0.0 (* sn +inf.0)))])
(im:sign-i (real ex sn) (sign-i (r ex sn)
[(eof) (make-rectangular real (do-sn/ex sn ex 1))] [(eof)
[(#\n) (next im:sign-in (make-rectangular real (* sn +inf.0)))]) (make-rectangular
(im:sign-in (n) (if (eq? ex 'i) 0.0 0)
[(#\f) (next im:sign-inf n)]) sn)]
(im:sign-inf (n) [(#\n) (next sign-in r sn)])
[(#\.) (next im:sign-inf. n)]) (sign-in (r sn)
(im:sign-inf. (n) [(#\f) (next sign-inf r sn)])
[(#\0) (next im:sign-inf.0 n)]) (sign-inf (r sn)
(im:sign-inf.0 (n) [(#\.) (next sign-inf. r sn)])
[(#\i) (next im:done n)]) (sign-inf. (r sn)
[(#\0) (next sign-inf.0 r sn)])
(sign-inf.0 (r sn)
[(eof) (* sn +inf.0)]
[(#\i)
(next im:done (make-rectangular 0.0 (* sn +inf.0)))])
(dot (r ex sn) (im:sign-i (real ex sn)
[(digit r) => d [(eof) (make-rectangular real (do-sn/ex sn ex 1))]
(next digit+dot r ex sn d -1)]) [(#\n) (next im:sign-in (make-rectangular real (* sn +inf.0)))])
(im:sign-in (n)
[(#\f) (next im:sign-inf n)])
(im:sign-inf (n)
[(#\.) (next im:sign-inf. n)])
(im:sign-inf. (n)
[(#\0) (next im:sign-inf.0 n)])
(im:sign-inf.0 (n)
[(#\i) (next im:done n)])
(im:sign (r real ex sn) (dot (r ex sn)
[(digit r) => d [(digit r) => d
(next im:digit+ r real ex sn d)] (next digit+dot r ex sn d -1)])
[(#\i)
(next im:sign-i real ex sn)])
(sign (r ex sn)
[(digit r) => d
(next digit+ r ex sn d)]
[(#\i)
(next sign-i r ex sn)]
[(#\.)
(if (fx=? r 10)
(next dot r ex sn)
(fail))])
(do-parse-h (dr r ex) (im:sign (r real ex sn)
[(#\x #\X) [(digit r) => d
(if r (fail) (next do-parse 16 16 ex))] (next im:digit+ r real ex sn d)]
[(#\o #\O) [(#\i)
(if r (fail) (next do-parse 8 8 ex))] (next im:sign-i real ex sn)])
[(#\b #\B)
(if r (fail) (next do-parse 2 2 ex))] (sign (r ex sn)
[(#\d #\D) [(digit r) => d
(if r (fail) (next do-parse 10 10 ex))] (next digit+ r ex sn d)]
[(#\e #\E) [(#\i)
(if ex (fail) (next do-parse dr r 'e))] (next sign-i r ex sn)]
[(#\i #\I) [(#\.)
(if ex (fail) (next do-parse dr r 'i))]) (if (fx=? r 10)
(next dot r ex sn)
(fail))]
[(#\n)
(next sign-n)])
(sign-n () [(#\a) (next sign-na)])
(sign-na () [(#\n) (next sign-nan)])
(sign-nan () [(#\.) (next sign-nan.)])
(sign-nan. () [(#\0) (next sign-nan.0)])
(sign-nan.0 ()
[(eof) +nan.0]
[(#\i) (next sign-nan.0i)])
(sign-nan.0i ()
[(eof) (make-rectangular 0.0 +nan.0)])
(do-parse (dr r ex) (parse-string-h (dr r ex)
[(#\#) (next do-parse-h dr r ex)] [(#\x #\X)
[(#\+) (next sign dr ex +1)] (if r (fail) (next parse-string 16 16 ex))]
[(#\-) (next sign dr ex -1)] [(#\o #\O)
[(#\.) (if r (fail) (next parse-string 8 8 ex))]
(if (fx=? dr 10) [(#\b #\B)
(next dot dr ex +1) (if r (fail) (next parse-string 2 2 ex))]
(fail))] [(#\d #\D)
[(digit dr) => d (if r (fail) (next parse-string 10 10 ex))]
(next digit+ dr ex +1 d)]) [(#\e #\E)
) (if ex (fail) (next parse-string dr r 'e))]
[(#\i #\I)
(if ex (fail) (next parse-string dr r 'i))])
(define string->number (parse-string (dr r ex)
(case-lambda [(#\#) (next parse-string-h dr r ex)]
[(s) [(#\+) (next sign dr ex +1)]
(unless (string? s) (die who "not a string" s)) [(#\-) (next sign dr ex -1)]
(do-parse s (string-length s) 0 10 #f #f)] [(#\.)
[(s r) (if (fx=? dr 10)
(unless (string? s) (die who "not a string" s)) (next dot dr ex +1)
(unless (memv r '(10 16 2 8)) (die who "invalid radix" r)) (fail))]
(do-parse s (string-length s) 0 r #f #f)])) [(digit dr) => d
(next digit+ dr ex +1 d)])
)) )
(define-syntax string-config
(syntax-rules (GEN-TEST GEN-ARGS FAIL)
[(_ GEN-ARGS k . rest) (k (s n i) . rest)]
[(_ FAIL (s n i)) #f]
[(_ GEN-TEST var next (s n i) sk fk)
(if (fx=? i n)
sk
(let ([var (string-ref s i)])
(define-syntax next
(syntax-rules ()
[(_ who args (... ...))
(who s n (fx+ i 1) args (... ...))]))
fk))]))
(define-string->number-parser string-config (parse-string))
(define string->number
(case-lambda
[(s)
(unless (string? s) (die who "not a string" s))
(parse-string s (string-length s) 0 10 #f #f)]
[(s r)
(unless (string? s) (die who "not a string" s))
(unless (memv r '(10 16 2 8)) (die who "invalid radix" r))
(parse-string s (string-length s) 0 r #f #f)]))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1494 1495

3
scheme/makefile.ss
View File

@ -82,9 +82,7 @@
"ikarus.intel-assembler.ss" "ikarus.intel-assembler.ss"
"ikarus.trace.ss" "ikarus.trace.ss"
"ikarus.fasl.write.ss" "ikarus.fasl.write.ss"
;;; HERE
"ikarus.fasl.ss" "ikarus.fasl.ss"
"ikarus.compiler.ss" "ikarus.compiler.ss"
"psyntax.compat.ss" "psyntax.compat.ss"
"psyntax.library-manager.ss" "psyntax.library-manager.ss"
@ -92,7 +90,6 @@
"psyntax.config.ss" "psyntax.config.ss"
"psyntax.builders.ss" "psyntax.builders.ss"
"psyntax.expander.ss" "psyntax.expander.ss"
"ikarus.load.ss" "ikarus.load.ss"
"ikarus.pretty-print.ss" "ikarus.pretty-print.ss"
"ikarus.cafe.ss" "ikarus.cafe.ss"