- fixed minor bug in current-directory

- changed implementation of string->number.

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)
 

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

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- 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 
+           (let ([xr ($compnum-real x)]
-             ($number->string ($compnum-real x) r)
+                 [xi ($compnum-imag x)])
-             (imag ($compnum-imag x) r)
+             (if (eqv? xr 0)
-             "i")]
+                 (string-append (imag xi r) "i")
+                 (string-append 
+                   ($number->string xr r)
+                   (imag xi r)
+                   "i")))]
           [(cflonum? x)
-           (string-append 
+           (let ([xr ($cflonum-real x)]
-             ($number->string ($cflonum-real x) r)
+                 [xi ($cflonum-imag x)])
-             (imag ($cflonum-imag x) r)
+             (cond
-             "i")]
+               [(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) 

scheme/ikarus.posix.ss

@@ -243,9 +243,9 @@
     (case-lambda
       [() 
        (let ([v (foreign-call "ikrt_getcwd")])
-         (if (eq? v #t)
+         (if (bytevector? v)
-             (raise/strerror 'current-directory v) 
+             (utf8->string v)
-             (utf8->string v)))]
+             (raise/strerror 'current-directory v)))]
       [(x) 
        (if (string? x) 
            (let ([rv (foreign-call "ikrt_chdir" (string->utf8 x))])

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)]))
+    
+    ))
+
+
+
+;;; <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"

scheme/last-revision

@@ -1 +1 @@
-1492
+1494

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"

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))])
+  (define (test string expected)
-      (unless (string=? s fl)
+    (printf "testing ~a -> ~s\n" string expected)
-        (error 'bignum->flonum
+    (let ([result (string->number string)])
-          "incorrect result for ~s\n expected ~a, \n      got ~a" x s fl))))
+      (if expected
-  (define-syntax test*
+          (unless (number? result)
-    (syntax-rules ()
+            (error 'test "did not parse as number" string))
-      [(_ name [str num] ...)
+          (when result
-       (define-tests name 
+            (error test "incorrectly parse as non-#f" string)))
-         [(lambda (x) (and x (= x num)))
+      (unless (equal? result expected)
-          (string->number str)]
+        (error 'test "failed/expected/got" string expected result))
-         ...)]))
+      (when expected
-  (test* test-string-to-number
+        (let ([s1 (format "~s" result)])
-    ("10" 10)
+          (unless (string=? s1 string)
-    ("1" 1)
+            (test s1 expected))))))
-    ("-17" -17)
+
-    ("+13476238746782364786237846872346782364876238477" 
+  (define inf+ (fl/ (inexact 1) (inexact 0)))
-     13476238746782364786237846872346782364876238477)
+  (define inf- (fl/ (inexact -1) (inexact 0)))
-    ("1/2" (/ 1 2))
+
-    ("-1/2" (/ 1 -2))
+
-    ("#x24" 36)
+  (define (test-string-to-number)
-    ("#x-24" -36)
+    (test "10" 10)
-    ("#b+00000110110" 54)
+    (test "1" 1)
-    ("#b-00000110110/10" -27)
+    (test "-17" -17)
-    ("#e10" 10)
+    (test "12" 12)
-    ("#e1" 1)
+    (test "+12" +12)
-    ("#e-17" -17)
+    (test "-12" -12)
-    ("#e#x24" 36)
+    (test "+13476238746782364786237846872346782364876238477" 13476238746782364786237846872346782364876238477)
-    ("#e#x-24" -36)
+    (test "+inf.0" inf+)
-    ("#e#b+00000110110" 54)
+    (test "-inf.0" inf-)
-    ("#e#b-00000110110/10" -27)
+    (test "+i" (make-rectangular 0 +1))
-    ("#x#e24" 36)
+    (test "-i" (make-rectangular 0 -1))
-    ("#x#e-24" -36)
+    (test "+15i" (make-rectangular 0 +15))
-    ("#b#e+00000110110" 54)
+    (test "-15i" (make-rectangular 0 -15))
-    ("#b#e-00000110110/10" -27)
+    (test "12/7" (/ 12 7))
-    ("#e1e1000" (expt 10 1000))
+    (test "-12/7" (/ -12 7))
-    ("#e-1e1000" (- (expt 10 1000)))
+    (test "+12/7" (/ 12 7))
-    ("#e1e-1000" (expt 10 -1000))
+    (test "12/7i" (make-rectangular 0 (/ 12 7)))
-    ("#e-1e-1000" (- (expt 10 -1000)))
+    (test "-12/7i" (make-rectangular 0 (/ -12 7)))
-    ("#i1e100" (exact->inexact (expt 10 100)))
+    (test "+12/7i" (make-rectangular 0 (/ 12 7)))
-    ("#i1e1000" (exact->inexact (expt 10 1000)))
+    (test "12/7+7i" (make-rectangular (/ 12 7) (/ 7 1)))
-    ("#i-1e1000" (exact->inexact (- (expt 10 1000))))
+    (test "12/7+7/5i" (make-rectangular (/ 12 7) (/ 7 5)))
-    ("1e100" (exact->inexact (expt 10 100)))
+    (test "12/7-7/5i" (make-rectangular (/ 12 7) (/ -7 5)))
-    ("1.0e100" (exact->inexact (expt 10 100)))
+    (test "12." (inexact 12))
-    ("1.e100" (exact->inexact (expt 10 100)))
+    (test "#e12." 12)
-    ("0.1e100" (exact->inexact (expt 10 99)))
+    (test "12.5" (inexact (/ 125 10)))
-    (".1e100" (exact->inexact (expt 10 99)))
+    (test "#e12.5123" (/ 125123 10000))
-    ("+1e100" (exact->inexact (expt 10 100)))
+    (test "#i125123/10000" (inexact (/ 125123 10000)))
-    ("+1.0e100" (exact->inexact (expt 10 100)))
+    (test "+inf.0i" (make-rectangular 0 inf+))
-    ("+1.e100" (exact->inexact (expt 10 100)))
+    (test "-inf.0i" (make-rectangular 0 inf-))
-    ("+0.1e100" (exact->inexact (expt 10 99)))
+    
-    ("+.1e100" (exact->inexact (expt 10 99)))
+    (test "1/2" (/ 1 2))
-    ("-1e100" (exact->inexact   (- (expt 10 100))))
+    (test "-1/2" (/ 1 -2))
-    ("-1.0e100" (exact->inexact (- (expt 10 100))))
+    (test "#x24" 36)
-    ("-1.e100" (exact->inexact  (- (expt 10 100))))
+    (test "#x-24" -36)
-    ("-0.1e100" (exact->inexact (- (expt 10 99))))
+    (test "#b+00000110110" 54)
-    ("-.1e100" (exact->inexact  (- (expt 10 99))))))
+    (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)
+
+    )
+
+  )