From a26bd487a761220ebe739f06aaaf758104f61f2c Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 30 Nov 2018 01:54:51 +0000
Subject: [PATCH] Define (copysign m s) = magnitude of m, sign of s.

---
 src/runtime/arith.scm         |  16 +++++
 src/runtime/runtime.pkg       |   1 +
 tests/runtime/test-arith.scm  | 106 +++++++++++++++++++++++++++++++++-
 tests/runtime/test-flonum.scm |  41 ++++++++++++-
 4 files changed, 161 insertions(+), 3 deletions(-)

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index ae39d37e1..4ebed69e1 100644
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -1304,6 +1304,18 @@ USA.
 
 (define-rational-exact-unary real:numerator->exact rat:numerator)
 (define-rational-exact-unary real:denominator->exact rat:denominator)
+
+(define (real:copysign x y)
+  (cond ((and (flonum? x) (flonum? y))
+	 (flo:copysign x y))
+	((flonum? x)
+	 (flo:copysign x (real:->inexact y)))
+	(else
+	 (if (if (flonum? y)
+		 (flo:safe-negative? y)
+		 (rat:negative? y))
+	     (- (rat:abs x))
+	     (rat:abs x)))))
 
 (define-syntax define-transcendental-unary
   (sc-macro-transformer
@@ -1737,6 +1749,10 @@ USA.
 
 (define (complex:denominator->exact q)
   (real:denominator->exact (complex:real-arg 'denominator->exact q)))
+
+(define (complex:copysign x y)
+  (real:copysign (complex:real-arg 'copysign x)
+		 (complex:real-arg 'copysign y)))
 
 (define (complex:floor x)
   (if (recnum? x)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0bbd55342..5777e63ef 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3324,6 +3324,7 @@ USA.
 	  (ceiling->exact complex:ceiling->exact)
 	  (complex? complex:complex?)
 	  (conjugate complex:conjugate)
+	  (copysign complex:copysign)
 	  (cos complex:cos)
 	  (denominator complex:denominator)
 	  (denominator->exact complex:denominator->exact)
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index c0ab2ed54..8a486805b 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -760,4 +760,108 @@ USA.
            (lambda ()
              (sqrt x)
              (flo:test-exceptions (flo:supported-exceptions))))))
-       (flo:exception:invalid-operation)))))
\ No newline at end of file
+       (flo:exception:invalid-operation)))))
+
+(define-enumerated-test 'copysign
+  `((0. 0. 0.)
+    (0. -0. -0.)
+    (0. 1. 0.)
+    (0. -1. -0.)
+    (0. +inf.0 0.)
+    (0. -inf.0 -0.)
+    (0. 0 0.)
+    (0. 1 0.)
+    (0. -1 -0.)
+    (0. ,(flo:make-nan #t #t 0) -0.)
+    (0. ,(flo:make-nan #f #t 0) 0.)
+    (0. ,(flo:make-nan #t #f 1) -0.)
+    (0. ,(flo:make-nan #f #f 1) 0.)
+    (-0. 0. 0.)
+    (-0. -0. -0.)
+    (-0. 1. 0.)
+    (-0. -1. -0.)
+    (-0. +inf.0 0.)
+    (-0. -inf.0 -0.)
+    (-0. ,(flo:make-nan #t #t 0) -0.)
+    (-0. ,(flo:make-nan #f #t 0) 0.)
+    (-0. ,(flo:make-nan #t #f 1) -0.)
+    (-0. ,(flo:make-nan #f #f 1) 0.)
+    (-0. 0 0.)
+    (-0. 1 0.)
+    (-0. -1 -0.)
+    (1. 0. 1.)
+    (1. -0. -1.)
+    (1. 1. 1.)
+    (1. -1. -1.)
+    (1. +inf.0 1.)
+    (1. -inf.0 -1.)
+    (1. ,(flo:make-nan #t #t 0) -1.)
+    (1. ,(flo:make-nan #f #t 0) 1.)
+    (1. ,(flo:make-nan #t #f 1) -1.)
+    (1. ,(flo:make-nan #f #f 1) 1.)
+    (1. 0 1.)
+    (1. 1 1.)
+    (1. -1 -1.)
+    (-1. 0. 1.)
+    (-1. -0. -1.)
+    (-1. 1. 1.)
+    (-1. -1. -1.)
+    (-1. +inf.0 1.)
+    (-1. -inf.0 -1.)
+    (-1. ,(flo:make-nan #t #t 0) -1.)
+    (-1. ,(flo:make-nan #f #t 0) 1.)
+    (-1. ,(flo:make-nan #t #f 1) -1.)
+    (-1. ,(flo:make-nan #f #f 1) 1.)
+    (-1. 0 1.)
+    (-1. 1 1.)
+    (-1. -1 -1.)
+    (+inf.0 0. +inf.0)
+    (+inf.0 -0. -inf.0)
+    (+inf.0 1. +inf.0)
+    (+inf.0 -1. -inf.0)
+    (+inf.0 +inf.0 +inf.0)
+    (+inf.0 -inf.0 -inf.0)
+    (+inf.0 ,(flo:make-nan #t #t 0) -inf.0)
+    (+inf.0 ,(flo:make-nan #f #t 0) +inf.0)
+    (+inf.0 ,(flo:make-nan #t #f 1) -inf.0)
+    (+inf.0 ,(flo:make-nan #f #f 1) +inf.0)
+    (+inf.0 0 +inf.0)
+    (+inf.0 1 +inf.0)
+    (+inf.0 -1 -inf.0)
+    (-inf.0 0. +inf.0)
+    (-inf.0 -0. -inf.0)
+    (-inf.0 1. +inf.0)
+    (-inf.0 -1. -inf.0)
+    (-inf.0 +inf.0 +inf.0)
+    (-inf.0 -inf.0 -inf.0)
+    (-inf.0 ,(flo:make-nan #t #t 0) -inf.0)
+    (-inf.0 ,(flo:make-nan #f #t 0) +inf.0)
+    (-inf.0 ,(flo:make-nan #t #f 1) -inf.0)
+    (-inf.0 ,(flo:make-nan #f #f 1) +inf.0)
+    (-inf.0 0 +inf.0)
+    (-inf.0 1 +inf.0)
+    (-inf.0 -1 -inf.0)
+    (,(flo:make-nan #f #t 0) 0. ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #t #t 0) 0. ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #f #t 0) -0. ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #t #t 0) -0. ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #f #f 1) 0. ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #t #f 1) 0. ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #f #f 1) -0. ,(flo:make-nan #t #f 1))
+    (,(flo:make-nan #t #f 1) -0. ,(flo:make-nan #t #f 1))
+    (,(flo:make-nan #f #t 0) 1 ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #t #t 0) 1 ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #f #t 0) -1 ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #t #t 0) -1 ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #f #f 1) 1 ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #t #f 1) 1 ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #f #f 1) -1 ,(flo:make-nan #t #f 1))
+    (,(flo:make-nan #t #f 1) -1 ,(flo:make-nan #t #f 1)))
+  (lambda (x y z)
+    (assert-eqv-nan (yes-traps (lambda () (copysign x y))) z)
+    (assert-eqv-nan (yes-traps (lambda () (copysign (- x) y))) z)
+    (if (not (eqv? y 0))
+        (begin
+          (assert-eqv-nan (yes-traps (lambda () (copysign x (- y)))) (- z))
+          (assert-eqv-nan (yes-traps (lambda () (copysign (- x) (- y))))
+                          (- z))))))
\ No newline at end of file
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 39216e0b8..4bd8469e3 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -227,6 +227,16 @@ USA.
     (0. ,(flo:make-nan #f #t 0) 0.)
     (0. ,(flo:make-nan #t #f 1) -0.)
     (0. ,(flo:make-nan #f #f 1) 0.)
+    (-0. 0. 0.)
+    (-0. -0. -0.)
+    (-0. 1. 0.)
+    (-0. -1. -0.)
+    (-0. +inf.0 0.)
+    (-0. -inf.0 -0.)
+    (-0. ,(flo:make-nan #t #t 0) -0.)
+    (-0. ,(flo:make-nan #f #t 0) 0.)
+    (-0. ,(flo:make-nan #t #f 1) -0.)
+    (-0. ,(flo:make-nan #f #f 1) 0.)
     (1. 0. 1.)
     (1. -0. -1.)
     (1. 1. 1.)
@@ -237,6 +247,16 @@ USA.
     (1. ,(flo:make-nan #f #t 0) 1.)
     (1. ,(flo:make-nan #t #f 1) -1.)
     (1. ,(flo:make-nan #f #f 1) 1.)
+    (-1. 0. 1.)
+    (-1. -0. -1.)
+    (-1. 1. 1.)
+    (-1. -1. -1.)
+    (-1. +inf.0 1.)
+    (-1. -inf.0 -1.)
+    (-1. ,(flo:make-nan #t #t 0) -1.)
+    (-1. ,(flo:make-nan #f #t 0) 1.)
+    (-1. ,(flo:make-nan #t #f 1) -1.)
+    (-1. ,(flo:make-nan #f #f 1) 1.)
     (+inf.0 0. +inf.0)
     (+inf.0 -0. -inf.0)
     (+inf.0 1. +inf.0)
@@ -256,9 +276,26 @@ USA.
     (-inf.0 ,(flo:make-nan #t #t 0) -inf.0)
     (-inf.0 ,(flo:make-nan #f #t 0) +inf.0)
     (-inf.0 ,(flo:make-nan #t #f 1) -inf.0)
-    (-inf.0 ,(flo:make-nan #f #f 1) +inf.0))
+    (-inf.0 ,(flo:make-nan #f #f 1) +inf.0)
+    (,(flo:make-nan #f #t 0) 0. ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #t #t 0) 0. ,(flo:make-nan #f #t 0))
+    (,(flo:make-nan #f #t 0) -0. ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #t #t 0) -0. ,(flo:make-nan #t #t 0))
+    (,(flo:make-nan #f #f 1) 0. ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #t #f 1) 0. ,(flo:make-nan #f #f 1))
+    (,(flo:make-nan #f #f 1) -0. ,(flo:make-nan #t #f 1))
+    (,(flo:make-nan #t #f 1) -0. ,(flo:make-nan #t #f 1)))
   (lambda (x y z)
-    (assert-eqv-nan (yes-traps (lambda () (flo:copysign x y))) z)))
+    (assert-eqv-nan (yes-traps (lambda () (flo:copysign x y))) z)
+    (assert-eqv-nan
+     (yes-traps (lambda () (flo:copysign (flo:negate x) y)))
+     z)
+    (assert-eqv-nan
+     (yes-traps (lambda () (flo:copysign x (flo:negate y))))
+     (flo:negate z))
+    (assert-eqv-nan
+     (yes-traps (lambda () (flo:copysign (flo:negate x) (flo:negate y))))
+     (flo:negate z))))
 
 (define-enumerated-test 'copysign-var/neg
   `((-inf.0 -inf.0)
-- 
2.25.1