- fixed minor bug in current-directory
- changed implementation of string->number.
This commit is contained in:
Abdulaziz Ghuloum
parent
c377d43b92
commit
a492d318e1
|
|
@ -23,7 +23,8 @@ EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
psyntax.compat.ss psyntax.config.ss psyntax.expander.ss \
|
||||
psyntax.internal.ss psyntax.library-manager.ss \
|
||||
unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
|
||||
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss
|
||||
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
|
||||
ikarus.string-to-number.ss
|
||||
|
||||
all: $(nodist_pkglib_DATA)
|
||||
|
||||
|
|
|
|||
|
|
@ -177,7 +177,8 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
|
|||
psyntax.compat.ss psyntax.config.ss psyntax.expander.ss \
|
||||
psyntax.internal.ss psyntax.library-manager.ss \
|
||||
unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
|
||||
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss
|
||||
ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
|
||||
ikarus.string-to-number.ss
|
||||
|
||||
revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
|
||||
CLEANFILES = $(nodist_pkglib_DATA) ikarus.config.ss
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -390,7 +390,7 @@
|
|||
bitwise-copy-bit bitwise-bit-field
|
||||
positive? negative? expt gcd lcm numerator denominator
|
||||
exact-integer-sqrt
|
||||
quotient+remainder number->string string->number min max
|
||||
quotient+remainder number->string min max
|
||||
abs truncate fltruncate sra sll real->flonum
|
||||
exact->inexact inexact floor ceiling round log fl=? fl<? fl<=? fl>?
|
||||
fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative?
|
||||
|
|
@ -415,7 +415,7 @@
|
|||
bitwise-copy-bit bitwise-bit-field
|
||||
positive? negative? bitwise-and bitwise-not bitwise-ior
|
||||
bitwise-xor
|
||||
string->number expt gcd lcm numerator denominator
|
||||
expt gcd lcm numerator denominator
|
||||
exact->inexact inexact floor ceiling round log
|
||||
exact-integer-sqrt min max abs real->flonum
|
||||
fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin
|
||||
|
|
@ -1605,15 +1605,26 @@
|
|||
(flonum->string x)]
|
||||
[(ratnum? x) (ratnum->string x r)]
|
||||
[(compnum? x)
|
||||
(string-append
|
||||
($number->string ($compnum-real x) r)
|
||||
(imag ($compnum-imag x) r)
|
||||
"i")]
|
||||
(let ([xr ($compnum-real x)]
|
||||
[xi ($compnum-imag x)])
|
||||
(if (eqv? xr 0)
|
||||
(string-append (imag xi r) "i")
|
||||
(string-append
|
||||
($number->string xr r)
|
||||
(imag xi r)
|
||||
"i")))]
|
||||
[(cflonum? x)
|
||||
(string-append
|
||||
($number->string ($cflonum-real x) r)
|
||||
(imag ($cflonum-imag x) r)
|
||||
"i")]
|
||||
(let ([xr ($cflonum-real x)]
|
||||
[xi ($cflonum-imag x)])
|
||||
(cond
|
||||
[(flnan? xi)
|
||||
(string-append ($number->string xr r) "+nan.0i")]
|
||||
[(flinfinite? xi)
|
||||
(string-append ($number->string xr r)
|
||||
(if ($fl> xi 0.0) "+inf.0i" "-inf.0i"))]
|
||||
[else
|
||||
(string-append
|
||||
($number->string xr r) (imag xi r) "i")]))]
|
||||
[else (die 'number->string "not a number" x)])))
|
||||
(define number->string
|
||||
(case-lambda
|
||||
|
|
@ -2719,220 +2730,6 @@
|
|||
(atan xi xr))))]
|
||||
[else (die 'log "not a number" x)])))
|
||||
|
||||
(define string->number
|
||||
(case-lambda
|
||||
[(x) (string->number-radix-10 x)]
|
||||
[(x r)
|
||||
(unless (eqv? r 10)
|
||||
(die 'string->number
|
||||
"BUG: only radix 10 is supported"
|
||||
x r))
|
||||
(string->number-radix-10 x)]))
|
||||
|
||||
(define string->number-radix-10
|
||||
(lambda (x)
|
||||
(define (convert-char 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 'convert-char "invalid radix" radix)]))
|
||||
(define (parse-exponent-start x n i radix)
|
||||
(define (parse-exponent x n i radix ac)
|
||||
(cond
|
||||
[(fx= i n) ac]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-exponent x n (fxadd1 i) radix
|
||||
(+ d (* ac radix))))]
|
||||
[else #f]))]))
|
||||
(define (parse-exponent-sign x n i radix)
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d) (parse-exponent x n (fxadd1 i) radix d))]
|
||||
[else #f]))]))
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-exponent x n (fxadd1 i) radix d))]
|
||||
[(char=? c #\+)
|
||||
(parse-exponent-sign x n (fxadd1 i) radix)]
|
||||
[(char=? c #\-)
|
||||
(let ([v (parse-exponent-sign x n (fxadd1 i) radix)])
|
||||
(and v (- v)))]
|
||||
[else #f]))]))
|
||||
(define (parse-decimal x n i pos? radix exact? ac exp)
|
||||
(cond
|
||||
[(fx= i n)
|
||||
(let ([ac (* (if pos? ac (- ac)) (expt radix exp))])
|
||||
(exact-conv (or exact? 'i) ac))]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-decimal x n (fxadd1 i) pos? radix exact?
|
||||
(+ (* ac radix) d) (fxsub1 exp)))]
|
||||
[(memv c '(#\e #\E))
|
||||
(let ([ex (parse-exponent-start x n (fxadd1 i) radix)])
|
||||
(and ex
|
||||
(exact-conv (or exact? 'i)
|
||||
(* (if pos? ac (- ac)) (expt radix (+ exp ex))))))]
|
||||
[else #f]))]))
|
||||
(define (parse-decimal-no-digits x n i pos? radix exact?)
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-decimal x n (fxadd1 i) pos? radix exact? d -1))]
|
||||
[else #f]))]))
|
||||
(define (parse-integer x n i pos? radix exact? ac)
|
||||
(define (parse-denom-start x n i radix)
|
||||
(define (parse-denom x n i radix ac)
|
||||
(cond
|
||||
[(fx= n i) ac]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-denom x n (fxadd1 i) radix
|
||||
(+ (* radix ac) d)))]
|
||||
[else #f]))]))
|
||||
(cond
|
||||
[(fx= n i) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-denom x n (fxadd1 i) radix d))]
|
||||
[else #f]))]))
|
||||
(cond
|
||||
[(fx= i n)
|
||||
(let ([ac (exact-conv exact? ac)])
|
||||
(if pos? ac (- ac)))]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-integer x n (fxadd1 i) pos? radix exact? (+ (* ac radix) d)))]
|
||||
[(char=? c #\.)
|
||||
(parse-decimal x n (fxadd1 i) pos? radix exact? ac 0)]
|
||||
[(char=? c #\/)
|
||||
(let ([denom (parse-denom-start x n (fxadd1 i) radix)])
|
||||
(and denom
|
||||
(not (= denom 0))
|
||||
(let ([ac (exact-conv exact? ac)])
|
||||
(/ (if pos? ac (- ac)) denom))))]
|
||||
[(memv c '(#\e #\E))
|
||||
(let ([ex (parse-exponent-start x n (fxadd1 i) radix)])
|
||||
(and ex
|
||||
(let ([ac (* (if pos? ac (- ac)) (expt radix ex))])
|
||||
(exact-conv (or exact? 'i) ac))))]
|
||||
[else #f]))]))
|
||||
(define (parse-integer-no-digits x n i pos? radix exact?)
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(convert-char c radix) =>
|
||||
(lambda (d)
|
||||
(parse-integer x n (fxadd1 i) pos? radix exact? d))]
|
||||
[(char=? c #\.)
|
||||
(parse-decimal-no-digits x n (fxadd1 i) pos? radix exact?)]
|
||||
[else #f]))]))
|
||||
(define (exact-conv exact? x)
|
||||
(and x (if (eq? exact? 'i) (exact->inexact x) x)))
|
||||
(define (start x n i exact? radix?)
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(char=? c #\-)
|
||||
(parse-integer-no-digits x n (fxadd1 i) #f (or radix? 10) exact?)]
|
||||
[(char=? c #\+)
|
||||
(parse-integer-no-digits x n (fxadd1 i) #t (or radix? 10) exact?)]
|
||||
[(char=? c #\#)
|
||||
(let ([i (fxadd1 i)])
|
||||
(cond
|
||||
[(fx= i n) #f]
|
||||
[else
|
||||
(let ([c (string-ref x i)])
|
||||
(case c
|
||||
[(#\x #\X)
|
||||
(and (not radix?) (start x n (fxadd1 i) exact? 16))]
|
||||
[(#\b #\B)
|
||||
(and (not radix?) (start x n (fxadd1 i) exact? 2))]
|
||||
[(#\o #\O)
|
||||
(and (not radix?) (start x n (fxadd1 i) exact? 8))]
|
||||
[(#\d #\D)
|
||||
(and (not radix?) (start x n (fxadd1 i) exact? 10))]
|
||||
[(#\e #\E)
|
||||
(and (not exact?) (start x n (fxadd1 i) 'e radix?))]
|
||||
[(#\i #\I)
|
||||
(and (not exact?) (start x n (fxadd1 i) 'i radix?))]
|
||||
[else #f]))]))]
|
||||
[(char=? c #\.)
|
||||
(parse-decimal-no-digits x n (fxadd1 i) #t (or radix? 10) exact?)]
|
||||
[(convert-char c (or radix? 10)) =>
|
||||
(lambda (d)
|
||||
(parse-integer x n (fxadd1 i) #t (or radix? 10) exact? d))]
|
||||
[else #f]))]))
|
||||
;;;
|
||||
(unless (string? x)
|
||||
(die 'string->number "not a string" x))
|
||||
(let ([n (string-length x)])
|
||||
(cond
|
||||
[(fx= n (string-length "+xxx.0"))
|
||||
(cond
|
||||
[(string-ci=? x "+inf.0") +inf.0]
|
||||
[(string-ci=? x "-inf.0") -inf.0]
|
||||
[(string-ci=? x "+nan.0") +nan.0]
|
||||
[(string-ci=? x "-nan.0") -nan.0]
|
||||
[else (start x n 0 #f #f)])]
|
||||
[(fx> n 0) (start x n 0 #f #f)]
|
||||
[else #f]))))
|
||||
|
||||
|
||||
(define (random n)
|
||||
(if (fixnum? n)
|
||||
(if (fx> n 1)
|
||||
|
|
|
|||
|
|
@ -243,9 +243,9 @@
|
|||
(case-lambda
|
||||
[()
|
||||
(let ([v (foreign-call "ikrt_getcwd")])
|
||||
(if (eq? v #t)
|
||||
(raise/strerror 'current-directory v)
|
||||
(utf8->string v)))]
|
||||
(if (bytevector? v)
|
||||
(utf8->string v)
|
||||
(raise/strerror 'current-directory v)))]
|
||||
[(x)
|
||||
(if (string? x)
|
||||
(let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))])
|
||||
|
|
|
|||
|
|
@ -0,0 +1,383 @@
|
|||
|
||||
(library (ikarus.string-to-number)
|
||||
(export string->number)
|
||||
(import (except (ikarus) string->number))
|
||||
|
||||
(module (string->number)
|
||||
(define who 'string->number)
|
||||
(define (do-sn/ex sn ex ac)
|
||||
(* sn (if (eq? ex 'i) (inexact ac) ac)))
|
||||
(define (do-dec-sn/ex sn ex ac)
|
||||
(* sn (if (eq? ex 'e) ac (inexact ac))))
|
||||
(define (digit c r)
|
||||
(let ([n (fx- (char->integer c) (char->integer #\0))])
|
||||
(cond
|
||||
[(and (fx>=? n 0) (fx< n r)) n]
|
||||
[(eqv? r 16)
|
||||
(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
|
||||
[(test c . args) =>
|
||||
(lambda (result) then)]
|
||||
[else (gen-char C Ca c . rest)])]
|
||||
[(_ C Ca c [ls then] . rest)
|
||||
(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 ...))]))
|
||||
(cond
|
||||
[(C GEN-EOF? (Ca ...))
|
||||
(gen-empty C (Ca ...) clause* ...)]
|
||||
[else
|
||||
(let ([c (C GEN-REF (Ca ...))])
|
||||
(define-syntax next
|
||||
(syntax-rules ()
|
||||
[(_ who args (... ...))
|
||||
(C GEN-NEXT (Ca ...) who args (... ...))]))
|
||||
(gen-char C (Ca ...) c clause* ...))]))]))
|
||||
(define-syntax define-parser
|
||||
(syntax-rules ()
|
||||
[(_ (entries ...) config next fail
|
||||
[name* (arg** ...) clause** ...] ...)
|
||||
(begin
|
||||
(module M (entries ...)
|
||||
(config GEN-ARGS
|
||||
gen-clause config next fail name*
|
||||
(arg** ...)
|
||||
(clause** ...))
|
||||
...)
|
||||
(import M))])))
|
||||
|
||||
(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)
|
||||
[(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)
|
||||
[(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)))))])
|
||||
|
||||
(im:done (n)
|
||||
[(eof) n])
|
||||
|
||||
(ratio (r ex sn num)
|
||||
[(digit r) => d
|
||||
(next ratio+ r ex sn num d)])
|
||||
|
||||
(im:ratio (r real ex sn num)
|
||||
[(digit r) => d
|
||||
(next im:ratio+ r real ex sn num d)])
|
||||
|
||||
(exponent+digit (r ex sn ac exp1 exp2 exp-sign)
|
||||
[(eof)
|
||||
(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+sign (r ex sn ac exp1 exp-sign)
|
||||
[(digit r) => d
|
||||
(next exponent+digit r ex sn ac exp1 d exp-sign)])
|
||||
|
||||
(exponent (r ex sn ac exp1)
|
||||
[(digit r) => d
|
||||
(next exponent+digit r ex sn ac exp1 d +1)]
|
||||
[(#\+) (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)
|
||||
[(eof)
|
||||
(do-dec-sn/ex sn ex (* ac (expt 10 exp)))]
|
||||
[(digit r) => d
|
||||
(next digit+dot r ex sn (+ (* ac r) d) (- exp 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)
|
||||
[(eof) (do-sn/ex sn ex ac)]
|
||||
[(digit r) => d
|
||||
(next digit+ r ex sn (+ (* ac r) d))]
|
||||
[(#\/) (next ratio r ex sn 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))])
|
||||
|
||||
(im:digit+ (r real ex sn ac)
|
||||
[(digit r) => d
|
||||
(next im:digit+ r real ex sn (+ (* ac r) d))]
|
||||
[(#\/)
|
||||
(next im:ratio r real ex sn ac)]
|
||||
[(#\i)
|
||||
(next im:done (make-rectangular real (do-sn/ex sn ex ac)))])
|
||||
|
||||
(sign-i (r ex sn)
|
||||
[(eof)
|
||||
(make-rectangular
|
||||
(if (eq? ex 'i) 0.0 0)
|
||||
sn)]
|
||||
[(#\n) (next sign-in r sn)])
|
||||
(sign-in (r sn)
|
||||
[(#\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)
|
||||
[(eof) (make-rectangular real (do-sn/ex sn ex 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)])
|
||||
|
||||
(dot (r ex sn)
|
||||
[(digit r) => d
|
||||
(next digit+dot r ex sn d -1)])
|
||||
|
||||
(im:sign (r real ex sn)
|
||||
[(digit r) => d
|
||||
(next im:digit+ r real ex sn d)]
|
||||
[(#\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)
|
||||
[(#\x #\X)
|
||||
(if r (fail) (next do-parse 16 16 ex))]
|
||||
[(#\o #\O)
|
||||
(if r (fail) (next do-parse 8 8 ex))]
|
||||
[(#\b #\B)
|
||||
(if r (fail) (next do-parse 2 2 ex))]
|
||||
[(#\d #\D)
|
||||
(if r (fail) (next do-parse 10 10 ex))]
|
||||
[(#\e #\E)
|
||||
(if ex (fail) (next do-parse dr r 'e))]
|
||||
[(#\i #\I)
|
||||
(if ex (fail) (next do-parse dr r 'i))])
|
||||
|
||||
(do-parse (dr r ex)
|
||||
[(#\#) (next do-parse-h dr r ex)]
|
||||
[(#\+) (next sign dr ex +1)]
|
||||
[(#\-) (next sign dr ex -1)]
|
||||
[(#\.)
|
||||
(if (fx=? dr 10)
|
||||
(next dot dr ex +1)
|
||||
(fail))]
|
||||
[(digit dr) => d
|
||||
(next digit+ dr ex +1 d)])
|
||||
)
|
||||
|
||||
(define string->number
|
||||
(case-lambda
|
||||
[(s)
|
||||
(unless (string? s) (die who "not a string" s))
|
||||
(do-parse 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))
|
||||
(do-parse s (string-length s) 0 r #f #f)]))
|
||||
|
||||
))
|
||||
|
||||
|
||||
|
||||
;;; <number> ::= <num 2>
|
||||
;;; | <num 8>
|
||||
;;; | <num 10>
|
||||
;;; | <num 16>
|
||||
;;; <num R> ::= <prefix R> <complex R>
|
||||
;;; <complex R> ::= <real R>
|
||||
;;; | <real R> "@" <real R>
|
||||
;;; | <real R> "+" <ureal R> "i"
|
||||
;;; | <real R> "-" <ureal R> "i"
|
||||
;;; | <real R> "+" <naninf> "i"
|
||||
;;; | <real R> "-" <naninf> "i"
|
||||
;;; | <real R> "+" "i"
|
||||
;;; | <real R> "-" "i"
|
||||
;;; | "+" <ureal R> "i"
|
||||
;;; | "-" <ureal R> "i"
|
||||
;;; | "+" <naninf> "i"
|
||||
;;; | "-" <naninf> "i"
|
||||
;;; | "+" "i"
|
||||
;;; | "-" "i"
|
||||
;;; <real R> ::= <sign> <ureal R>
|
||||
;;; | "+" <naninf>
|
||||
;;; | "-" <naninf>
|
||||
;;; <naninf> ::= "nan.0"
|
||||
;;; | "inf.0"
|
||||
;;; <ureal R> | <uinteger R>
|
||||
;;; | <uinteger R> "/" <uinteger R>
|
||||
;;; | <decimal R> <mantissa width>
|
||||
;;; <decimal 10> ::= <uinteger 10> <suffix>
|
||||
;;; | "." <digit 10> + <suffix>
|
||||
;;; | <digit 10> + "." <digit 10> * <suffix>
|
||||
;;; | <digit 10> + "." <suffix>
|
||||
;;; <uinteger R> ::= <digit R> +
|
||||
;;; <prefix R> | <radix R> <exactness>
|
||||
;;; | <exactness <radix R>
|
||||
;;; <suffix> ::= epsilon
|
||||
;;; | <exponent-marker> <sign> <digit 10> +
|
||||
;;; <exponent-marker> ::= "e"
|
||||
;;; | "E"
|
||||
;;; | "s"
|
||||
;;; | "S"
|
||||
;;; | "f"
|
||||
;;; | "F"
|
||||
;;; | "d"
|
||||
;;; | "D"
|
||||
;;; | "l"
|
||||
;;; | "L"
|
||||
;;; <mantissa-width> ::= epsilon
|
||||
;;; | "|" <digit +>
|
||||
;;; <sign> ::= epsilon
|
||||
;;; | "+"
|
||||
;;; | "-"
|
||||
;;; <exactness> ::= epsilon
|
||||
;;; | "#i"
|
||||
;;; | "#I"
|
||||
;;; | "#e"
|
||||
;;; | "#E"
|
||||
;;; <radix-2> ::= "#b"
|
||||
;;; | "#B"
|
||||
;;; <radix-8> ::= "#o"
|
||||
;;; | "#O"
|
||||
;;; <radix-10> ::= epsilon
|
||||
;;; | "#d"
|
||||
;;; | "#D"
|
||||
;;; <radix-16> ::= "#x"
|
||||
;;; | "#X"
|
||||
;;; <digit-2> ::= "0"
|
||||
;;; | "1"
|
||||
;;; <digit-8> ::= "0"
|
||||
;;; | "1"
|
||||
;;; | "2"
|
||||
;;; | "3"
|
||||
;;; | "4"
|
||||
;;; | "5"
|
||||
;;; | "6"
|
||||
;;; | "7"
|
||||
;;; <digit-10> ::= <digit>
|
||||
;;; <digit-16> ::= <hex-digit>
|
||||
;;; <digit> ::= "0"
|
||||
;;; | "1"
|
||||
;;; | "2"
|
||||
;;; | "3"
|
||||
;;; | "4"
|
||||
;;; | "5"
|
||||
;;; | "6"
|
||||
;;; | "7"
|
||||
;;; | "8"
|
||||
;;; | "9"
|
||||
;;; <hex-digit> ::= <hex>
|
||||
;;; | "A"
|
||||
;;; | "B"
|
||||
;;; | "C"
|
||||
;;; | "D"
|
||||
;;; | "E"
|
||||
;;; | "F"
|
||||
;;; | "a"
|
||||
;;; | "b"
|
||||
;;; | "c"
|
||||
;;; | "d"
|
||||
;;; | "e"
|
||||
;;; | "f"
|
||||
|
|
@ -1 +1 @@
|
|||
1492
|
||||
1494
|
||||
|
|
|
|||
|
|
@ -64,6 +64,7 @@
|
|||
"ikarus.symbols.ss"
|
||||
"ikarus.vectors.ss"
|
||||
"ikarus.unicode-data.ss"
|
||||
"ikarus.string-to-number.ss"
|
||||
"ikarus.numerics.ss"
|
||||
"ikarus.conditions.ss"
|
||||
"ikarus.guardians.ss"
|
||||
|
|
|
|||
|
|
@ -1,64 +1,119 @@
|
|||
|
||||
|
||||
;;; assume reader which loads this file can only read signed integers.
|
||||
|
||||
(library (tests string-to-number)
|
||||
(export test-string-to-number)
|
||||
(import (ikarus) (tests framework))
|
||||
(define (t x s)
|
||||
(let ([fl (format "~a" (exact->inexact x))])
|
||||
(unless (string=? s fl)
|
||||
(error 'bignum->flonum
|
||||
"incorrect result for ~s\n expected ~a, \n got ~a" x s fl))))
|
||||
(define-syntax test*
|
||||
(syntax-rules ()
|
||||
[(_ name [str num] ...)
|
||||
(define-tests name
|
||||
[(lambda (x) (and x (= x num)))
|
||||
(string->number str)]
|
||||
...)]))
|
||||
(test* test-string-to-number
|
||||
("10" 10)
|
||||
("1" 1)
|
||||
("-17" -17)
|
||||
("+13476238746782364786237846872346782364876238477"
|
||||
13476238746782364786237846872346782364876238477)
|
||||
("1/2" (/ 1 2))
|
||||
("-1/2" (/ 1 -2))
|
||||
("#x24" 36)
|
||||
("#x-24" -36)
|
||||
("#b+00000110110" 54)
|
||||
("#b-00000110110/10" -27)
|
||||
("#e10" 10)
|
||||
("#e1" 1)
|
||||
("#e-17" -17)
|
||||
("#e#x24" 36)
|
||||
("#e#x-24" -36)
|
||||
("#e#b+00000110110" 54)
|
||||
("#e#b-00000110110/10" -27)
|
||||
("#x#e24" 36)
|
||||
("#x#e-24" -36)
|
||||
("#b#e+00000110110" 54)
|
||||
("#b#e-00000110110/10" -27)
|
||||
("#e1e1000" (expt 10 1000))
|
||||
("#e-1e1000" (- (expt 10 1000)))
|
||||
("#e1e-1000" (expt 10 -1000))
|
||||
("#e-1e-1000" (- (expt 10 -1000)))
|
||||
("#i1e100" (exact->inexact (expt 10 100)))
|
||||
("#i1e1000" (exact->inexact (expt 10 1000)))
|
||||
("#i-1e1000" (exact->inexact (- (expt 10 1000))))
|
||||
("1e100" (exact->inexact (expt 10 100)))
|
||||
("1.0e100" (exact->inexact (expt 10 100)))
|
||||
("1.e100" (exact->inexact (expt 10 100)))
|
||||
("0.1e100" (exact->inexact (expt 10 99)))
|
||||
(".1e100" (exact->inexact (expt 10 99)))
|
||||
("+1e100" (exact->inexact (expt 10 100)))
|
||||
("+1.0e100" (exact->inexact (expt 10 100)))
|
||||
("+1.e100" (exact->inexact (expt 10 100)))
|
||||
("+0.1e100" (exact->inexact (expt 10 99)))
|
||||
("+.1e100" (exact->inexact (expt 10 99)))
|
||||
("-1e100" (exact->inexact (- (expt 10 100))))
|
||||
("-1.0e100" (exact->inexact (- (expt 10 100))))
|
||||
("-1.e100" (exact->inexact (- (expt 10 100))))
|
||||
("-0.1e100" (exact->inexact (- (expt 10 99))))
|
||||
("-.1e100" (exact->inexact (- (expt 10 99))))))
|
||||
|
||||
(define (test string expected)
|
||||
(printf "testing ~a -> ~s\n" string expected)
|
||||
(let ([result (string->number string)])
|
||||
(if expected
|
||||
(unless (number? result)
|
||||
(error 'test "did not parse as number" string))
|
||||
(when result
|
||||
(error test "incorrectly parse as non-#f" string)))
|
||||
(unless (equal? result expected)
|
||||
(error 'test "failed/expected/got" string expected result))
|
||||
(when expected
|
||||
(let ([s1 (format "~s" result)])
|
||||
(unless (string=? s1 string)
|
||||
(test s1 expected))))))
|
||||
|
||||
(define inf+ (fl/ (inexact 1) (inexact 0)))
|
||||
(define inf- (fl/ (inexact -1) (inexact 0)))
|
||||
|
||||
|
||||
(define (test-string-to-number)
|
||||
(test "10" 10)
|
||||
(test "1" 1)
|
||||
(test "-17" -17)
|
||||
(test "12" 12)
|
||||
(test "+12" +12)
|
||||
(test "-12" -12)
|
||||
(test "+13476238746782364786237846872346782364876238477" 13476238746782364786237846872346782364876238477)
|
||||
(test "+inf.0" inf+)
|
||||
(test "-inf.0" inf-)
|
||||
(test "+i" (make-rectangular 0 +1))
|
||||
(test "-i" (make-rectangular 0 -1))
|
||||
(test "+15i" (make-rectangular 0 +15))
|
||||
(test "-15i" (make-rectangular 0 -15))
|
||||
(test "12/7" (/ 12 7))
|
||||
(test "-12/7" (/ -12 7))
|
||||
(test "+12/7" (/ 12 7))
|
||||
(test "12/7i" (make-rectangular 0 (/ 12 7)))
|
||||
(test "-12/7i" (make-rectangular 0 (/ -12 7)))
|
||||
(test "+12/7i" (make-rectangular 0 (/ 12 7)))
|
||||
(test "12/7+7i" (make-rectangular (/ 12 7) (/ 7 1)))
|
||||
(test "12/7+7/5i" (make-rectangular (/ 12 7) (/ 7 5)))
|
||||
(test "12/7-7/5i" (make-rectangular (/ 12 7) (/ -7 5)))
|
||||
(test "12." (inexact 12))
|
||||
(test "#e12." 12)
|
||||
(test "12.5" (inexact (/ 125 10)))
|
||||
(test "#e12.5123" (/ 125123 10000))
|
||||
(test "#i125123/10000" (inexact (/ 125123 10000)))
|
||||
(test "+inf.0i" (make-rectangular 0 inf+))
|
||||
(test "-inf.0i" (make-rectangular 0 inf-))
|
||||
|
||||
(test "1/2" (/ 1 2))
|
||||
(test "-1/2" (/ 1 -2))
|
||||
(test "#x24" 36)
|
||||
(test "#x-24" -36)
|
||||
(test "#b+00000110110" 54)
|
||||
(test "#b-00000110110/10" -27)
|
||||
(test "#e10" 10)
|
||||
(test "#e1" 1)
|
||||
(test "#e-17" -17)
|
||||
(test "#e#x24" 36)
|
||||
(test "#e#x-24" -36)
|
||||
(test "#e#b+00000110110" 54)
|
||||
(test "#e#b-00000110110/10" -27)
|
||||
(test "#x#e24" 36)
|
||||
(test "#x#e-24" -36)
|
||||
(test "#b#e+00000110110" 54)
|
||||
(test "#b#e-00000110110/10" -27)
|
||||
(test "#e1e1000" (expt 10 1000))
|
||||
(test "#e-1e1000" (- (expt 10 1000)))
|
||||
(test "#e1e-1000" (expt 10 -1000))
|
||||
(test "#e-1e-1000" (- (expt 10 -1000)))
|
||||
(test "#i1e100" (exact->inexact (expt 10 100)))
|
||||
(test "#i1e1000" (exact->inexact (expt 10 1000)))
|
||||
(test "#i-1e1000" (exact->inexact (- (expt 10 1000))))
|
||||
(test "1e100" (exact->inexact (expt 10 100)))
|
||||
(test "1.0e100" (exact->inexact (expt 10 100)))
|
||||
(test "1.e100" (exact->inexact (expt 10 100)))
|
||||
(test "0.1e100" (exact->inexact (expt 10 99)))
|
||||
(test ".1e100" (exact->inexact (expt 10 99)))
|
||||
(test "+1e100" (exact->inexact (expt 10 100)))
|
||||
(test "+1.0e100" (exact->inexact (expt 10 100)))
|
||||
(test "+1.e100" (exact->inexact (expt 10 100)))
|
||||
(test "+0.1e100" (exact->inexact (expt 10 99)))
|
||||
(test "+.1e100" (exact->inexact (expt 10 99)))
|
||||
(test "-1e100" (exact->inexact (- (expt 10 100))))
|
||||
(test "-1.0e100" (exact->inexact (- (expt 10 100))))
|
||||
(test "-1.e100" (exact->inexact (- (expt 10 100))))
|
||||
(test "-0.1e100" (exact->inexact (- (expt 10 99))))
|
||||
(test "-.1e100" (exact->inexact (- (expt 10 99))))
|
||||
|
||||
(test "i" #f)
|
||||
(test "/" #f)
|
||||
(test "12/0" #f)
|
||||
(test "+12/0" #f)
|
||||
(test "-12/0" #f)
|
||||
(test "12/0000" #f)
|
||||
(test "+12/0000" #f)
|
||||
(test "-12/0000" #f)
|
||||
(test "12+" #f)
|
||||
(test "+12+" #f)
|
||||
(test "-12+" #f)
|
||||
(test "12+" #f)
|
||||
(test "+12+" #f)
|
||||
(test "-12+" #f)
|
||||
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue