diff options
| -rw-r--r-- | libguile/numbers.c | 20 | ||||
| -rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 15 | ||||
| -rw-r--r-- | test-suite/tests/numbers.test | 94 | ||||
| -rw-r--r-- | 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 5d64b4ab2..b9e453a63 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 1c4b94ce7..e3f3ce714 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 ffbbea26f..68f8f91a7 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 ea425e3dc..c90184daa 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)) |