mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Fix numerator and denominator handling of signed zeroes and infinities.

Browse source 
* 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).
This commit is contained in:
Mark H Weaver 2013-08-09 05:32:23 -04:00
parent d9b312af56
commit fa102e73c3
4 changed files with 55 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

20
libguile/numbers.c
View file

@ -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);
}

15
module/rnrs/arithmetic/flonums.scm
View file

@ -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))

86
test-suite/tests/numbers.test
View file

@ -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-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 "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-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 "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.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-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 "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-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 "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.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

2
test-suite/tests/r6rs-arithmetic-flonums.test
View file

@ -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))