From 195dc0ea4585f0ce7b2d5a4965c8670a5f287a91 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 15 Jul 2008 22:44:55 -0700 Subject: [PATCH] Fixed some problems parsing complex numbers. --- scheme/ikarus.numerics.ss | 8 +- scheme/ikarus.string-to-number.ss | 60 ++++++++++---- scheme/last-revision | 2 +- scheme/tests/string-to-number.ss | 131 +++++++++++++++++++++++++++++- 4 files changed, 180 insertions(+), 21 deletions(-) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index a46bff6..051c691 100644 --- a/scheme/ikarus.numerics.ss +++ b/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) diff --git a/scheme/ikarus.string-to-number.ss b/scheme/ikarus.string-to-number.ss index fe6abd2..9fc38b2 100755 --- a/scheme/ikarus.string-to-number.ss +++ b/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)]) - (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) + [(#\n) (next sign-in r ex sn)]) + (sign-in (r ex sn) + [(#\f) (next sign-inf r ex sn)]) + (sign-inf (r ex sn) + [(#\.) (next sign-inf. r ex sn)]) + (sign-inf. (r ex sn) + [(#\0) (next sign-inf.0 r ex 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)]) - (sign-n () [(#\a) (next sign-na)]) - (sign-na () [(#\n) (next sign-nan)]) - (sign-nan () [(#\.) (next sign-nan.)]) - (sign-nan. () [(#\0) (next sign-nan.0)]) - (sign-nan.0 () + (next sign-n r ex)]) + (sign-n (r ex) [(#\a) (next sign-na r ex)]) + (sign-na (r ex) [(#\n) (next sign-nan r ex)]) + (sign-nan (r ex) [(#\.) (next sign-nan. r ex)]) + (sign-nan. (r ex) [(#\0) (next sign-nan.0 r ex)]) + (sign-nan.0 (r ex) [(eof) +nan.0] - [(#\i) (next sign-nan.0i)]) - (sign-nan.0i () + [(#\+) (next im:sign r +nan.0 ex +1)] + [(#\-) (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) diff --git a/scheme/last-revision b/scheme/last-revision index 576784f..1fd9918 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1538 +1539 diff --git a/scheme/tests/string-to-number.ss b/scheme/tests/string-to-number.ss index 33e9882..5577224 100644 --- a/scheme/tests/string-to-number.ss +++ b/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)]) @@ -110,6 +124,121 @@ (test "12+" #f) (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)) )