[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-63-gfa102e7

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=fa102e73c3d14f52d089ec2faa55c9a7e87f4a23

The branch, stable-2.0 has been updated
       via  fa102e73c3d14f52d089ec2faa55c9a7e87f4a23 (commit)
      from  d9b312af56666efa72cf15e87091b707ac600f13 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit fa102e73c3d14f52d089ec2faa55c9a7e87f4a23
Author: Mark H Weaver <address@hidden>
Date:   Fri Aug 9 05:32:23 2013 -0400

    Fix numerator and denominator handling of signed zeroes and infinities.
    
    * libguile/numbers.c (scm_numerator, scm_denominator): Handle signed
      zeroes and infinities in accordance with the corresponding R6RS flonum
      procedures.
    
    * module/rnrs/arithmetic/flonums.scm (flnumerator, fldenominator):
      Remove special handling of infinities.
    
    * test-suite/tests/numbers.test (numerator, denominator): Add tests.
      Convert existing tests to use 'pass-if-equal'.
    
    * test-suite/tests/r6rs-arithmetic-flonums.test (flnumerator): Fix
      broken test of (flnumerator -0.0).

-----------------------------------------------------------------------

Summary of changes:
 libguile/numbers.c                            |   20 +++++-
 module/rnrs/arithmetic/flonums.scm            |   15 +----
 test-suite/tests/numbers.test                 |   94 ++++++++++---------------
 test-suite/tests/r6rs-arithmetic-flonums.test |    2 +-
 4 files changed, 59 insertions(+), 72 deletions(-)

diff --git a/libguile/numbers.c b/libguile/numbers.c
index 5d64b4a..b9e453a 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -9183,7 +9183,15 @@ SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 
0,
   else if (SCM_FRACTIONP (z))
     return SCM_FRACTION_NUMERATOR (z);
   else if (SCM_REALP (z))
-    return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+    {
+      double zz = SCM_REAL_VALUE (z);
+      if (zz == floor (zz))
+        /* Handle -0.0 and infinities in accordance with R6RS
+           flnumerator, and optimize handling of integers. */
+        return z;
+      else
+        return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+    }
   else
     SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
 }
@@ -9200,7 +9208,15 @@ SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 
1, 0, 0,
   else if (SCM_FRACTIONP (z))
     return SCM_FRACTION_DENOMINATOR (z);
   else if (SCM_REALP (z))
-    return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+    {
+      double zz = SCM_REAL_VALUE (z);
+      if (zz == floor (zz))
+        /* Handle infinities in accordance with R6RS fldenominator, and
+           optimize handling of integers. */
+        return scm_i_from_double (1.0);
+      else
+        return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact 
(z)));
+    }
   else
     SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator);
 }
diff --git a/module/rnrs/arithmetic/flonums.scm 
b/module/rnrs/arithmetic/flonums.scm
index 1c4b94c..e3f3ce7 100644
--- a/module/rnrs/arithmetic/flonums.scm
+++ b/module/rnrs/arithmetic/flonums.scm
@@ -153,19 +153,8 @@
     (assert-iflonum fl1 fl2)
     (mod0 fl1 fl2))
 
-  (define (flnumerator fl) 
-    (assert-flonum fl) 
-    (case fl 
-      ((+inf.0) +inf.0) 
-      ((-inf.0) -inf.0)
-      (else (numerator fl))))
-
-  (define (fldenominator fl) 
-    (assert-flonum fl) 
-    (case fl
-      ((+inf.0) 1.0)
-      ((-inf.0) 1.0)
-      (else (denominator fl))))
+  (define (flnumerator fl) (assert-flonum fl) (numerator fl))
+  (define (fldenominator fl) (assert-flonum fl) (denominator fl))
   
   (define (flfloor fl) (assert-flonum fl) (floor fl))
   (define (flceiling fl) (assert-flonum fl) (ceiling fl))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index ffbbea2..68f8f91 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1079,68 +1079,50 @@
 ;;;
 
 (with-test-prefix "numerator"
-  (pass-if "0"
-    (eqv? 0 (numerator 0)))
-  (pass-if "1"
-    (eqv? 1 (numerator 1)))
-  (pass-if "2"
-    (eqv? 2 (numerator 2)))
-  (pass-if "-1"
-    (eqv? -1 (numerator -1)))
-  (pass-if "-2"
-    (eqv? -2 (numerator -2)))
-
-  (pass-if "0.0"
-    (eqv? 0.0 (numerator 0.0)))
-  (pass-if "1.0"
-    (eqv? 1.0 (numerator 1.0)))
-  (pass-if "2.0"
-    (eqv? 2.0 (numerator 2.0)))
-  (pass-if "-1.0"
-    (eqv? -1.0 (numerator -1.0)))
-  (pass-if "-2.0"
-    (eqv? -2.0 (numerator -2.0)))
-
-  (pass-if "0.5"
-    (eqv? 1.0 (numerator 0.5)))
-  (pass-if "0.25"
-    (eqv? 1.0 (numerator 0.25)))
-  (pass-if "0.75"
-    (eqv? 3.0 (numerator 0.75))))
+  (pass-if-equal "0" 0 (numerator 0))
+  (pass-if-equal "1" 1 (numerator 1))
+  (pass-if-equal "2" 2 (numerator 2))
+  (pass-if-equal "-1" -1 (numerator -1))
+  (pass-if-equal "-2" -2 (numerator -2))
+
+  (pass-if-equal "0.0" 0.0 (numerator 0.0))
+  (pass-if-equal "1.0" 1.0 (numerator 1.0))
+  (pass-if-equal "2.0" 2.0 (numerator 2.0))
+  (pass-if-equal "-0.0" -0.0 (numerator -0.0))
+  (pass-if-equal "-1.0" -1.0 (numerator -1.0))
+  (pass-if-equal "-2.0" -2.0 (numerator -2.0))
+
+  (pass-if-equal "0.5" 1.0 (numerator 0.5))
+  (pass-if-equal "0.25" 1.0 (numerator 0.25))
+  (pass-if-equal "0.75" 3.0 (numerator 0.75))
+
+  (pass-if-equal "+inf.0" +inf.0 (numerator +inf.0))
+  (pass-if-equal "-inf.0" -inf.0 (numerator -inf.0)))
 
 ;;;
 ;;; denominator
 ;;;
 
 (with-test-prefix "denominator"
-  (pass-if "0"
-    (eqv? 1 (denominator 0)))
-  (pass-if "1"
-    (eqv? 1 (denominator 1)))
-  (pass-if "2"
-    (eqv? 1 (denominator 2)))
-  (pass-if "-1"
-    (eqv? 1 (denominator -1)))
-  (pass-if "-2"
-    (eqv? 1 (denominator -2)))
-
-  (pass-if "0.0"
-    (eqv? 1.0 (denominator 0.0)))
-  (pass-if "1.0"
-    (eqv? 1.0 (denominator 1.0)))
-  (pass-if "2.0"
-    (eqv? 1.0 (denominator 2.0)))
-  (pass-if "-1.0"
-    (eqv? 1.0 (denominator -1.0)))
-  (pass-if "-2.0"
-    (eqv? 1.0 (denominator -2.0)))
-
-  (pass-if "0.5"
-    (eqv? 2.0 (denominator 0.5)))
-  (pass-if "0.25"
-    (eqv? 4.0 (denominator 0.25)))
-  (pass-if "0.75"
-    (eqv? 4.0 (denominator 0.75))))
+  (pass-if-equal "0" 1 (denominator 0))
+  (pass-if-equal "1" 1 (denominator 1))
+  (pass-if-equal "2" 1 (denominator 2))
+  (pass-if-equal "-1" 1 (denominator -1))
+  (pass-if-equal "-2" 1 (denominator -2))
+
+  (pass-if-equal "0.0" 1.0 (denominator 0.0))
+  (pass-if-equal "1.0" 1.0 (denominator 1.0))
+  (pass-if-equal "2.0" 1.0 (denominator 2.0))
+  (pass-if-equal "-0.0" 1.0 (denominator -0.0))
+  (pass-if-equal "-1.0" 1.0 (denominator -1.0))
+  (pass-if-equal "-2.0" 1.0 (denominator -2.0))
+
+  (pass-if-equal "0.5" 2.0 (denominator 0.5))
+  (pass-if-equal "0.25" 4.0 (denominator 0.25))
+  (pass-if-equal "0.75" 4.0 (denominator 0.75))
+
+  (pass-if-equal "+inf.0" 1.0 (denominator +inf.0))
+  (pass-if-equal "-inf.0" 1.0 (denominator -inf.0)))
 
 ;;;
 ;;; gcd
diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test 
b/test-suite/tests/r6rs-arithmetic-flonums.test
index ea425e3..c90184d 100644
--- a/test-suite/tests/r6rs-arithmetic-flonums.test
+++ b/test-suite/tests/r6rs-arithmetic-flonums.test
@@ -218,7 +218,7 @@
     (and (fl=? (flnumerator +inf.0) +inf.0)
         (fl=? (flnumerator -inf.0) -inf.0)))
 
-  (pass-if "negative zero" (fl=? (flnumerator -0.0) -0.0)))
+  (pass-if "negative zero" (eqv? (flnumerator -0.0) -0.0)))
 
 (with-test-prefix "fldenominator"
   (pass-if "simple" (fl=? (fldenominator 0.5) 2.0))


hooks/post-receive
-- 
GNU Guile