Fix multiplication and division by purely imaginary numbers.

That is, complex numbers whose real part is exact zero.

diff --git a/src/relnotes/bug-exactimul b/src/relnotes/bug-exactimul
new file mode 100644 (file)
index 0000000..9a6644d
--- /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 2c0fb5187ad7493760d865a486292ca55130f7a9..36fe945d4e9acb432f4742eb508f42cdd0aede58 100644 (file)
--- 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 0cb8243a91992b824f4cddcb779787f1b0bef8a8..14dfad5f581ca419c912b1fef8561029c53c93fb 100644 (file)
--- 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)))