Fixed some problems parsing complex numbers.

scheme/ikarus.numerics.ss

@@ -1589,7 +1589,8 @@
       (cond
         [(eqv? x 1) "+"]
         [(eqv? x -1) "-"]
-        [(< x 0) ($number->string x r)]
+        [(or (< x 0) (and (flonum? x) (not (flzero? (atan 0.0 x)))))
+         ($number->string x r)]
         [else (string-append "+" ($number->string x r))]))
     (define $number->string
       (lambda (x r)
@@ -2316,6 +2317,7 @@
       (cond
         [(fixnum? x) (eq? x 0)]
         [(bignum? x) #f]
+        [(ratnum? x) #f]
         [(flonum? x)
          (or ($fl= x 0.0) ($fl= x -0.0))]
         [else 
@@ -3628,7 +3630,9 @@
   (define ($make-rectangular r i)
     ;;; should be called with 2 exacts or two inexacts
     (if (flonum? i) 
-        (if (fl=? i 0.0) r ($make-cflonum r i))
+        (if (and (fl=? i 0.0) (fl=? (atan 0.0 i) 0.0))
+            r
+            ($make-cflonum r i))
         (if (eqv? i 0) r ($make-compnum r i))))
 
   (define (make-rectangular r i)

scheme/ikarus.string-to-number.ss

@@ -154,6 +154,12 @@
     (exponent+digit (r ex sn ac exp1 exp2 exp-sign)
       [(eof)
        (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]
+      [(#\+) 
+       (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
+         (next im:sign r real ex +1))]
+      [(#\-) 
+       (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
+         (next im:sign r real ex -1))]
       [(digit r) => d
        (next exponent+digit r ex sn ac exp1 (+ (* exp2 r) d) exp-sign)])
 
@@ -231,7 +237,7 @@
        (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))]
+       (next im:done (make-rectangular 0 (do-sn/ex sn ex ac)))]
       [(#\e)
        (if (fx=? r 10) 
            (next exponent r ex sn ac 0)
@@ -240,8 +246,16 @@
     (im:digit+ (r real ex sn ac)
       [(digit r) => d
        (next im:digit+ r real ex sn (+ (* ac r) d))]
+      [(#\.)
+       (if (fx=? r 10)
+           (next im:digit+dot r real ex sn ac 0)
+           (fail))]
       [(#\/)
        (next im:ratio r real ex sn ac)]
+      [(#\e)
+       (if (fx=? r 10)
+           (next im:exponent r real ex sn ac 0)
+           (fail))]
       [(#\i)
        (next im:done (make-rectangular real (do-sn/ex sn ex ac)))])
 
@@ -250,15 +264,17 @@
        (make-rectangular 
          (if (eq? ex 'i) 0.0 0)
          sn)]
-      [(#\n) (next sign-in r sn)])
+      [(#\n) (next sign-in r ex sn)])
-    (sign-in (r sn)
+    (sign-in (r ex sn)
-      [(#\f) (next sign-inf r sn)])
+      [(#\f) (next sign-inf r ex sn)])
-    (sign-inf (r sn)
+    (sign-inf (r ex sn)
-      [(#\.) (next sign-inf. r sn)])
+      [(#\.) (next sign-inf. r ex sn)])
-    (sign-inf. (r sn)
+    (sign-inf. (r ex sn)
-      [(#\0) (next sign-inf.0 r sn)])
+      [(#\0) (next sign-inf.0 r ex sn)])
-    (sign-inf.0 (r sn)
+    (sign-inf.0 (r ex sn)
       [(eof) (* sn +inf.0)]
+      [(#\+) (next im:sign r (* sn +inf.0) ex +1)]
+      [(#\-) (next im:sign r (* sn +inf.0) ex -1)]
       [(#\i) 
        (next im:done (make-rectangular 0.0 (* sn +inf.0)))])
 
@@ -274,6 +290,12 @@
     (im:sign-inf.0 (n)
       [(#\i) (next im:done n)])
 
+    (im:sign-n (n) [(#\a) (next im:sign-na n)])
+    (im:sign-na (n) [(#\n) (next im:sign-nan n)])
+    (im:sign-nan (n) [(#\.) (next im:sign-nan. n)])
+    (im:sign-nan. (n) [(#\0) (next im:sign-nan.0 n)])
+    (im:sign-nan.0 (n) [(#\i) (next im:done n)])
+
     (dot (r ex sn)
       [(digit r) => d
        (next digit+dot r ex sn d -1)])
@@ -287,6 +309,8 @@
        (next im:digit+ r real ex sn d)]
       [(#\i) 
        (next im:sign-i real ex sn)]
+      [(#\n)
+       (next im:sign-n (make-rectangular real +nan.0))]
       [(#\.)
        (if (fx=? r 10)
            (next im:dot r real ex sn)
@@ -302,15 +326,17 @@
            (next dot r ex sn)
            (fail))]
       [(#\n)
-       (next sign-n)])
+       (next sign-n r ex)])
-    (sign-n () [(#\a) (next sign-na)])
+    (sign-n (r ex) [(#\a) (next sign-na r ex)])
-    (sign-na () [(#\n) (next sign-nan)])
+    (sign-na (r ex) [(#\n) (next sign-nan r ex)])
-    (sign-nan () [(#\.) (next sign-nan.)])
+    (sign-nan (r ex) [(#\.) (next sign-nan. r ex)])
-    (sign-nan. () [(#\0) (next sign-nan.0)])
+    (sign-nan. (r ex) [(#\0) (next sign-nan.0 r ex)])
-    (sign-nan.0 ()
+    (sign-nan.0 (r ex)
       [(eof) +nan.0]
-      [(#\i) (next sign-nan.0i)])
+      [(#\+) (next im:sign r +nan.0 ex +1)]
-    (sign-nan.0i ()
+      [(#\-) (next im:sign r +nan.0 ex -1)]
+      [(#\i) (next sign-nan.0i r ex)])
+    (sign-nan.0i (r ex)
       [(eof) (make-rectangular 0.0 +nan.0)])
 
     (parse-string-h (dr r ex)

scheme/last-revision

@@ -1 +1 @@
-1538
+1539

scheme/tests/string-to-number.ss

@@ -7,6 +7,20 @@
   (import (ikarus) (tests framework))
 
   (define (test string expected)
+    (define (equal-results? x y)
+      (define (== x y)
+        (cond
+          [(nan? x) (nan? y)]
+          [(zero? x) (and (= x y) (= (atan 0.0 x) (atan 0.0 y)))]
+          [else 
+            (and (or (and (exact? x) (exact? y))
+                     (and (inexact? x) (inexact? y)))
+                 (= x y))]))
+      (cond
+        [(and (number? x) (number? y))
+         (and (== (real-part x) (real-part y))
+              (== (imag-part x) (imag-part y)))]
+        [else (equal? x y)]))
     (printf "testing ~a -> ~s\n" string expected)
     (let ([result (string->number string)])
       (if expected
@@ -14,7 +28,7 @@
             (error 'test "did not parse as number" string))
           (when result
             (error test "incorrectly parse as non-#f" string)))
-      (unless (equal? result expected)
+      (unless (equal-results? result expected)
         (error 'test "failed/expected/got" string expected result))
       (when expected
         (let ([s1 (format "~s" result)])
@@ -111,6 +125,121 @@
     (test "+12+" #f)
     (test "-12+" #f)
     
+    (test "8+6.0i" (make-rectangular 8 6.0))
+    (test "8.0+6i" (make-rectangular 8.0 6))
+    (test "+8+6.0i" (make-rectangular 8 6.0))
+    (test "+8.0+6i" (make-rectangular 8.0 6))
+    (test "-8+6.0i" (make-rectangular -8 6.0))
+    (test "-8.0+6i" (make-rectangular -8.0 6))
+
+    (test "8-6.0i" (make-rectangular 8 -6.0))
+    (test "8.0-6i" (make-rectangular 8.0 -6))
+    (test "+8-6.0i" (make-rectangular 8 -6.0))
+    (test "+8.0-6i" (make-rectangular 8.0 -6))
+    (test "-8-6.0i" (make-rectangular -8 -6.0))
+    (test "-8.0-6i" (make-rectangular -8.0 -6))
+    
+    (test "0i" 0)
+    (test "+0i" 0)
+    (test "-0i" 0)
+
+    (test "1i" (make-rectangular 0 1))
+    (test "+1i" (make-rectangular 0 1))
+    (test "-1i" (make-rectangular 0 -1))
+
+    (test "8+nan.0i" (make-rectangular 8 +nan.0))
+    (test "8.0+nan.0i" (make-rectangular 8.0 +nan.0))
+    (test "+8+nan.0i" (make-rectangular 8 +nan.0))
+    (test "+8.0+nan.0i" (make-rectangular 8.0 +nan.0))
+    (test "-8+nan.0i" (make-rectangular -8 +nan.0))
+    (test "-8.0+nan.0i" (make-rectangular -8.0 +nan.0))
+    (test "8-nan.0i" (make-rectangular 8 -nan.0))
+    (test "8.0-nan.0i" (make-rectangular 8.0 -nan.0))
+    (test "+8-nan.0i" (make-rectangular 8 -nan.0))
+    (test "+8.0-nan.0i" (make-rectangular 8.0 -nan.0))
+    (test "-8-nan.0i" (make-rectangular -8 -nan.0))
+    (test "-8.0-nan.0i" (make-rectangular -8.0 -nan.0))
+    (test "+nan.0+6.0i" (make-rectangular +nan.0 6.0))
+    (test "+nan.0+6i" (make-rectangular +nan.0 6))
+    (test "+nan.0+6.0i" (make-rectangular +nan.0 6.0))
+    (test "+nan.0+6i" (make-rectangular +nan.0 6))
+    (test "-nan.0+6.0i" (make-rectangular -nan.0 6.0))
+    (test "-nan.0+6i" (make-rectangular -nan.0 6))
+    (test "+nan.0-6.0i" (make-rectangular +nan.0 -6.0))
+    (test "+nan.0-6i" (make-rectangular +nan.0 -6))
+    (test "+nan.0-6.0i" (make-rectangular +nan.0 -6.0))
+    (test "+nan.0-6i" (make-rectangular +nan.0 -6))
+    (test "-nan.0-6.0i" (make-rectangular -nan.0 -6.0))
+    (test "-nan.0-6i" (make-rectangular -nan.0 -6))
+    (test "+nan.0+nan.0i" (make-rectangular +nan.0 +nan.0))
+    (test "+nan.0-nan.0i" (make-rectangular +nan.0 -nan.0))
+    (test "-nan.0+nan.0i" (make-rectangular -nan.0 +nan.0))
+    (test "-nan.0-nan.0i" (make-rectangular -nan.0 -nan.0))
+ 
+    (test "+nan.0+i" (make-rectangular +nan.0 +1))
+    (test "+nan.0-i" (make-rectangular +nan.0 -1))
+    (test "-nan.0+i" (make-rectangular -nan.0 +1))
+    (test "-nan.0-i" (make-rectangular -nan.0 -1))
+
+    (test "8+inf.0i" (make-rectangular 8 +inf.0))
+    (test "8.0+inf.0i" (make-rectangular 8.0 +inf.0))
+    (test "+8+inf.0i" (make-rectangular 8 +inf.0))
+    (test "+8.0+inf.0i" (make-rectangular 8.0 +inf.0))
+    (test "-8+inf.0i" (make-rectangular -8 +inf.0))
+    (test "-8.0+inf.0i" (make-rectangular -8.0 +inf.0))
+    (test "8-inf.0i" (make-rectangular 8 -inf.0))
+    (test "8.0-inf.0i" (make-rectangular 8.0 -inf.0))
+    (test "+8-inf.0i" (make-rectangular 8 -inf.0))
+    (test "+8.0-inf.0i" (make-rectangular 8.0 -inf.0))
+    (test "-8-inf.0i" (make-rectangular -8 -inf.0))
+    (test "-8.0-inf.0i" (make-rectangular -8.0 -inf.0))
+    (test "+inf.0+6.0i" (make-rectangular +inf.0 6.0))
+    (test "+inf.0+6i" (make-rectangular +inf.0 6))
+    (test "+inf.0+6.0i" (make-rectangular +inf.0 6.0))
+    (test "+inf.0+6i" (make-rectangular +inf.0 6))
+    (test "-inf.0+6.0i" (make-rectangular -inf.0 6.0))
+    (test "-inf.0+6i" (make-rectangular -inf.0 6))
+    (test "+inf.0-6.0i" (make-rectangular +inf.0 -6.0))
+    (test "+inf.0-6i" (make-rectangular +inf.0 -6))
+    (test "+inf.0-6.0i" (make-rectangular +inf.0 -6.0))
+    (test "+inf.0-6i" (make-rectangular +inf.0 -6))
+    (test "-inf.0-6.0i" (make-rectangular -inf.0 -6.0))
+    (test "-inf.0-6i" (make-rectangular -inf.0 -6))
+    (test "+inf.0+inf.0i" (make-rectangular +inf.0 +inf.0))
+    (test "+inf.0-inf.0i" (make-rectangular +inf.0 -inf.0))
+    (test "-inf.0+inf.0i" (make-rectangular -inf.0 +inf.0))
+    (test "-inf.0-inf.0i" (make-rectangular -inf.0 -inf.0))
+ 
+    (test "+inf.0+i" (make-rectangular +inf.0 +1))
+    (test "+inf.0-i" (make-rectangular +inf.0 -1))
+    (test "-inf.0+i" (make-rectangular -inf.0 +1))
+    (test "-inf.0-i" (make-rectangular -inf.0 -1))
+
+    (test "8+6e20i" (make-rectangular +8 +6e20))
+    (test "8-6e20i" (make-rectangular +8 -6e20))
+    (test "8e20+6i" (make-rectangular +8e20 +6))
+    (test "8e20-6i" (make-rectangular +8e20 -6))
+    (test "+8+6e20i" (make-rectangular +8 +6e20))
+    (test "+8-6e20i" (make-rectangular +8 -6e20))
+    (test "+8e20+6i" (make-rectangular +8e20 +6))
+    (test "+8e20-6i" (make-rectangular +8e20 -6))
+    (test "-8+6e20i" (make-rectangular -8 +6e20))
+    (test "-8-6e20i" (make-rectangular -8 -6e20))
+    (test "-8e20+6i" (make-rectangular -8e20 +6))
+    (test "-8e20-6i" (make-rectangular -8e20 -6))
+
+    (test "8e10+6e20i" (make-rectangular +8e10 +6e20))
+    (test "8e10-6e20i" (make-rectangular +8e10 -6e20))
+    (test "+8e10+6e20i" (make-rectangular +8e10 +6e20))
+    (test "+8e10-6e20i" (make-rectangular +8e10 -6e20))
+    (test "-8e10+6e20i" (make-rectangular -8e10 +6e20))
+    (test "-8e10-6e20i" (make-rectangular -8e10 -6e20))
+
+    (test "-0e-10" -0.0)
+    (test "-0e-0" -0.0)
+    (test "#d-0e-10-0e-0i" (make-rectangular -0.0 -0.0))
+    (test "-0.i" (make-rectangular 0.0 -0.0))
+
     )
 
   )