mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Implement floor-quotient with new integer lib

Browse source 
* libguile/integers.c (scm_integer_floor_quotient_ii)
(scm_integer_floor_quotient_iz, scm_integer_floor_quotient_zi)
(scm_integer_floor_quotient_zz): New internal functions.
(long_to_scm, ulong_to_scm, take_bignum_from_mpz): New helpers.
* libguile/integers.h: Declare internal functions.
* libguile/numbers.c (scm_floor_quotient): Use the new functions.
This commit is contained in:
Andy Wingo 2021-12-03 22:34:09 +01:00
parent 44c654aa3e
commit 31da9be6c4
3 changed files with 92 additions and 67 deletions
Download patch file Download diff file Expand all files Collapse all files

86
libguile/integers.c
View file

@ -180,10 +180,20 @@ long_to_bignum (long i)
};
static SCM
inum_to_bignum (scm_t_inum i)
long_to_scm (long i)
{
if (SCM_FIXABLE (i))
return SCM_I_MAKINUM (i);
return long_to_bignum (i);
};
}
static SCM
ulong_to_scm (unsigned long i)
{
if (SCM_POSFIXABLE (i))
return SCM_I_MAKINUM (i);
return ulong_to_bignum (i);
}
static struct scm_bignum *
clone_bignum (struct scm_bignum *z)
@ -212,6 +222,14 @@ 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,11 +269,7 @@ scm_integer_abs_i (scm_t_inum i)
if (i >= 0)
return SCM_I_MAKINUM (i);
unsigned long abs = long_magnitude (i);
if (SCM_LIKELY (SCM_POSFIXABLE (abs)))
return SCM_I_MAKINUM (abs);
return ulong_to_bignum (abs);
return ulong_to_scm (long_magnitude (i));
}
SCM
@ -266,3 +280,61 @@ scm_integer_abs_z (SCM z)
return SCM_PACK (negate_bignum (clone_bignum (scm_bignum (z))));
}
SCM
scm_integer_floor_quotient_ii (scm_t_inum x, scm_t_inum y)
{
if (y > 0)
{
if (x < 0)
x = x - y + 1;
}
else if (y == 0)
scm_num_overflow ("floor-quotient");
else if (x > 0)
x = x - y - 1;
scm_t_inum q = x / y;
return long_to_scm (q);
}
SCM
scm_integer_floor_quotient_iz (scm_t_inum x, SCM y)
{
if (x == 0 || ((x < 0) == bignum_is_negative (scm_bignum (y))))
return SCM_INUM0;
return SCM_I_MAKINUM (-1);
}
SCM
scm_integer_floor_quotient_zi (SCM x, scm_t_inum y)
{
if (y == 0)
scm_num_overflow ("floor-quotient");
else if (y == 1)
return x;
mpz_t zx, q;
alias_bignum_to_mpz (scm_bignum (x), zx);
mpz_init (q);
if (y > 0)
mpz_fdiv_q_ui (q, zx, y);
else
{
mpz_cdiv_q_ui (q, zx, -y);
mpz_neg (q, q);
}
scm_remember_upto_here_1 (x);
return SCM_PACK (normalize_bignum (take_bignum_from_mpz (q)));
}
SCM
scm_integer_floor_quotient_zz (SCM x, SCM y)
{
mpz_t zx, zy, q;
alias_bignum_to_mpz (scm_bignum (x), zx);
alias_bignum_to_mpz (scm_bignum (y), zy);
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)));
}

5
libguile/integers.h
View file

@ -29,6 +29,11 @@ SCM_INTERNAL int scm_is_integer_odd_z (SCM z);
SCM_INTERNAL SCM scm_integer_abs_i (scm_t_inum i);
SCM_INTERNAL SCM scm_integer_abs_z (SCM z);
SCM_INTERNAL SCM scm_integer_floor_quotient_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_floor_quotient_iz (scm_t_inum x, SCM y);
SCM_INTERNAL SCM scm_integer_floor_quotient_zi (SCM x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_floor_quotient_zz (SCM x, SCM y);
#endif /* SCM_INTEGERS_H */

68
libguile/numbers.c
View file

@ -1200,40 +1200,14 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_floor_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);
scm_t_inum xx1 = xx;
scm_t_inum qq;
if (SCM_LIKELY (yy > 0))
{
if (SCM_UNLIKELY (xx < 0))
xx1 = xx - yy + 1;
}
else if (SCM_UNLIKELY (yy == 0))
scm_num_overflow (s_scm_floor_quotient);
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_floor_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 (sign > 0)
return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
else
return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
}
return scm_integer_floor_quotient_iz (SCM_I_INUM (x), y);
else if (SCM_REALP (y))
return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
return scm_i_inexact_floor_quotient (SCM_I_INUM (x), SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
@ -1242,36 +1216,10 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-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_floor_quotient);
else if (SCM_UNLIKELY (yy == 1))
return x;
else
{
SCM q = scm_i_mkbig ();
if (yy > 0)
mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
else
{
mpz_cdiv_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_floor_quotient_zi (x, SCM_I_INUM (y));
else if (SCM_BIGP (y))
{
SCM q = scm_i_mkbig ();
mpz_fdiv_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_floor_quotient_zz (x, y);
else if (SCM_REALP (y))
return scm_i_inexact_floor_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y));