diff --git a/scheme/Makefile.am b/scheme/Makefile.am index 054e499..ac18a27 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -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) diff --git a/scheme/Makefile.in b/scheme/Makefile.in index 5fdecdf..e578df5 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -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 diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index a8d70bc..a994380 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 5a5851d..172a0f7 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -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/ 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/ 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) diff --git a/scheme/ikarus.posix.ss b/scheme/ikarus.posix.ss index 9cf57d8..fdc1a66 100644 --- a/scheme/ikarus.posix.ss +++ b/scheme/ikarus.posix.ss @@ -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))]) diff --git a/scheme/ikarus.string-to-number.ss b/scheme/ikarus.string-to-number.ss new file mode 100755 index 0000000..dff5c2b --- /dev/null +++ b/scheme/ikarus.string-to-number.ss @@ -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)])) + + )) + + + +;;; ::= +;;; | +;;; | +;;; | +;;; ::= +;;; ::= +;;; | "@" +;;; | "+" "i" +;;; | "-" "i" +;;; | "+" "i" +;;; | "-" "i" +;;; | "+" "i" +;;; | "-" "i" +;;; | "+" "i" +;;; | "-" "i" +;;; | "+" "i" +;;; | "-" "i" +;;; | "+" "i" +;;; | "-" "i" +;;; ::= +;;; | "+" +;;; | "-" +;;; ::= "nan.0" +;;; | "inf.0" +;;; | +;;; | "/" +;;; | +;;; ::= +;;; | "." + +;;; | + "." * +;;; | + "." +;;; ::= + +;;; | +;;; | +;;; ::= epsilon +;;; | + +;;; ::= "e" +;;; | "E" +;;; | "s" +;;; | "S" +;;; | "f" +;;; | "F" +;;; | "d" +;;; | "D" +;;; | "l" +;;; | "L" +;;; ::= epsilon +;;; | "|" +;;; ::= epsilon +;;; | "+" +;;; | "-" +;;; ::= epsilon +;;; | "#i" +;;; | "#I" +;;; | "#e" +;;; | "#E" +;;; ::= "#b" +;;; | "#B" +;;; ::= "#o" +;;; | "#O" +;;; ::= epsilon +;;; | "#d" +;;; | "#D" +;;; ::= "#x" +;;; | "#X" +;;; ::= "0" +;;; | "1" +;;; ::= "0" +;;; | "1" +;;; | "2" +;;; | "3" +;;; | "4" +;;; | "5" +;;; | "6" +;;; | "7" +;;; ::= +;;; ::= +;;; ::= "0" +;;; | "1" +;;; | "2" +;;; | "3" +;;; | "4" +;;; | "5" +;;; | "6" +;;; | "7" +;;; | "8" +;;; | "9" +;;; ::= +;;; | "A" +;;; | "B" +;;; | "C" +;;; | "D" +;;; | "E" +;;; | "F" +;;; | "a" +;;; | "b" +;;; | "c" +;;; | "d" +;;; | "e" +;;; | "f" diff --git a/scheme/last-revision b/scheme/last-revision index 3591ec6..9d877e1 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1492 +1494 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c09b81d..99765de 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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" diff --git a/scheme/tests/string-to-number.ss b/scheme/tests/string-to-number.ss index 30d6bd6..33e9882 100644 --- a/scheme/tests/string-to-number.ss +++ b/scheme/tests/string-to-number.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) + + ) + + )