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

@@ -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);
+}

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 */

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;
+  if (!scm_is_exact_integer (n))
-  istart = scm_to_ulong (start);
+    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
-  iend = scm_to_ulong (end);
-  SCM_ASSERT_RANGE (3, end, (iend >= istart));
 
-  /* how many bits to keep */
+  unsigned long istart = scm_to_ulong (start);
-  bits = iend - istart;
+  unsigned long iend = scm_to_ulong (end);
+  SCM_ASSERT_RANGE (3, end, (iend >= istart));
+  unsigned long bits = iend - istart;
 
   if (SCM_I_INUMP (n))
-    {
+    return scm_integer_bit_extract_i (SCM_I_INUM (n), istart, bits);
-      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;
-    }
   else
-    SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+    return scm_integer_bit_extract_z (n, istart, bits);
 }
 #undef FUNC_NAME