>From d4a0dfbaa775f6268a20fde2161911c5ce12e9a9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 1 Feb 2011 05:19:24 -0500 Subject: [PATCH] Fix bugs in `rationalize' * libguile/numbers.c (scm_rationalize): Fix bugs. Previously, it returned exact integers unmodified, although that was incorrect if the epsilon was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per R5RS and R6RS, but previously it returned 4. Also handle cases involving infinities and NaNs properly, per R6RS. * test-suite/tests/numbers.test: Add test cases for `rationalize'. * NEWS: Add NEWS entry --- NEWS | 8 ++++++ libguile/numbers.c | 52 +++++++++++++++++++++++++++++++--------- test-suite/tests/numbers.test | 37 +++++++++++++++++++++++++++++ 3 files changed, 85 insertions(+), 12 deletions(-) diff --git a/NEWS b/NEWS index 2ba79a6..3769b81 100644 --- a/NEWS +++ b/NEWS @@ -169,6 +169,14 @@ an error when a non-real number or non-number is passed to these procedures. (Note that NaNs _are_ considered numbers by scheme, despite their name). +*** `rationalize' bugfixes and changes + +Fixed bugs in scm_rationalize `rationalize'. Previously, it returned +exact integers unmodified, although that was incorrect if the epsilon +was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per +R5RS and R6RS, but previously it returned 4. It also now handles +cases involving infinities and NaNs properly, per R6RS. + *** New procedure: `finite?' Add scm_finite_p `finite?' from R6RS to guile core, which returns #t diff --git a/libguile/numbers.c b/libguile/numbers.c index d08d15f..d4380dd 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -7267,11 +7267,46 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_rationalize { - if (SCM_I_INUMP (x)) - return x; - else if (SCM_BIGP (x)) + SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real"); + SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real"); + eps = scm_abs (eps); + if (scm_is_false (scm_positive_p (eps))) + { + /* eps is either zero or a NaN */ + if (scm_is_true (scm_nan_p (eps))) + return scm_nan (); + else if (SCM_INEXACTP (eps)) + return scm_exact_to_inexact (x); + else + return x; + } + else if (scm_is_false (scm_finite_p (eps))) + { + if (scm_is_true (scm_finite_p (x))) + return flo0; + else + return scm_nan (); + } + else if (scm_is_false (scm_finite_p (x))) /* checks for both inf and nan */ return x; - else if ((SCM_REALP (x)) || SCM_FRACTIONP (x)) + else if (scm_is_false (scm_less_p (scm_floor (scm_sum (x, eps)), + scm_ceiling (scm_difference (x, eps))))) + { + /* There's an integer within range; we want the one closest to zero */ + if (scm_is_false (scm_less_p (eps, scm_abs (x)))) + { + /* zero is within range */ + if (SCM_INEXACTP (x) || SCM_INEXACTP (eps)) + return flo0; + else + return SCM_INUM0; + } + else if (scm_is_true (scm_positive_p (x))) + return scm_ceiling (scm_difference (x, eps)); + else + return scm_floor (scm_sum (x, eps)); + } + else { /* Use continued fractions to find closest ratio. All arithmetic is done with exact numbers. @@ -7285,9 +7320,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, SCM rx; int i = 0; - if (scm_is_true (scm_num_eq_p (ex, int_part))) - return ex; - ex = scm_difference (ex, int_part); /* x = x-int_part */ rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */ @@ -7296,7 +7328,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, converges after less than a dozen iterations. */ - eps = scm_abs (eps); while (++i < 1000000) { a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */ @@ -7307,8 +7338,7 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, eps))) /* abs(x-a/b) <= eps */ { SCM res = scm_sum (int_part, scm_divide (a, b)); - if (scm_is_false (scm_exact_p (x)) - || scm_is_false (scm_exact_p (eps))) + if (SCM_INEXACTP (x) || SCM_INEXACTP (eps)) return scm_exact_to_inexact (res); else return res; @@ -7323,8 +7353,6 @@ SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0, } scm_num_overflow (s_scm_rationalize); } - else - SCM_WRONG_TYPE_ARG (1, x); } #undef FUNC_NAME diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index d85e44c..5619bf0 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1328,6 +1328,43 @@ (pass-if (= lcm-of-big-n-and-11 (lcm 11 big-n 11))))) ;;; +;;; rationalize +;;; +(with-test-prefix "rationalize" + (pass-if (documented? rationalize)) + (pass-if (eqv? 2 (rationalize 4 2 ))) + (pass-if (eqv? -2 (rationalize -4 2 ))) + (pass-if (eqv? 2.0 (rationalize 4 2.0))) + (pass-if (eqv? -2.0 (rationalize -4.0 2 ))) + + (pass-if (eqv? 0 (rationalize 4 8 ))) + (pass-if (eqv? 0 (rationalize -4 8 ))) + (pass-if (eqv? 0.0 (rationalize 4 8.0))) + (pass-if (eqv? 0.0 (rationalize -4.0 8 ))) + + (pass-if (eqv? 0.0 (rationalize 3 +inf.0))) + (pass-if (eqv? 0.0 (rationalize -3 +inf.0))) + + (pass-if (nan? (rationalize +inf.0 +inf.0))) + (pass-if (nan? (rationalize +nan.0 +inf.0))) + (pass-if (nan? (rationalize +nan.0 4))) + (pass-if (eqv? +inf.0 (rationalize +inf.0 3))) + + (pass-if (eqv? 3/10 (rationalize 3/10 0))) + (pass-if (eqv? -3/10 (rationalize -3/10 0))) + + (pass-if (eqv? 1/3 (rationalize 3/10 1/10))) + (pass-if (eqv? -1/3 (rationalize -3/10 1/10))) + + (pass-if (eqv? 1/3 (rationalize 3/10 -1/10))) + (pass-if (eqv? -1/3 (rationalize -3/10 -1/10))) + + (pass-if (test-eqv? (/ 1.0 3) (rationalize 0.3 1/10))) + (pass-if (test-eqv? (/ -1.0 3) (rationalize -0.3 1/10))) + (pass-if (test-eqv? (/ 1.0 3) (rationalize 0.3 -1/10))) + (pass-if (test-eqv? (/ -1.0 3) (rationalize -0.3 -1/10)))) + +;;; ;;; number->string ;;; -- 1.5.6.5