[Guile-commits] 37/85: Reimplement = on integer lib, clean up scm_num_eq_p

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 44bee085122262cbcbf2f7fae9aa38841bd2c10b
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Jan 4 12:01:56 2022 +0100

    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 <config.h>
 #endif
 
+#include <math.h>
 #include <stdlib.h>
 #include <stdio.h>
 #include <string.h>
@@ -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)
-            return SCM_BOOL_F;
-          xx = SCM_COMPLEX_REAL (x);
-          if (isnan (xx) || isinf (xx))
+          if (SCM_COMPLEX_IMAG (x) != 0.0
+              || isnan (SCM_COMPLEX_REAL (x))
+              || isinf (SCM_COMPLEX_REAL (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_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,