diff options
author | Andy Wingo <wingo@pobox.com> | 2021-12-10 13:38:19 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2022-01-13 09:37:16 +0100 |
commit | c1d8dd5e6a2933af468afbe177e4ceebd6b719b2 (patch) | |
tree | e548767ca9157136538f6586337c225b9dc754b1 | |
parent | 8a6353745898a82322c813d289ed433bb7e597c4 (diff) | |
download | guile-c1d8dd5e6a2933af468afbe177e4ceebd6b719b2.tar.gz |
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.
-rw-r--r-- | libguile/integers.c | 143 | ||||
-rw-r--r-- | libguile/integers.h | 5 | ||||
-rw-r--r-- | 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)); |