mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Fix bugs in `rationalize'

Browse source 
* 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
This commit is contained in:
Mark H Weaver 2011-02-01 05:19:24 -05:00 • committed by Andy Wingo
parent 820381bc7f
commit 605f698026
3 changed files with 85 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

8
NEWS
View file

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

52
libguile/numbers.c
View file

@ -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))
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_BIGP (x))
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

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

@ -1327,6 +1327,43 @@
(pass-if (= lcm-of-big-n-and-11 (lcm big-n 11)))
(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
;;;