diff --git a/libguile/integers.c b/libguile/integers.c index 1d2254745..5653fa8d2 100644 --- a/libguile/integers.c +++ b/libguile/integers.c @@ -812,3 +812,65 @@ scm_integer_ceiling_divide_zz (SCM x, SCM y, SCM *qp, SCM *rp) *qp = take_mpz (q); *rp = take_mpz (r); } + +SCM +scm_integer_truncate_quotient_ii (scm_t_inum x, scm_t_inum y) +{ + if (y == 0) + scm_num_overflow ("truncate-quotient"); + else + { + scm_t_inum q = x / y; + return long_to_scm (q); + } +} + +SCM +scm_integer_truncate_quotient_iz (scm_t_inum x, SCM y) +{ + 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; +} + +SCM +scm_integer_truncate_quotient_zi (SCM x, scm_t_inum y) +{ + if (y == 0) + scm_num_overflow ("truncate-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_tdiv_q_ui (q, zx, y); + else + { + mpz_tdiv_q_ui (q, zx, -y); + mpz_neg (q, q); + } + scm_remember_upto_here_1 (x); + return take_mpz (q); + } +} + +SCM +scm_integer_truncate_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_tdiv_q (q, zx, zy); + scm_remember_upto_here_2 (x, y); + return take_mpz (q); +} diff --git a/libguile/integers.h b/libguile/integers.h index 331f4aec6..9707444f7 100644 --- a/libguile/integers.h +++ b/libguile/integers.h @@ -67,6 +67,11 @@ SCM_INTERNAL void scm_integer_ceiling_divide_zi (SCM x, scm_t_inum y, SCM_INTERNAL void scm_integer_ceiling_divide_zz (SCM x, SCM y, SCM *qp, SCM *rp); +SCM_INTERNAL SCM scm_integer_truncate_quotient_ii (scm_t_inum x, scm_t_inum y); +SCM_INTERNAL SCM scm_integer_truncate_quotient_iz (scm_t_inum x, SCM y); +SCM_INTERNAL SCM scm_integer_truncate_quotient_zi (SCM x, scm_t_inum y); +SCM_INTERNAL SCM scm_integer_truncate_quotient_zz (SCM x, SCM y); + #endif /* SCM_INTEGERS_H */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 2e73bac1d..7abc727d7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1815,38 +1815,16 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_truncate_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_truncate_quotient); - else - { - scm_t_inum qq = xx / 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_truncate_quotient_ii (SCM_I_INUM (x), + SCM_I_INUM (y)); else if (SCM_BIGP (y)) - { - 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; - } + return scm_integer_truncate_quotient_iz (SCM_I_INUM (x), y); else if (SCM_REALP (y)) - return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y)); + return scm_i_inexact_truncate_quotient (SCM_I_INUM (x), + SCM_REAL_VALUE (y)); else if (SCM_FRACTIONP (y)) return scm_i_exact_rational_truncate_quotient (x, y); else @@ -1855,36 +1833,10 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-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_truncate_quotient); - else if (SCM_UNLIKELY (yy == 1)) - return x; - else - { - SCM q = scm_i_mkbig (); - if (yy > 0) - mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy); - else - { - mpz_tdiv_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_truncate_quotient_zi (x, SCM_I_INUM (y)); else if (SCM_BIGP (y)) - { - SCM q = scm_i_mkbig (); - mpz_tdiv_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_truncate_quotient_zz (x, y); else if (SCM_REALP (y)) return scm_i_inexact_truncate_quotient (scm_i_big2dbl (x), SCM_REAL_VALUE (y));