[Guile-commits] 08/69: Implement ceiling-quotient with new integer lib

[Andy Wingo]

wingo pushed a commit to branch wip-inline-digits
in repository guile.

commit a9b43e9deb16f78b9539004ea162ade4987f74c2
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Dec 10 13:38:19 2021 +0100

    Implement ceiling-quotient with new integer lib
    
    * libguile/integers.c (scm_integer_ceiling_quotient_ii)
    (scm_integer_ceiling_quotient_iz, scm_integer_ceiling_quotient_zi)
    (scm_integer_ceiling_quotient_zz): New internal functions.
    (take_bignum_from_mpz): Change to also normalize the mpz, as all callers
    required.
    (long_sign, bignum_cmp_long): New helpers.
    * libguile/integers.h: Declare internal functions.
    * libguile/numbers.c (scm_ceiling_quotient): Use the new functions.
---
 libguile/integers.c | 143 +++++++++++++++++++++++++++++++++++++++++++++-------
 libguile/integers.h |   5 ++
 libguile/numbers.c  |  87 ++++----------------------------
 3 files changed, 138 insertions(+), 97 deletions(-)

diff --git a/libguile/integers.c b/libguile/integers.c
index a791657ff..f27d77b54 100644
--- a/libguile/integers.c
+++ b/libguile/integers.c
@@ -222,14 +222,6 @@ make_bignum_from_mpz (mpz_srcptr mpz)
   return mpz_sgn (mpz) < 0 ? negate_bignum (ret) : ret;
 }
 
-static struct scm_bignum *
-take_bignum_from_mpz (mpz_ptr mpz)
-{
-  struct scm_bignum *res = make_bignum_from_mpz (mpz);
-  mpz_clear (mpz);
-  return res;
-}
-
 static SCM
 normalize_bignum (struct scm_bignum *z)
 {
@@ -251,6 +243,42 @@ normalize_bignum (struct scm_bignum *z)
   return SCM_PACK (z);
 }
 
+static SCM
+take_bignum_from_mpz (mpz_ptr mpz)
+{
+  struct scm_bignum *res = make_bignum_from_mpz (mpz);
+  mpz_clear (mpz);
+  return normalize_bignum (res);
+}
+
+static int
+long_sign (long l)
+{
+  if (l < 0) return -1;
+  if (l == 0) return 0;
+  return 1;
+}
+
+static int
+bignum_cmp_long (struct scm_bignum *z, long l)
+{
+  switch (bignum_size (z))
+    {
+    case -1:
+      if (l >= 0)
+        return -1;
+      return long_sign (long_magnitude (l) - bignum_limbs (z)[0]);
+    case 0:
+      return long_sign (l);
+    case 1:
+      if (l <= 0)
+        return 1;
+      return long_sign (bignum_limbs (z)[0] - (unsigned long) l);
+    default:
+      return long_sign (bignum_size (z));
+    }
+}
+
 int
 scm_is_integer_odd_i (scm_t_inum i)
 {
@@ -324,7 +352,7 @@ scm_integer_floor_quotient_zi (SCM x, scm_t_inum y)
       mpz_neg (q, q);
     }
   scm_remember_upto_here_1 (x);
-  return SCM_PACK (normalize_bignum (take_bignum_from_mpz (q)));
+  return take_bignum_from_mpz (q);
 }
 
 SCM
@@ -336,7 +364,7 @@ scm_integer_floor_quotient_zz (SCM x, SCM y)
   mpz_init (q);
   mpz_fdiv_q (q, zx, zy);
   scm_remember_upto_here_2 (x, y);
-  return SCM_PACK (normalize_bignum (take_bignum_from_mpz (q)));
+  return take_bignum_from_mpz (q);
 }
 
 SCM
@@ -363,7 +391,7 @@ scm_integer_floor_remainder_iz (scm_t_inum x, SCM y)
           alias_bignum_to_mpz (scm_bignum (y), zy);
           mpz_sub_ui (r, zy, -x);
           scm_remember_upto_here_1 (y);
-          return SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+          return take_bignum_from_mpz (r);
         }
       else
         return SCM_I_MAKINUM (x);
@@ -377,7 +405,7 @@ scm_integer_floor_remainder_iz (scm_t_inum x, SCM y)
       alias_bignum_to_mpz (scm_bignum (y), zy);
       mpz_add_ui (r, zy, x);
       scm_remember_upto_here_1 (y);
-      return SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+      return take_bignum_from_mpz (r);
     }
 }
 
@@ -409,7 +437,7 @@ scm_integer_floor_remainder_zz (SCM x, SCM y)
   mpz_init (r);
   mpz_fdiv_r (r, zx, zy);
   scm_remember_upto_here_2 (x, y);
-  return SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+  return take_bignum_from_mpz (r);
 }
 
 void
@@ -445,7 +473,7 @@ scm_integer_floor_divide_iz (scm_t_inum x, SCM y, SCM *qp, 
SCM *rp)
           mpz_sub_ui (r, zy, -x);
           scm_remember_upto_here_1 (y);
           *qp = SCM_I_MAKINUM (-1);
-          *rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+          *rp = take_bignum_from_mpz (r);
         }
       else
         {
@@ -466,7 +494,7 @@ scm_integer_floor_divide_iz (scm_t_inum x, SCM y, SCM *qp, 
SCM *rp)
       mpz_add_ui (r, zy, x);
       scm_remember_upto_here_1 (y);
       *qp = SCM_I_MAKINUM (-1);
-      *rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+      *rp = take_bignum_from_mpz (r);
     }
 }
 
@@ -488,8 +516,8 @@ scm_integer_floor_divide_zi (SCM x, scm_t_inum y, SCM *qp, 
SCM *rp)
       mpz_neg (q, q);
     }
   scm_remember_upto_here_1 (x);
-  *qp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (q)));
-  *rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+  *qp = take_bignum_from_mpz (q);
+  *rp = take_bignum_from_mpz (r);
 }
 
 void
@@ -502,6 +530,83 @@ scm_integer_floor_divide_zz (SCM x, SCM y, SCM *qp, SCM 
*rp)
   alias_bignum_to_mpz (scm_bignum (y), zy);
   mpz_fdiv_qr (q, r, zx, zy);
   scm_remember_upto_here_2 (x, y);
-  *qp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (q)));
-  *rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r)));
+  *qp = take_bignum_from_mpz (q);
+  *rp = take_bignum_from_mpz (r);
+}
+
+SCM
+scm_integer_ceiling_quotient_ii (scm_t_inum x, scm_t_inum y)
+{
+  if (y == 0)
+    scm_num_overflow ("ceiling-quotient");
+
+  if (y > 0)
+    {
+      if (x >= 0)
+        x = x + y - 1;
+    }
+  else if (x < 0)
+    x = x + y + 1;
+  scm_t_inum q = x / y;
+
+  return long_to_scm (q);
+}
+
+SCM
+scm_integer_ceiling_quotient_iz (scm_t_inum x, SCM y)
+{
+  if (!bignum_is_negative (scm_bignum (y)))
+    {
+      if (x > 0)
+        return SCM_INUM1;
+      else if (x == SCM_MOST_NEGATIVE_FIXNUM &&
+               bignum_cmp_long (scm_bignum (y), -SCM_MOST_NEGATIVE_FIXNUM) == 
0)
+        {
+          /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+          scm_remember_upto_here_1 (y);
+          return SCM_I_MAKINUM (-1);
+        }
+      else
+        return SCM_INUM0;
+    }
+  else if (x >= 0)
+    return SCM_INUM0;
+  else
+    return SCM_INUM1;
+}
+
+SCM
+scm_integer_ceiling_quotient_zi (SCM x, scm_t_inum y)
+{
+  if (y == 0)
+    scm_num_overflow ("ceiling-quotient");
+  else if (y == 1)
+    return x;
+  else
+    {
+      mpz_t q, zx;
+      mpz_init (q);
+      alias_bignum_to_mpz (scm_bignum (x), zx);
+      if (y > 0)
+        mpz_cdiv_q_ui (q, zx, y);
+      else
+        {
+          mpz_fdiv_q_ui (q, zx, -y);
+          mpz_neg (q, q);
+        }
+      scm_remember_upto_here_1 (x);
+      return take_bignum_from_mpz (q);
+    }
+}
+
+SCM
+scm_integer_ceiling_quotient_zz (SCM x, SCM y)
+{
+  mpz_t q, zx, zy;
+  mpz_init (q);
+  alias_bignum_to_mpz (scm_bignum (x), zx);
+  alias_bignum_to_mpz (scm_bignum (y), zy);
+  mpz_cdiv_q (q, zx, zy);
+  scm_remember_upto_here_2 (x, y);
+  return take_bignum_from_mpz (q);
 }
diff --git a/libguile/integers.h b/libguile/integers.h
index 7c3c3c030..16761bad7 100644
--- a/libguile/integers.h
+++ b/libguile/integers.h
@@ -48,6 +48,11 @@ SCM_INTERNAL void scm_integer_floor_divide_zi (SCM x, 
scm_t_inum y,
 SCM_INTERNAL void scm_integer_floor_divide_zz (SCM x, SCM y,
                                                SCM *qp, SCM *rp);
 
+SCM_INTERNAL SCM scm_integer_ceiling_quotient_ii (scm_t_inum x, scm_t_inum y);
+SCM_INTERNAL SCM scm_integer_ceiling_quotient_iz (scm_t_inum x, SCM y);
+SCM_INTERNAL SCM scm_integer_ceiling_quotient_zi (SCM x, scm_t_inum y);
+SCM_INTERNAL SCM scm_integer_ceiling_quotient_zz (SCM x, SCM y);
+
 
 
 #endif  /* SCM_INTEGERS_H */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 773d0da35..c72261081 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1507,58 +1507,15 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, 
"ceiling-quotient", 2, 0, 0,
                       "@end lisp")
 #define FUNC_NAME s_scm_ceiling_quotient
 {
-  if (SCM_LIKELY (SCM_I_INUMP (x)))
+  if (SCM_I_INUMP (x))
     {
-      scm_t_inum xx = SCM_I_INUM (x);
-      if (SCM_LIKELY (SCM_I_INUMP (y)))
-       {
-         scm_t_inum yy = SCM_I_INUM (y);
-         if (SCM_UNLIKELY (yy == 0))
-           scm_num_overflow (s_scm_ceiling_quotient);
-         else
-           {
-             scm_t_inum xx1 = xx;
-             scm_t_inum qq;
-             if (SCM_LIKELY (yy > 0))
-               {
-                 if (SCM_LIKELY (xx >= 0))
-                   xx1 = xx + yy - 1;
-               }
-             else if (xx < 0)
-               xx1 = xx + yy + 1;
-             qq = xx1 / yy;
-             if (SCM_LIKELY (SCM_FIXABLE (qq)))
-               return SCM_I_MAKINUM (qq);
-             else
-               return scm_i_inum2big (qq);
-           }
-       }
+      if (SCM_I_INUMP (y))
+        return scm_integer_ceiling_quotient_ii (SCM_I_INUM (x), SCM_I_INUM 
(y));
       else if (SCM_BIGP (y))
-       {
-         int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
-         scm_remember_upto_here_1 (y);
-         if (SCM_LIKELY (sign > 0))
-           {
-             if (SCM_LIKELY (xx > 0))
-               return SCM_INUM1;
-             else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
-                      && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
-                                      - SCM_MOST_NEGATIVE_FIXNUM) == 0))
-               {
-                 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
-                 scm_remember_upto_here_1 (y);
-                 return SCM_I_MAKINUM (-1);
-               }
-             else
-               return SCM_INUM0;
-           }
-         else if (xx >= 0)
-           return SCM_INUM0;
-         else
-           return SCM_INUM1;
-       }
+        return scm_integer_ceiling_quotient_iz (SCM_I_INUM (x), y);
       else if (SCM_REALP (y))
-       return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
+       return scm_i_inexact_ceiling_quotient (SCM_I_INUM (x),
+                                               SCM_REAL_VALUE (y));
       else if (SCM_FRACTIONP (y))
        return scm_i_exact_rational_ceiling_quotient (x, y);
       else
@@ -1567,36 +1524,10 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, 
"ceiling-quotient", 2, 0, 0,
     }
   else if (SCM_BIGP (x))
     {
-      if (SCM_LIKELY (SCM_I_INUMP (y)))
-       {
-         scm_t_inum yy = SCM_I_INUM (y);
-         if (SCM_UNLIKELY (yy == 0))
-           scm_num_overflow (s_scm_ceiling_quotient);
-         else if (SCM_UNLIKELY (yy == 1))
-           return x;
-         else
-           {
-             SCM q = scm_i_mkbig ();
-             if (yy > 0)
-               mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
-             else
-               {
-                 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
-                 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
-               }
-             scm_remember_upto_here_1 (x);
-             return scm_i_normbig (q);
-           }
-       }
+      if (SCM_I_INUMP (y))
+        return scm_integer_ceiling_quotient_zi (x, SCM_I_INUM (y));
       else if (SCM_BIGP (y))
-       {
-         SCM q = scm_i_mkbig ();
-         mpz_cdiv_q (SCM_I_BIG_MPZ (q),
-                     SCM_I_BIG_MPZ (x),
-                     SCM_I_BIG_MPZ (y));
-         scm_remember_upto_here_2 (x, y);
-         return scm_i_normbig (q);
-       }
+        return scm_integer_ceiling_quotient_zz (x, y);
       else if (SCM_REALP (y))
        return scm_i_inexact_ceiling_quotient
          (scm_i_big2dbl (x), SCM_REAL_VALUE (y));