mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Clean up <, reimplement in terms of integer lib

Browse source 
* libguile/numbers.c (scm_is_less_than, scm_is_greater_than):
(scm_is_less_than_or_equal, scm_is_greater_than_or_equal): New internal
functions.
(scm_less_p, scm_gr_p, scm_leq_p, scm_geq_p): Use new helpers.  Dispatch
to generics if operands aren't real -- a tightening relative to the
previous check which was just for numbers.
* libguile/integers.h:
* libguile/integers.c (scm_is_integer_less_than_ir):
(scm_is_integer_less_than_ri):
(scm_is_integer_less_than_zz):
(scm_is_integer_less_than_zr):
(scm_is_integer_less_than_rz):
(scm_is_integer_positive_z):
(scm_is_integer_negative_z): New internal functions.
This commit is contained in:
Andy Wingo 2022-01-04 13:54:12 +01:00
parent 44bee08512
commit 54d7722523
3 changed files with 200 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

91
libguile/integers.c
View file

@ -2411,3 +2411,94 @@ scm_is_integer_equal_zc (struct scm_bignum *x, double real, double imag)
{
return imag == 0.0 && scm_is_integer_equal_zr (x, real);
}
int
scm_is_integer_less_than_ir (scm_t_inum x, double y)
{
/* We can safely take the ceiling of y without changing the
result of x<y, given that x is an integer. */
y = ceil (y);
/* In the following comparisons, it's important that the right
hand side always be a power of 2, so that it can be
losslessly converted to a double even on 64-bit
machines. */
if (y >= (double) (SCM_MOST_POSITIVE_FIXNUM+1))
return 1;
else if (!(y > (double) SCM_MOST_NEGATIVE_FIXNUM))
/* The condition above is carefully written to include the
case where y==NaN. */
return 0;
else
/* y is a finite integer that fits in an inum. */
return x < (scm_t_inum) y;
}
int
scm_is_integer_less_than_ri (double x, scm_t_inum y)
{
/* We can safely take the floor of x without changing the
result of x<y, given that y is an integer. */
x = floor (x);
/* In the following comparisons, it's important that the right
hand side always be a power of 2, so that it can be
losslessly converted to a double even on 64-bit
machines. */
if (x < (double) SCM_MOST_NEGATIVE_FIXNUM)
return 1;
else if (!(x < (double) (SCM_MOST_POSITIVE_FIXNUM+1)))
/* The condition above is carefully written to include the
case where x==NaN. */
return 0;
else
/* x is a finite integer that fits in an inum. */
return (scm_t_inum) x < y;
}
int
scm_is_integer_less_than_zz (struct scm_bignum *x, struct scm_bignum *y)
{
mpz_t zx, zy;
alias_bignum_to_mpz (x, zx);
alias_bignum_to_mpz (y, zy);
int cmp = mpz_cmp (zx, zy);
scm_remember_upto_here_2 (x, y);
return cmp < 0;
}
int
scm_is_integer_less_than_zr (struct scm_bignum *x, double y)
{
if (isnan (y))
return 0;
mpz_t zx;
alias_bignum_to_mpz (x, zx);
int cmp = mpz_cmp_d (zx, y);
scm_remember_upto_here_1 (x);
return cmp < 0;
}
int
scm_is_integer_less_than_rz (double x, struct scm_bignum *y)
{
if (isnan (x))
return 0;
mpz_t zy;
alias_bignum_to_mpz (y, zy);
int cmp = mpz_cmp_d (zy, x);
scm_remember_upto_here_1 (y);
return cmp > 0;
}
int
scm_is_integer_positive_z (struct scm_bignum *x)
{
return bignum_is_positive (x);
}
int
scm_is_integer_negative_z (struct scm_bignum *x)
{
return bignum_is_negative (x);
}

10
libguile/integers.h
View file

@ -156,6 +156,16 @@ SCM_INTERNAL int scm_is_integer_equal_zr (struct scm_bignum *x, double y);
SCM_INTERNAL int scm_is_integer_equal_zc (struct scm_bignum *x,
double real, double imag);
SCM_INTERNAL int scm_is_integer_less_than_ir (scm_t_inum x, double y);
SCM_INTERNAL int scm_is_integer_less_than_ri (double x, scm_t_inum y);
SCM_INTERNAL int scm_is_integer_less_than_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL int scm_is_integer_less_than_zr (struct scm_bignum *x, double y);
SCM_INTERNAL int scm_is_integer_less_than_rz (double y, struct scm_bignum *x);
SCM_INTERNAL int scm_is_integer_positive_z (struct scm_bignum *x);
SCM_INTERNAL int scm_is_integer_negative_z (struct scm_bignum *x);
#endif /* SCM_INTEGERS_H */

277
libguile/numbers.c
View file

@ -4729,6 +4729,89 @@ scm_num_eq_p (SCM x, SCM y)
mpq_cmp. flonum/frac compares likewise, but with the slight complication
of the float exponent to take into account. */
static int scm_is_less_than (SCM x, SCM y);
static int scm_is_greater_than (SCM x, SCM y);
static int scm_is_less_than_or_equal (SCM x, SCM y);
static int scm_is_greater_than_or_equal (SCM x, SCM y);
static int
scm_is_less_than (SCM x, SCM y)
{
if (SCM_I_INUMP (x))
{
if (SCM_I_INUMP (y))
return SCM_I_INUM (x) < SCM_I_INUM (y);
else if (SCM_BIGP (y))
return scm_is_integer_positive_z (scm_bignum (y));
else if (SCM_REALP (y))
return scm_is_integer_less_than_ir (SCM_I_INUM (x), SCM_REAL_VALUE (y));
if (!SCM_FRACTIONP (y))
abort ();
/* "x < a/b" becomes "x*b < a" */
return scm_is_less_than (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
}
else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
return scm_is_integer_negative_z (scm_bignum (x));
else if (SCM_BIGP (y))
return scm_is_integer_less_than_zz (scm_bignum (x), scm_bignum (y));
else if (SCM_REALP (y))
return scm_is_integer_less_than_zr (scm_bignum (x), SCM_REAL_VALUE (y));
if (!SCM_FRACTIONP (y))
abort ();
/* "x < a/b" becomes "x*b < a" */
return scm_is_less_than (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
}
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
return scm_is_integer_less_than_ri (SCM_REAL_VALUE (x), SCM_I_INUM (y));
else if (SCM_BIGP (y))
return scm_is_integer_less_than_rz (SCM_REAL_VALUE (x), scm_bignum (y));
else if (SCM_REALP (y))
return SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y);
if (!SCM_FRACTIONP (y))
abort ();
if (isnan (SCM_REAL_VALUE (x)))
return 0;
if (isinf (SCM_REAL_VALUE (x)))
return SCM_REAL_VALUE (x) < 0.0;
return scm_is_less_than (scm_inexact_to_exact (x), y);
}
if (!SCM_FRACTIONP (x))
abort ();
/* "a/b < " becomes "a < y*b" */
return scm_is_less_than (SCM_FRACTION_NUMERATOR (x),
scm_product (y, SCM_FRACTION_DENOMINATOR (x)));
}
static int
scm_is_greater_than (SCM x, SCM y)
{
return scm_is_less_than (y, x);
}
static int
scm_is_less_than_or_equal (SCM x, SCM y)
{
if ((SCM_REALP (x) && isnan (SCM_REAL_VALUE (x)))
|| (SCM_REALP (y) && isnan (SCM_REAL_VALUE (y))))
return 0;
return !scm_is_less_than (y, x);
}
static int
scm_is_greater_than_or_equal (SCM x, SCM y)
{
return scm_is_less_than_or_equal (y, x);
}
SCM_INTERNAL SCM scm_i_num_less_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
(SCM x, SCM y, SCM rest),
@ -4749,171 +4832,17 @@ SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
return scm_less_p (x, y);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_i_num_less_p
SCM
scm_less_p (SCM x, SCM y)
{
again:
if (SCM_I_INUMP (x))
{
scm_t_inum xx = SCM_I_INUM (x);
if (SCM_I_INUMP (y))
{
scm_t_inum yy = SCM_I_INUM (y);
return scm_from_bool (xx < yy);
}
else if (SCM_BIGP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
scm_remember_upto_here_1 (y);
return scm_from_bool (sgn > 0);
}
else if (SCM_REALP (y))
{
/* We can safely take the ceiling of y without changing the
result of x<y, given that x is an integer. */
double yy = ceil (SCM_REAL_VALUE (y));
/* In the following comparisons, it's important that the right
hand side always be a power of 2, so that it can be
losslessly converted to a double even on 64-bit
machines. */
if (yy >= (double) (SCM_MOST_POSITIVE_FIXNUM+1))
return SCM_BOOL_T;
else if (!(yy > (double) SCM_MOST_NEGATIVE_FIXNUM))
/* The condition above is carefully written to include the
case where yy==NaN. */
return SCM_BOOL_F;
else
/* yy is a finite integer that fits in an inum. */
return scm_from_bool (xx < (scm_t_inum) yy);
}
else if (SCM_FRACTIONP (y))
{
/* "x < a/b" becomes "x*b < a" */
int_frac:
x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
y = SCM_FRACTION_NUMERATOR (y);
goto again;
}
else
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
{
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
scm_remember_upto_here_1 (x);
return scm_from_bool (sgn < 0);
}
else if (SCM_BIGP (y))
{
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
scm_remember_upto_here_2 (x, y);
return scm_from_bool (cmp < 0);
}
else if (SCM_REALP (y))
{
int cmp;
if (isnan (SCM_REAL_VALUE (y)))
return SCM_BOOL_F;
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
scm_remember_upto_here_1 (x);
return scm_from_bool (cmp < 0);
}
else if (SCM_FRACTIONP (y))
goto int_frac;
else
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
if (SCM_I_INUMP (y))
{
/* We can safely take the floor of x without changing the
result of x<y, given that y is an integer. */
double xx = floor (SCM_REAL_VALUE (x));
/* In the following comparisons, it's important that the right
hand side always be a power of 2, so that it can be
losslessly converted to a double even on 64-bit
machines. */
if (xx < (double) SCM_MOST_NEGATIVE_FIXNUM)
return SCM_BOOL_T;
else if (!(xx < (double) (SCM_MOST_POSITIVE_FIXNUM+1)))
/* The condition above is carefully written to include the
case where xx==NaN. */
return SCM_BOOL_F;
else
/* xx is a finite integer that fits in an inum. */
return scm_from_bool ((scm_t_inum) xx < SCM_I_INUM (y));
}
else if (SCM_BIGP (y))
{
int cmp;
if (isnan (SCM_REAL_VALUE (x)))
return SCM_BOOL_F;
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
scm_remember_upto_here_1 (y);
return scm_from_bool (cmp > 0);
}
else if (SCM_REALP (y))
return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
else if (SCM_FRACTIONP (y))
{
double xx = SCM_REAL_VALUE (x);
if (isnan (xx))
return SCM_BOOL_F;
if (isinf (xx))
return scm_from_bool (xx < 0.0);
x = scm_inexact_to_exact (x); /* with x as frac or int */
goto again;
}
else
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
if (SCM_I_INUMP (y) || SCM_BIGP (y))
{
/* "a/b < y" becomes "a < y*b" */
y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
x = SCM_FRACTION_NUMERATOR (x);
goto again;
}
else if (SCM_REALP (y))
{
double yy = SCM_REAL_VALUE (y);
if (isnan (yy))
return SCM_BOOL_F;
if (isinf (yy))
return scm_from_bool (0.0 < yy);
y = scm_inexact_to_exact (y); /* with y as frac or int */
goto again;
}
else if (SCM_FRACTIONP (y))
{
/* "a/b < c/d" becomes "a*d < c*b" */
SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (y));
SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
SCM_FRACTION_DENOMINATOR (x));
x = new_x;
y = new_y;
goto again;
}
else
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
s_scm_i_num_less_p);
}
else
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
s_scm_i_num_less_p);
if (!scm_is_real (x))
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, FUNC_NAME);
if (!scm_is_real (y))
return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG2, FUNC_NAME);
return scm_from_bool (scm_is_less_than (x, y));
}
#undef FUNC_NAME
SCM scm_i_num_gr_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
@ -4939,16 +4868,14 @@ SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
SCM
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
if (!scm_is_real (x))
return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
if (!scm_is_real (y))
return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
return scm_from_bool (scm_is_greater_than (x, y));
}
#undef FUNC_NAME
SCM scm_i_num_leq_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
(SCM x, SCM y, SCM rest),
@ -4973,14 +4900,11 @@ SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
SCM
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
if (!scm_is_real (x))
return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
if (!scm_is_real (y))
return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
return scm_not (scm_less_p (y, x));
return scm_from_bool (scm_is_less_than_or_equal (x, y));
}
#undef FUNC_NAME
@ -5009,14 +4933,11 @@ SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
SCM
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
if (!scm_is_real (x))
return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
if (!scm_is_real (y))
return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
return scm_not (scm_less_p (x, y));
return scm_from_bool (scm_is_greater_than_or_equal (x, y));
}
#undef FUNC_NAME