diff options
author | Andy Wingo <wingo@pobox.com> | 2021-12-03 14:07:32 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2022-01-13 09:37:16 +0100 |
commit | 5321899b9acc166003ca2c14a8c23f4bd881543a (patch) | |
tree | 9d54beb07c6879c21c45a27df2ba563e24661a63 | |
parent | c768115d93cf5535b19770831c142704128c0991 (diff) | |
download | guile-5321899b9acc166003ca2c14a8c23f4bd881543a.tar.gz |
Implement odd? and even? with new integer lib
* libguile/integers.c (scm_is_integer_odd_i):
(scm_is_integer_odd_z): New internal functions. Add a number of
internal support routines.
* libguile/integers.h: Declare internal functions.
* libguile/numbers.c (scm_odd_p, scm_even_p): Use the new functions.
-rw-r--r-- | libguile/integers.c | 211 | ||||
-rw-r--r-- | libguile/integers.h | 5 | ||||
-rw-r--r-- | libguile/numbers.c | 23 |
3 files changed, 220 insertions, 19 deletions
diff --git a/libguile/integers.c b/libguile/integers.c index d19c4450e..e449ff635 100644 --- a/libguile/integers.c +++ b/libguile/integers.c @@ -23,6 +23,8 @@ # include <config.h> #endif +#include <stdlib.h> +#include <stdio.h> #include <verify.h> #include "numbers.h" @@ -33,3 +35,212 @@ non-negative fixnum will always fit in a 'mp_limb_t'. */ verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1); +#define NLIMBS_MAX (SSIZE_MAX / sizeof(mp_limb_t)) + +#ifndef NDEBUG +#define ASSERT(x) \ + do { \ + if (!(x)) \ + { \ + fprintf (stderr, "%s:%d: assertion failed\n", __FILE__, __LINE__); \ + abort(); \ + } \ + } while (0) +#else +#define ASSERT(x) do { } while (0) +#endif + +struct scm_bignum +{ + scm_t_bits tag; + /* FIXME: In Guile 3.2, replace this union with just a "size" member. + Digits are always allocated inline. */ + union { + mpz_t mpz; + struct { + int zero; + int size; + mp_limb_t *limbs; + } z; + } u; + mp_limb_t limbs[]; +}; + +static inline struct scm_bignum * +scm_bignum (SCM x) +{ + ASSERT (SCM_BIGP (x)); + return (struct scm_bignum *) SCM_UNPACK (x); +} + +static int +bignum_size (struct scm_bignum *z) +{ + return z->u.z.size; +} + +static int +bignum_is_negative (struct scm_bignum *z) +{ + return bignum_size (z) < 0; +} + +static size_t +bignum_limb_count (struct scm_bignum *z) +{ + return bignum_is_negative (z) ? -bignum_size (z) : bignum_size (z); +} + +static mp_limb_t* +bignum_limbs (struct scm_bignum *z) +{ + // FIXME: In the future we can just return z->limbs. + return z->u.z.limbs; +} + +static inline unsigned long +long_magnitude (long l) +{ + unsigned long mag = l; + return l < 0 ? ~mag + 1 : mag; +} + +static inline long +negative_long (unsigned long mag) +{ + ASSERT (mag <= (unsigned long) LONG_MIN); + return ~mag + 1; +} + +static inline scm_t_bits +inum_magnitude (scm_t_inum i) +{ + scm_t_bits mag = i; + if (i < 0) + mag = ~mag + 1; + return mag; +} + +static struct scm_bignum * +allocate_bignum (size_t nlimbs) +{ + ASSERT (nlimbs <= (size_t)INT_MAX); + ASSERT (nlimbs <= NLIMBS_MAX); + + size_t size = sizeof (struct scm_bignum) + nlimbs * sizeof(mp_limb_t); + struct scm_bignum *z = scm_gc_malloc_pointerless (size, "bignum"); + + z->tag = scm_tc16_big; + + z->u.z.zero = 0; + z->u.z.size = nlimbs; + z->u.z.limbs = z->limbs; + + // _mp_alloc == 0 means GMP will never try to free this memory. + ASSERT (z->u.mpz[0]._mp_alloc == 0); + // Our "size" field should alias the mpz's _mp_size field. + ASSERT (z->u.mpz[0]._mp_size == nlimbs); + // Limbs are always allocated inline. + ASSERT (z->u.mpz[0]._mp_d == z->limbs); + + // z->limbs left uninitialized. + return z; +} + +static struct scm_bignum * +negate_bignum (struct scm_bignum *z) +{ + z->u.z.size = -z->u.z.size; + return z; +} + +static SCM +make_bignum_1 (int is_negative, mp_limb_t limb) +{ + struct scm_bignum *z = allocate_bignum (1); + z->limbs[0] = limb; + return SCM_PACK (is_negative ? negate_bignum(z) : z); +} + +static SCM +ulong_to_bignum (unsigned long u) +{ + ASSERT (!SCM_POSFIXABLE (u)); + return make_bignum_1 (0, u); +}; + +static SCM +long_to_bignum (long i) +{ + if (i > 0) + return ulong_to_bignum (i); + + ASSERT (!SCM_NEGFIXABLE (i)); + return make_bignum_1 (1, long_magnitude (i)); +}; + +static SCM +inum_to_bignum (scm_t_inum i) +{ + return long_to_bignum (i); +}; + +static struct scm_bignum * +clone_bignum (struct scm_bignum *z) +{ + struct scm_bignum *ret = allocate_bignum (bignum_limb_count (z)); + mpn_copyi (bignum_limbs (ret), bignum_limbs (z), bignum_limb_count (z)); + return bignum_is_negative (z) ? negate_bignum (ret) : ret; +} + +static void +alias_bignum_to_mpz (struct scm_bignum *z, mpz_ptr mpz) +{ + // No need to clear this mpz. + mpz->_mp_alloc = 0; + mpz->_mp_size = bignum_size (z); + // Gotta be careful to keep z alive. + mpz->_mp_d = bignum_limbs (z); +} + +static struct scm_bignum * +make_bignum_from_mpz (mpz_srcptr mpz) +{ + size_t nlimbs = mpz_size (mpz); + struct scm_bignum *ret = allocate_bignum (nlimbs); + mpn_copyi (bignum_limbs (ret), mpz_limbs_read (mpz), nlimbs); + return mpz_sgn (mpz) < 0 ? negate_bignum (ret) : ret; +} + +static SCM +normalize_bignum (struct scm_bignum *z) +{ + switch (bignum_size (z)) + { + case -1: + if (bignum_limbs (z)[0] <= inum_magnitude (SCM_MOST_NEGATIVE_FIXNUM)) + return SCM_I_MAKINUM (negative_long (bignum_limbs (z)[0])); + break; + case 0: + return SCM_INUM0; + case 1: + if (bignum_limbs (z)[0] <= SCM_MOST_POSITIVE_FIXNUM) + return SCM_I_MAKINUM (bignum_limbs (z)[0]); + break; + default: + break; + } + return SCM_PACK (z); +} + +int +scm_is_integer_odd_i (scm_t_inum i) +{ + return i & 1; +} + +int +scm_is_integer_odd_z (SCM z) +{ + return bignum_limbs (scm_bignum (z))[0] & 1; +} diff --git a/libguile/integers.h b/libguile/integers.h index ac0a0f325..2bd937669 100644 --- a/libguile/integers.h +++ b/libguile/integers.h @@ -21,7 +21,10 @@ -/* Contents go here. */ +#include "libguile/numbers.h" + +SCM_INTERNAL int scm_is_integer_odd_i (scm_t_inum i); +SCM_INTERNAL int scm_is_integer_odd_z (SCM z); diff --git a/libguile/numbers.c b/libguile/numbers.c index bc0fe282d..a91d5963d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -65,6 +65,7 @@ #include "finalizers.h" #include "goops.h" #include "gsubr.h" +#include "integers.h" #include "modules.h" #include "pairs.h" #include "ports.h" @@ -741,16 +742,9 @@ SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0, #define FUNC_NAME s_scm_odd_p { if (SCM_I_INUMP (n)) - { - scm_t_inum val = SCM_I_INUM (n); - return scm_from_bool ((val & 1L) != 0); - } + return scm_from_bool (scm_is_integer_odd_i (SCM_I_INUM (n))); else if (SCM_BIGP (n)) - { - int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - return scm_from_bool (odd_p); - } + return scm_from_bool (scm_is_integer_odd_z (n)); else if (SCM_REALP (n)) { double val = SCM_REAL_VALUE (n); @@ -775,16 +769,9 @@ SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0, #define FUNC_NAME s_scm_even_p { if (SCM_I_INUMP (n)) - { - scm_t_inum val = SCM_I_INUM (n); - return scm_from_bool ((val & 1L) == 0); - } + return scm_from_bool (!scm_is_integer_odd_i (SCM_I_INUM (n))); else if (SCM_BIGP (n)) - { - int even_p = mpz_even_p (SCM_I_BIG_MPZ (n)); - scm_remember_upto_here_1 (n); - return scm_from_bool (even_p); - } + return scm_from_bool (!scm_is_integer_odd_z (n)); else if (SCM_REALP (n)) { double val = SCM_REAL_VALUE (n); |