[Guile-commits] 30/85: Implement scm_bit_extract with new integer library

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 88f56e91aa283421665cd736a2d4f138d737d815
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Jan 4 09:43:26 2022 +0100

    Implement scm_bit_extract with new integer library
    
    * libguile/integers.c (scm_integer_bit_extract_i)
    (scm_integer_bit_extract_z): New internal functions.
    * libguile/integers.h: Declare the new internal functions.
    * libguile/numbers.c (scm_bit_extract): Use new internal functions.
---
 libguile/integers.c | 50 +++++++++++++++++++++++++++++++++++++++++++
 libguile/integers.h |  5 +++++
 libguile/numbers.c  | 61 +++++++----------------------------------------------
 3 files changed, 63 insertions(+), 53 deletions(-)

diff --git a/libguile/integers.c b/libguile/integers.c
index 820f19ddf..8ddcd087e 100644
--- a/libguile/integers.c
+++ b/libguile/integers.c
@@ -2204,3 +2204,53 @@ scm_integer_round_rsh_zu (SCM n, unsigned long count)
   scm_remember_upto_here_1 (n);
   return take_mpz (q);
 }
+
+#define MIN(A, B) ((A) <= (B) ? (A) : (B))
+
+SCM
+scm_integer_bit_extract_i (scm_t_inum n, unsigned long start,
+                           unsigned long bits)
+{
+  /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
+     SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "n". */
+  n = SCM_SRS (n, MIN (start, SCM_I_FIXNUM_BIT-1));
+
+  if (n < 0 && bits >= SCM_I_FIXNUM_BIT)
+    {
+      /* Since we emulate two's complement encoded numbers, this special
+         case requires us to produce a result that has more bits than
+         can be stored in a fixnum.  */
+      mpz_t result;
+      mpz_init_set_si (result, n);
+      mpz_fdiv_r_2exp (result, result, bits);
+      return take_mpz (result);
+    }
+
+  /* mask down to requisite bits */
+  bits = MIN (bits, SCM_I_FIXNUM_BIT);
+  return SCM_I_MAKINUM (n & ((1L << bits) - 1));
+}
+
+SCM
+scm_integer_bit_extract_z (SCM n, unsigned long start, unsigned long bits)
+{
+  mpz_t zn;
+  alias_bignum_to_mpz (scm_bignum (n), zn);
+
+  if (bits == 1)
+    {
+      int bit = mpz_tstbit (zn, start);
+      scm_remember_upto_here_1 (n);
+      return SCM_I_MAKINUM (bit);
+    }
+
+  /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
+     bits<SCM_I_FIXNUM_BIT.  Would want some help from GMP to get
+     such bits into a ulong.  */
+  mpz_t result;
+  mpz_init (result);
+  mpz_fdiv_q_2exp (result, zn, start);
+  mpz_fdiv_r_2exp (result, result, bits);
+  scm_remember_upto_here_1 (n);
+  return take_mpz (result);
+}
diff --git a/libguile/integers.h b/libguile/integers.h
index dea4c2235..e77084ea3 100644
--- a/libguile/integers.h
+++ b/libguile/integers.h
@@ -163,6 +163,11 @@ SCM_INTERNAL SCM scm_integer_floor_rsh_zu (SCM n, unsigned 
long count);
 SCM_INTERNAL SCM scm_integer_round_rsh_iu (scm_t_inum n, unsigned long count);
 SCM_INTERNAL SCM scm_integer_round_rsh_zu (SCM n, unsigned long count);
 
+SCM_INTERNAL SCM scm_integer_bit_extract_i (scm_t_inum n, unsigned long start,
+                                            unsigned long bits);
+SCM_INTERNAL SCM scm_integer_bit_extract_z (SCM n, unsigned long start,
+                                            unsigned long bits);
+
 
 
 #endif  /* SCM_INTEGERS_H */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 46f7b21d2..84b920eac 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -3340,9 +3340,6 @@ SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-
-#define MIN(A, B) ((A) <= (B) ? (A) : (B))
-
 SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
             (SCM n, SCM start, SCM end),
            "Return the integer composed of the @var{start} (inclusive)\n"
@@ -3357,60 +3354,18 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
            "@end lisp")
 #define FUNC_NAME s_scm_bit_extract
 {
-  unsigned long int istart, iend, bits;
-  istart = scm_to_ulong (start);
-  iend = scm_to_ulong (end);
-  SCM_ASSERT_RANGE (3, end, (iend >= istart));
+  if (!scm_is_exact_integer (n))
+    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
 
-  /* how many bits to keep */
-  bits = iend - istart;
+  unsigned long istart = scm_to_ulong (start);
+  unsigned long iend = scm_to_ulong (end);
+  SCM_ASSERT_RANGE (3, end, (iend >= istart));
+  unsigned long bits = iend - istart;
 
   if (SCM_I_INUMP (n))
-    {
-      scm_t_inum in = SCM_I_INUM (n);
-
-      /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
-         SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
-      in = SCM_SRS (in, MIN (istart, SCM_I_FIXNUM_BIT-1));
-
-      if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
-       {
-         /* Since we emulate two's complement encoded numbers, this
-          * special case requires us to produce a result that has
-          * more bits than can be stored in a fixnum.
-          */
-          SCM result = scm_i_inum2big (in);
-          mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
-                           bits);
-          return result;
-       }
-
-      /* mask down to requisite bits */
-      bits = MIN (bits, SCM_I_FIXNUM_BIT);
-      return SCM_I_MAKINUM (in & ((1L << bits) - 1));
-    }
-  else if (SCM_BIGP (n))
-    {
-      SCM result;
-      if (bits == 1)
-        {
-          result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart));
-        }
-      else
-        {
-          /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
-             bits<SCM_I_FIXNUM_BIT.  Would want some help from GMP to get
-             such bits into a ulong.  */
-          result = scm_i_mkbig ();
-          mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(n), istart);
-          mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(result), bits);
-          result = scm_i_normbig (result);
-        }
-      scm_remember_upto_here_1 (n);
-      return result;
-    }
+    return scm_integer_bit_extract_i (SCM_I_INUM (n), istart, bits);
   else
-    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+    return scm_integer_bit_extract_z (n, istart, bits);
 }
 #undef FUNC_NAME