[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-33-g3bbca1f

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=3bbca1f7237c0e9d9419eaea8f274c9cd7314f04

The branch, stable-2.0 has been updated
       via  3bbca1f7237c0e9d9419eaea8f274c9cd7314f04 (commit)
      from  b4c55c9ccedd47c16007b590f064ef3bd67565aa (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 3bbca1f7237c0e9d9419eaea8f274c9cd7314f04
Author: Mark H Weaver <address@hidden>
Date:   Tue Jul 16 06:38:38 2013 -0400

    gcd and lcm support inexact integer arguments.
    
    Fixes <http://bugs.gnu.org/14870>.
    Reported by Göran Weinholt <address@hidden>.
    
    * libguile/numbers.c (scm_gcd, scm_lcm): Support inexact integers.
    
    * test-suite/tests/numbers.test (gcd, lcm): Add tests.

-----------------------------------------------------------------------

Summary of changes:
 libguile/numbers.c            |   61 +++++++++++++++++++++++++++++----------
 test-suite/tests/numbers.test |   62 +++++++++++++++++++++++++++++++++++++++-
 2 files changed, 105 insertions(+), 18 deletions(-)

diff --git a/libguile/numbers.c b/libguile/numbers.c
index 6107310..5ee1fc7 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);
-    }
-
-  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_UNLIKELY (SCM_UNBNDP (n2)))
+    return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1);
 
-  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 0d4285a..a36d493 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)))


hooks/post-receive
-- 
GNU Guile