From: Taylor R Campbell <campbell@mumble.net>
Date: Tue, 20 Aug 2019 03:40:24 +0000 (+0000)
Subject: Fix multiplication and division by purely imaginary numbers.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~74
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ae24e8c900f80d381291e4dc0c1920b7c94d3d84;p=mit-scheme.git

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