diff options
| -rw-r--r-- | libguile/integers.c | 50 | ||||
| -rw-r--r-- | libguile/integers.h | 5 | ||||
| -rw-r--r-- | 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 |