guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 38/85: Clean up <, reimplement in terms of integer lib


From: Andy Wingo
Subject: [Guile-commits] 38/85: Clean up <, reimplement in terms of integer lib
Date: Thu, 13 Jan 2022 03:40:19 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit 54d77225236004cbc2d9a00b25db8bc440652e33
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Jan 4 13:54:12 2022 +0100

    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.
---
 libguile/integers.c |  91 +++++++++++++++++
 libguile/integers.h |  10 ++
 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
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]