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

Implement ceiling-quotient with new integer lib

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2021-12-10 13:38:19 +01:00
parent 8a63537458
commit c1d8dd5e6a
3 changed files with 138 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

143
libguile/integers.c
View file

@ -222,14 +222,6 @@ make_bignum_from_mpz (mpz_srcptr mpz)
return mpz_sgn (mpz) < 0 ? negate_bignum (ret) : ret; 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 static SCM
normalize_bignum (struct scm_bignum *z) normalize_bignum (struct scm_bignum *z)
{ {
@ -251,6 +243,42 @@ normalize_bignum (struct scm_bignum *z)
return SCM_PACK (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 int
scm_is_integer_odd_i (scm_t_inum i) 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); mpz_neg (q, q);
} }
scm_remember_upto_here_1 (x); scm_remember_upto_here_1 (x);
return SCM_PACK (normalize_bignum (take_bignum_from_mpz (q))); return take_bignum_from_mpz (q);
} }
SCM SCM
@ -336,7 +364,7 @@ scm_integer_floor_quotient_zz (SCM x, SCM y)
mpz_init (q); mpz_init (q);
mpz_fdiv_q (q, zx, zy); mpz_fdiv_q (q, zx, zy);
scm_remember_upto_here_2 (x, y); scm_remember_upto_here_2 (x, y);
return SCM_PACK (normalize_bignum (take_bignum_from_mpz (q))); return take_bignum_from_mpz (q);
} }
SCM SCM
@ -363,7 +391,7 @@ scm_integer_floor_remainder_iz (scm_t_inum x, SCM y)
alias_bignum_to_mpz (scm_bignum (y), zy); alias_bignum_to_mpz (scm_bignum (y), zy);
mpz_sub_ui (r, zy, -x); mpz_sub_ui (r, zy, -x);
scm_remember_upto_here_1 (y); scm_remember_upto_here_1 (y);
return SCM_PACK (normalize_bignum (take_bignum_from_mpz (r))); return take_bignum_from_mpz (r);
} }
else else
return SCM_I_MAKINUM (x); 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); alias_bignum_to_mpz (scm_bignum (y), zy);
mpz_add_ui (r, zy, x); mpz_add_ui (r, zy, x);
scm_remember_upto_here_1 (y); 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_init (r);
mpz_fdiv_r (r, zx, zy); mpz_fdiv_r (r, zx, zy);
scm_remember_upto_here_2 (x, y); scm_remember_upto_here_2 (x, y);
return SCM_PACK (normalize_bignum (take_bignum_from_mpz (r))); return take_bignum_from_mpz (r);
} }
void 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); mpz_sub_ui (r, zy, -x);
scm_remember_upto_here_1 (y); scm_remember_upto_here_1 (y);
*qp = SCM_I_MAKINUM (-1); *qp = SCM_I_MAKINUM (-1);
*rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r))); *rp = take_bignum_from_mpz (r);
} }
else 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); mpz_add_ui (r, zy, x);
scm_remember_upto_here_1 (y); scm_remember_upto_here_1 (y);
*qp = SCM_I_MAKINUM (-1); *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); mpz_neg (q, q);
} }
scm_remember_upto_here_1 (x); scm_remember_upto_here_1 (x);
*qp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (q))); *qp = take_bignum_from_mpz (q);
*rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r))); *rp = take_bignum_from_mpz (r);
} }
void 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); alias_bignum_to_mpz (scm_bignum (y), zy);
mpz_fdiv_qr (q, r, zx, zy); mpz_fdiv_qr (q, r, zx, zy);
scm_remember_upto_here_2 (x, y); scm_remember_upto_here_2 (x, y);
*qp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (q))); *qp = take_bignum_from_mpz (q);
*rp = SCM_PACK (normalize_bignum (take_bignum_from_mpz (r))); *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);
} }

5
libguile/integers.h
View file

@ -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_INTERNAL void scm_integer_floor_divide_zz (SCM x, SCM y,
SCM *qp, SCM *rp); 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 */ #endif /* SCM_INTEGERS_H */

87
libguile/numbers.c
View file

@ -1507,58 +1507,15 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_ceiling_quotient #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_I_INUMP (y))
if (SCM_LIKELY (SCM_I_INUMP (y))) return scm_integer_ceiling_quotient_ii (SCM_I_INUM (x), SCM_I_INUM (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);
}
}
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ return scm_integer_ceiling_quotient_iz (SCM_I_INUM (x), 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;
}
else if (SCM_REALP (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)) else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y); return scm_i_exact_rational_ceiling_quotient (x, y);
else else
@ -1567,36 +1524,10 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
} }
else if (SCM_BIGP (x)) else if (SCM_BIGP (x))
{ {
if (SCM_LIKELY (SCM_I_INUMP (y))) if (SCM_I_INUMP (y))
{ return scm_integer_ceiling_quotient_zi (x, SCM_I_INUM (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);
}
}
else if (SCM_BIGP (y)) else if (SCM_BIGP (y))
{ return scm_integer_ceiling_quotient_zz (x, 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);
}
else if (SCM_REALP (y)) else if (SCM_REALP (y))
return scm_i_inexact_ceiling_quotient return scm_i_inexact_ceiling_quotient
(scm_i_big2dbl (x), SCM_REAL_VALUE (y)); (scm_i_big2dbl (x), SCM_REAL_VALUE (y));