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

gcd and lcm support inexact integer arguments.

Browse source 
Fixes <http://bugs.gnu.org/14870>.
Reported by Göran Weinholt <goran@weinholt.se>.

* libguile/numbers.c (scm_gcd, scm_lcm): Support inexact integers.

* test-suite/tests/numbers.test (gcd, lcm): Add tests.
This commit is contained in:
Mark H Weaver 2013-07-16 06:38:38 -04:00
parent b4c55c9cce
commit 3bbca1f723
2 changed files with 105 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

61
libguile/numbers.c
View file

@ -4145,6 +4145,8 @@ scm_gcd (SCM x, SCM y)
SCM_SWAP (x, y);
goto big_inum;
}
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
@ -4175,6 +4177,20 @@ scm_gcd (SCM x, SCM y)
scm_remember_upto_here_2 (x, y);
return scm_i_normbig (result);
}
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_REALP (x) && scm_is_integer (x))
{
if (SCM_I_INUMP (y) || SCM_BIGP (y)
|| (SCM_REALP (y) && scm_is_integer (y)))
{
handle_inexacts:
return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x),
scm_inexact_to_exact (y)));
}
else
SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
@ -4203,21 +4219,12 @@ SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
SCM
scm_lcm (SCM n1, SCM n2)
{
if (SCM_UNBNDP (n2))
{
if (SCM_UNBNDP (n1))
return SCM_I_MAKINUM (1L);
n2 = SCM_I_MAKINUM (1L);
}
if (SCM_UNLIKELY (SCM_UNBNDP (n2)))
return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1);
SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1),
g_lcm, n1, n2, SCM_ARG1, s_lcm);
SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2),
g_lcm, n1, n2, SCM_ARGn, s_lcm);
if (SCM_I_INUMP (n1))
if (SCM_LIKELY (SCM_I_INUMP (n1)))
{
if (SCM_I_INUMP (n2))
if (SCM_LIKELY (SCM_I_INUMP (n2)))
{
SCM d = scm_gcd (n1, n2);
if (scm_is_eq (d, SCM_INUM0))
@ -4225,7 +4232,7 @@ scm_lcm (SCM n1, SCM n2)
else
return scm_abs (scm_product (n1, scm_quotient (n2, d)));
}
else
else if (SCM_LIKELY (SCM_BIGP (n2)))
{
/* inum n1, big n2 */
inumbig:
@ -4239,8 +4246,12 @@ scm_lcm (SCM n1, SCM n2)
return result;
}
}
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else
else if (SCM_LIKELY (SCM_BIGP (n1)))
{
/* big n1 */
if (SCM_I_INUMP (n2))
@ -4248,7 +4259,7 @@ scm_lcm (SCM n1, SCM n2)
SCM_SWAP (n1, n2);
goto inumbig;
}
else
else if (SCM_LIKELY (SCM_BIGP (n2)))
{
SCM result = scm_i_mkbig ();
mpz_lcm(SCM_I_BIG_MPZ (result),
@ -4258,7 +4269,25 @@ scm_lcm (SCM n1, SCM n2)
/* shouldn't need to normalize b/c lcm of 2 bigs should be big */
return result;
}
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else if (SCM_REALP (n1) && scm_is_integer (n1))
{
if (SCM_I_INUMP (n2) || SCM_BIGP (n2)
|| (SCM_REALP (n2) && scm_is_integer (n2)))
{
handle_inexacts:
return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1),
scm_inexact_to_exact (n2)));
}
else
SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else
SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:

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

@ -1322,6 +1322,32 @@
(pass-if "n = fixnum-min - 1"
(eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1)))))
(with-test-prefix "flonum arguments"
(pass-if-equal "flonum"
15.0
(gcd -15.0))
(pass-if-equal "flonum/flonum"
3.0
(gcd 6.0 -15.0))
(pass-if-equal "flonum/fixnum"
3.0
(gcd 6.0 -15))
(pass-if-equal "fixnum/flonum"
3.0
(gcd -6 15.0))
(pass-if-equal "flonum/bignum"
2.0
(gcd -6.0 (expt 2 fixnum-bit)))
(pass-if-equal "bignum/flonum"
3.0
(gcd (- (expt 3 fixnum-bit)) 6.0)))
;; Are wrong type arguments detected correctly?
)
@ -1334,8 +1360,40 @@
;; FIXME: more tests?
;; (some of these are already in r4rs.test)
(pass-if (documented? lcm))
(pass-if (= (lcm) 1))
(pass-if (= (lcm 32 -36) 288))
(pass-if-equal 1 (lcm))
(pass-if-equal 15 (lcm -15))
(pass-if-equal 288 (lcm 32 -36))
(with-test-prefix "flonum arguments"
(pass-if-equal "flonum"
15.0
(lcm -15.0))
(pass-if-equal "flonum/flonum"
30.0
(lcm 6.0 -15.0))
(pass-if-equal "flonum/fixnum"
30.0
(lcm 6.0 -15))
(pass-if-equal "fixnum/flonum"
30.0
(lcm -6 15.0))
(pass-if "flonum/bignum"
(let ((want (* 3.0 (expt 2 fixnum-bit)))
(got (lcm -6.0 (expt 2 fixnum-bit))))
(and (inexact? got)
(test-eqv? 1.0 (/ want got)))))
(pass-if "bignum/flonum"
(let ((want (* 2.0 (expt 3 fixnum-bit)))
(got (lcm (- (expt 3 fixnum-bit)) 6.0)))
(and (inexact? got)
(test-eqv? 1.0 (/ want got))))))
(let ((big-n 115792089237316195423570985008687907853269984665640564039457584007913129639936) ; 2 ^ 256
(lcm-of-big-n-and-11 1273712981610478149659280835095566986385969831322046204434033424087044426039296))
(pass-if (= lcm-of-big-n-and-11 (lcm big-n 11)))