Define (copysign m s) = magnitude of m, sign of s.

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index ae39d37e1baae9e70f5fa1f51f23145689c63951..4ebed69e16f3e13b2e53524fba2758290bd11a5d 100644 (file)
--- 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)))))
 \f
 (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)))
 \f
 (define (complex:floor x)
   (if (recnum? x)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0bbd55342948f1a3e94bd68a4bfcda686c6ec37f..5777e63efbbcd44aabbb1ae16e3708470b112c7c 100644 (file)
--- 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 c0ab2ed54b6a673d4db0978f34b9a1419e30db09..8a486805b822ed16a12c27d551f9c10a76cb9a64 100644 (file)
--- 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 39216e0b822faeb9c8e04c09c7abdb198f6e0819..4bd8469e3a6ae17ceea469e0b7c6b1b44be15a5a 100644 (file)
--- 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)