From ae24e8c900f80d381291e4dc0c1920b7c94d3d84 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Tue, 20 Aug 2019 03:40:24 +0000 Subject: [PATCH] Fix multiplication and division by purely imaginary numbers. That is, complex numbers whose real part is exact zero. --- src/relnotes/bug-exactimul | 8 ++++++++ src/runtime/arith.scm | 22 ++++++++++++++++------ tests/runtime/test-arith.scm | 16 ++++++++-------- 3 files changed, 32 insertions(+), 14 deletions(-) create mode 100644 src/relnotes/bug-exactimul diff --git a/src/relnotes/bug-exactimul b/src/relnotes/bug-exactimul new file mode 100644 index 000000000..9a6644d91 --- /dev/null +++ b/src/relnotes/bug-exactimul @@ -0,0 +1,8 @@ +Bug fix: Multiplying by purely imaginary numbers preserves zero sign. + +- (* +i (make-rectangular x y)) = (make-rectangular (* -1 y) x) +- (* (make-rectangular x y) +i) = (make-rectangular (* -1 y) x) +- (/ (make-rectangular x y) -i) = (make-rectangular (* -1 y) x) +- (* -1 (make-rectangular x y)) = (make-rectangular y (* -1 x)) +- (* (make-rectangular x y) -i) = (make-rectangular y (* -1 x)) +- (/ (make-rectangular x y) +i) = (make-rectangular y (* -1 x)) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 2c0fb5187..36fe945d4 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -1652,8 +1652,12 @@ USA. (z2r (rec:real-part z2)) (z2i (rec:imag-part z2))) (complex:%make-rectangular - (real:- (real:* z1r z2r) (real:* z1i z2i)) - (real:+ (real:* z1r z2i) (real:* z1i z2r)))) + (if (or (real:exact0= z1r) (real:exact0= z2r)) + (real:negate (real:* z1i z2i)) + (real:- (real:* z1r z2r) (real:* z1i z2i))) + (cond ((real:exact0= z1r) (real:* z1i z2r)) + ((real:exact0= z2r) (real:* z1r z2i)) + (else (real:+ (real:* z1r z2i) (real:* z1i z2r)))))) (complex:%make-rectangular (real:* (rec:real-part z1) z2) (real:* (rec:imag-part z1) z2))) (if (recnum? z2) @@ -1708,10 +1712,16 @@ USA. (z1i (rec:imag-part z1)) (z2r (rec:real-part z2)) (z2i (rec:imag-part z2))) - (let ((d (real:+ (real:square z2r) (real:square z2i)))) - (complex:%make-rectangular - (real:/ (real:+ (real:* z1r z2r) (real:* z1i z2i)) d) - (real:/ (real:- (real:* z1i z2r) (real:* z1r z2i)) d)))) + (let ((d (real:+ (real:square z2r) (real:square z2i))) + (u + (if (or (real:exact0= z1r) (real:exact0= z2r)) + (real:* z1i z2i) + (real:+ (real:* z1r z2r) (real:* z1i z2i)))) + (v + (if (real:exact0= z2r) + (real:negate (real:* z1r z2i)) + (real:- (real:* z1i z2r) (real:* z1r z2i))))) + (complex:%make-rectangular (real:/ u d) (real:/ v d)))) (make-recnum (real:/ (rec:real-part z1) z2) (real:/ (rec:imag-part z1) z2))) (if (recnum? z2) diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm index 0cb8243a9..14dfad5f5 100644 --- a/tests/runtime/test-arith.scm +++ b/tests/runtime/test-arith.scm @@ -261,12 +261,12 @@ USA. (list 3+4i -4+3i) (list +0. +0.i) (list -0. -0.i) - (list +0.i -0. expect-failure) + (list +0.i -0.) (list -0.i +0.) - (list +0.+0.i -0.+0.i expect-failure) - (list -0.+0.i -0.-0.i expect-failure) + (list +0.+0.i -0.+0.i) + (list -0.+0.i -0.-0.i) (list +0.-0.i +0.+0.i) - (list -0.-0.i +0.-0.i expect-failure)) + (list -0.-0.i +0.-0.i)) (lambda (z w #!optional xfail) (with-expected-failure xfail (lambda () (assert-eqv (* +i z) w))) (with-expected-failure xfail (lambda () (assert-eqv (* z +i) w))) @@ -278,11 +278,11 @@ USA. (list +0. -0.i) (list -0. +0.i) (list +0.i +0.) - (list -0.i -0. expect-failure) - (list +0.+0.i +0.-0.i expect-failure) + (list -0.i -0.) + (list +0.+0.i +0.-0.i) (list -0.+0.i +0.+0.i) - (list +0.-0.i -0.-0.i expect-failure) - (list -0.-0.i -0.+0.i expect-failure)) + (list +0.-0.i -0.-0.i) + (list -0.-0.i -0.+0.i)) (lambda (z w #!optional xfail) (with-expected-failure xfail (lambda () (assert-eqv (/ z +i) w))) (with-expected-failure xfail (lambda () (assert-eqv (* -i z) w))) -- 2.25.1