diff --git a/libguile/numbers.c b/libguile/numbers.c index 6107310ba..5ee1fc723 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -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: diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 0d4285ad4..a36d49394 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -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)))