conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixed some problems parsing complex numbers.

This commit is contained in:
Abdulaziz Ghuloum 2008-07-15 22:44:55 -07:00
parent 2a49d5c538
commit 195dc0ea45
4 changed files with 180 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
scheme/ikarus.numerics.ss
View File

@ -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)

60
scheme/ikarus.string-to-number.ss
View File

@ -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)

2
scheme/last-revision
View File

@ -1 +1 @@
1538
1539

131
scheme/tests/string-to-number.ss
View File

@ -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))
)
)