From 44bee085122262cbcbf2f7fae9aa38841bd2c10b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 4 Jan 2022 12:01:56 +0100 Subject: [PATCH] Reimplement = on integer lib, clean up scm_num_eq_p * libguile/integers.h: * libguile/integers.c (scm_is_integer_equal_ir): (scm_is_integer_equal_ic): (scm_is_integer_equal_zz): (scm_is_integer_equal_zr): (scm_is_integer_equal_zc): New internal functions. * libguile/numbers.c (scm_num_eq_p): Rework to tail-recurse if we need to swap arguments, to reduce duplication, and use the new integer lib. --- libguile/integers.c | 58 ++++++++++++++ libguile/integers.h | 9 +++ libguile/numbers.c | 186 ++++++++------------------------------------ 3 files changed, 99 insertions(+), 154 deletions(-) diff --git a/libguile/integers.c b/libguile/integers.c index d955ec4bf..e47518338 100644 --- a/libguile/integers.c +++ b/libguile/integers.c @@ -23,6 +23,7 @@ # include #endif +#include #include #include #include @@ -2353,3 +2354,60 @@ scm_integer_to_string_z (struct scm_bignum *n, int base) freefunc (str, len + 1); return ret; } + +int +scm_is_integer_equal_ir (scm_t_inum x, double y) +{ + /* On a 32-bit system an inum fits a double, we can cast the inum + to a double and compare. + + But on a 64-bit system an inum is bigger than a double and casting + it to a double (call that dx) will round. Although dxx will not in + general be equal to x, dx will always be an integer and within a + factor of 2 of x, so if dx==y, we know that y is an integer and + fits in scm_t_signed_bits. So we cast y to scm_t_signed_bits and + compare with plain x. + + An alternative (for any size system actually) would be to check y + is an integer (with floor) and is in range of an inum (compare + against appropriate powers of 2) then test x==(scm_t_inum)y. It's + just a matter of which casts/comparisons might be fastest or + easiest for the cpu. */ + return (double) x == y + && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 || x == (scm_t_inum) y); +} + +int +scm_is_integer_equal_ic (scm_t_inum x, double real, double imag) +{ + return imag == 0.0 && scm_is_integer_equal_ir (x, real); +} + +int +scm_is_integer_equal_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 0 == cmp; +} + +int +scm_is_integer_equal_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 0 == cmp; +} + +int +scm_is_integer_equal_zc (struct scm_bignum *x, double real, double imag) +{ + return imag == 0.0 && scm_is_integer_equal_zr (x, real); +} diff --git a/libguile/integers.h b/libguile/integers.h index 8ac4ca55f..dca255175 100644 --- a/libguile/integers.h +++ b/libguile/integers.h @@ -147,6 +147,15 @@ SCM_INTERNAL SCM scm_integer_length_z (struct scm_bignum *n); SCM_INTERNAL SCM scm_integer_to_string_i (scm_t_inum n, int base); SCM_INTERNAL SCM scm_integer_to_string_z (struct scm_bignum *n, int base); +SCM_INTERNAL int scm_is_integer_equal_ir (scm_t_inum x, double y); +SCM_INTERNAL int scm_is_integer_equal_ic (scm_t_inum x, + double real, double imag); +SCM_INTERNAL int scm_is_integer_equal_zz (struct scm_bignum *x, + struct scm_bignum *y); +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); + #endif /* SCM_INTEGERS_H */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 46f55de58..2d9408a1e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4639,205 +4639,83 @@ SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1, return scm_num_eq_p (x, y); } #undef FUNC_NAME + SCM scm_num_eq_p (SCM x, SCM y) { - again: if (SCM_I_INUMP (x)) { - scm_t_signed_bits xx = SCM_I_INUM (x); if (SCM_I_INUMP (y)) - { - scm_t_signed_bits yy = SCM_I_INUM (y); - return scm_from_bool (xx == yy); - } + return scm_eq_p (x, y); else if (SCM_BIGP (y)) return SCM_BOOL_F; else if (SCM_REALP (y)) - { - /* On a 32-bit system an inum fits a double, we can cast the inum - to a double and compare. - - But on a 64-bit system an inum is bigger than a double and - casting it to a double (call that dxx) will round. - Although dxx will not in general be equal to xx, dxx will - always be an integer and within a factor of 2 of xx, so if - dxx==yy, we know that yy is an integer and fits in - scm_t_signed_bits. So we cast yy to scm_t_signed_bits and - compare with plain xx. - - An alternative (for any size system actually) would be to check - yy is an integer (with floor) and is in range of an inum - (compare against appropriate powers of 2) then test - xx==(scm_t_signed_bits)yy. It's just a matter of which - casts/comparisons might be fastest or easiest for the cpu. */ - - double yy = SCM_REAL_VALUE (y); - return scm_from_bool ((double) xx == yy - && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 - || xx == (scm_t_signed_bits) yy)); - } + return scm_from_bool + (scm_is_integer_equal_ir (SCM_I_INUM (x), SCM_REAL_VALUE (y))); else if (SCM_COMPLEXP (y)) - { - /* see comments with inum/real above */ - double ry = SCM_COMPLEX_REAL (y); - return scm_from_bool ((double) xx == ry - && 0.0 == SCM_COMPLEX_IMAG (y) - && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 - || xx == (scm_t_signed_bits) ry)); - } + return scm_from_bool + (scm_is_integer_equal_ic (SCM_I_INUM (x), SCM_COMPLEX_REAL (y), + SCM_COMPLEX_IMAG (y))); else if (SCM_FRACTIONP (y)) return SCM_BOOL_F; else - return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, - s_scm_i_num_eq_p); + return scm_num_eq_p (y, x); } else if (SCM_BIGP (x)) { - if (SCM_I_INUMP (y)) - return SCM_BOOL_F; - 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 (0 == cmp); - } + if (SCM_BIGP (y)) + return scm_from_bool + (scm_is_integer_equal_zz (scm_bignum (x), scm_bignum (y))); 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 (0 == cmp); - } + return scm_from_bool + (scm_is_integer_equal_zr (scm_bignum (x), SCM_REAL_VALUE (y))); else if (SCM_COMPLEXP (y)) - { - int cmp; - if (0.0 != SCM_COMPLEX_IMAG (y)) - return SCM_BOOL_F; - if (isnan (SCM_COMPLEX_REAL (y))) - return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y)); - scm_remember_upto_here_1 (x); - return scm_from_bool (0 == cmp); - } + return scm_from_bool + (scm_is_integer_equal_zc (scm_bignum (x), SCM_COMPLEX_REAL (y), + SCM_COMPLEX_IMAG (y))); else if (SCM_FRACTIONP (y)) return SCM_BOOL_F; else - return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, - s_scm_i_num_eq_p); + return scm_num_eq_p (y, x); } else if (SCM_REALP (x)) { - double xx = SCM_REAL_VALUE (x); - if (SCM_I_INUMP (y)) - { - /* see comments with inum/real above */ - scm_t_signed_bits yy = SCM_I_INUM (y); - return scm_from_bool (xx == (double) yy - && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 - || (scm_t_signed_bits) xx == yy)); - } - else if (SCM_BIGP (y)) - { - int cmp; - if (isnan (xx)) - return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); - scm_remember_upto_here_1 (y); - return scm_from_bool (0 == cmp); - } - else if (SCM_REALP (y)) - return scm_from_bool (xx == SCM_REAL_VALUE (y)); + if (SCM_REALP (y)) + return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); else if (SCM_COMPLEXP (y)) - return scm_from_bool ((xx == SCM_COMPLEX_REAL (y)) - && (0.0 == SCM_COMPLEX_IMAG (y))); + return scm_from_bool (SCM_COMPLEX_IMAG (y) == 0.0 + && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)); else if (SCM_FRACTIONP (y)) { - if (isnan (xx) || isinf (xx)) + if (isnan (SCM_REAL_VALUE (x)) || isinf (SCM_REAL_VALUE (x))) return SCM_BOOL_F; - x = scm_inexact_to_exact (x); /* with x as frac or int */ - goto again; + return scm_num_eq_p (scm_inexact_to_exact (x), y); } else - return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, - s_scm_i_num_eq_p); + return scm_num_eq_p (y, x); } else if (SCM_COMPLEXP (x)) { - if (SCM_I_INUMP (y)) - { - /* see comments with inum/real above */ - double rx = SCM_COMPLEX_REAL (x); - scm_t_signed_bits yy = SCM_I_INUM (y); - return scm_from_bool (rx == (double) yy - && 0.0 == SCM_COMPLEX_IMAG (x) - && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1 - || (scm_t_signed_bits) rx == yy)); - } - else if (SCM_BIGP (y)) - { - int cmp; - if (0.0 != SCM_COMPLEX_IMAG (x)) - return SCM_BOOL_F; - if (isnan (SCM_COMPLEX_REAL (x))) - return SCM_BOOL_F; - cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x)); - scm_remember_upto_here_1 (y); - return scm_from_bool (0 == cmp); - } - else if (SCM_REALP (y)) - return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) - && (SCM_COMPLEX_IMAG (x) == 0.0)); - else if (SCM_COMPLEXP (y)) + if (SCM_COMPLEXP (y)) return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); else if (SCM_FRACTIONP (y)) { - double xx; - if (SCM_COMPLEX_IMAG (x) != 0.0) + if (SCM_COMPLEX_IMAG (x) != 0.0 + || isnan (SCM_COMPLEX_REAL (x)) + || isinf (SCM_COMPLEX_REAL (x))) return SCM_BOOL_F; - xx = SCM_COMPLEX_REAL (x); - if (isnan (xx) || isinf (xx)) - return SCM_BOOL_F; - x = scm_inexact_to_exact (x); /* with x as frac or int */ - goto again; + return scm_num_eq_p (scm_inexact_to_exact (x), y); } else - return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, - s_scm_i_num_eq_p); + return scm_num_eq_p (y, x); } else if (SCM_FRACTIONP (x)) { - if (SCM_I_INUMP (y)) - return SCM_BOOL_F; - else if (SCM_BIGP (y)) - return SCM_BOOL_F; - else if (SCM_REALP (y)) - { - double yy = SCM_REAL_VALUE (y); - if (isnan (yy) || isinf (yy)) - return SCM_BOOL_F; - y = scm_inexact_to_exact (y); /* with y as frac or int */ - goto again; - } - else if (SCM_COMPLEXP (y)) - { - double yy; - if (SCM_COMPLEX_IMAG (y) != 0.0) - return SCM_BOOL_F; - yy = SCM_COMPLEX_REAL (y); - if (isnan (yy) || isinf(yy)) - return SCM_BOOL_F; - y = scm_inexact_to_exact (y); /* with y as frac or int */ - goto again; - } - else if (SCM_FRACTIONP (y)) + if (SCM_FRACTIONP (y)) return scm_i_fraction_equalp (x, y); else - return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, - s_scm_i_num_eq_p); + return scm_num_eq_p (y, x); } else return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,