From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 30 Nov 2018 06:29:58 +0000 (+0000)
Subject: Handle more sqrt edge cases.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~98
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=02e75e858bec67dd6b5ab0f1a5dd17b83c463c33;p=mit-scheme.git

Handle more sqrt edge cases.
---

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 38dfb04ce..87e25a1cd 100644
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -1999,14 +1999,32 @@ USA.
 		     sqrt-abs-y/2
 		     (real:copysign sqrt-abs-y/2 y))))
 		 ((real:zero? y)
+		  (assert (not (real:exact0= y)))
 		  (if (real:negative? x)
 		      (complex:%make-rectangular
 		       0.
 		       (real:copysign (x>=0 (real:negate x)) y))
 		      (complex:%make-rectangular (x>=0 x) y)))
-		 (else
+		 ((eq? (real:infinite? x) (real:infinite? y))
+		  ;; Standard formula.  Works when both inputs are
+		  ;; finite, when both inputs are infinite, and when
+		  ;; both inputs are NaN.
 		  (complex:%make-polar (x>=0 (complex:magnitude z))
-				       (real:/ (complex:angle z) 2))))))
+				       (real:/ (complex:angle z) 2)))
+		 ((real:finite? x)
+		  ;; Rotate from pi/2 to pi/4, or from -pi/2 to -pi/4,
+		  ;; or preserve NaN but keep real sign positive.
+		  (assert (or (real:infinite? y) (real:nan? y)))
+		  (complex:%make-rectangular (flo:abs y) y))
+		 ((and (real:infinite? x) (real:finite? y))
+		  (if (real:negative? x)
+		      (complex:%make-rectangular 0. (flo:copysign x y))
+		      (complex:%make-rectangular x (flo:copysign 0. y))))
+		 (else
+		  ;; Garbage in, garbage out.  Try to preserve as much
+		  ;; NaNity as possible.
+		  (assert (or (real:nan? x) (real:nan? y)))
+		  (complex:%make-rectangular (flo:abs x) y)))))
 	((real:negative? z)
 	 (complex:%make-rectangular 0 (x>=0 (real:negate z))))
 	(else
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index f9c343d17..49958c9f4 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -725,12 +725,12 @@ USA.
     (+inf.0 +inf.0)
     (-inf.0+0.i 0.+inf.0i)
     (+inf.0+0.i +inf.0+0.i)
-    (-inf.0+1.i 0.+inf.0i ,expect-failure)
-    (+inf.0+1.i +inf.0+0.i ,expect-error)
+    (-inf.0+1.i 0.+inf.0i)
+    (+inf.0+1.i +inf.0+0.i)
     (-inf.0-0.i 0.-inf.0i)
     (+inf.0-0.i +inf.0-0.i)
-    (-inf.0-1.i 0.-inf.0i ,expect-failure)
-    (+inf.0-1.i +inf.0-0.i ,expect-error)
+    (-inf.0-1.i 0.-inf.0i)
+    (+inf.0-1.i +inf.0-0.i)
     (-inf.0i +inf.0-inf.0i)
     (+inf.0i +inf.0+inf.0i)
     (+0.-inf.0i +inf.0-inf.0i)