diff options
author | Andy Wingo <wingo@pobox.com> | 2022-01-04 13:54:12 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2022-01-13 09:37:16 +0100 |
commit | 54d77225236004cbc2d9a00b25db8bc440652e33 (patch) | |
tree | 6beeab5a3bfaaea0f4f418e6c4879d69943504ba /libguile | |
parent | 44bee085122262cbcbf2f7fae9aa38841bd2c10b (diff) | |
download | guile-54d77225236004cbc2d9a00b25db8bc440652e33.tar.gz |
Clean up <, reimplement in terms of integer lib
* 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.
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/integers.c | 91 | ||||
-rw-r--r-- | libguile/integers.h | 10 | ||||
-rw-r--r-- | libguile/numbers.c | 277 |
3 files changed, 200 insertions, 178 deletions
diff --git a/libguile/integers.c b/libguile/integers.c index e47518338..27c33d072 100644 --- a/libguile/integers.c +++ b/libguile/integers.c @@ -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); +} diff --git a/libguile/integers.h b/libguile/integers.h index dca255175..bd9f528b0 100644 --- a/libguile/integers.h +++ b/libguile/integers.h @@ -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 */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 2d9408a1e..6aa944111 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -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 |