equal?' and eqv?' are now equivalent for numbers

Change `equal?' to work like `eqv?' for numbers.
Previously they worked differently in some cases, e.g.
when comparing signed zeroes or NaNs.  For example,
(equal? 0.0 -0.0) returned #t but (eqv? 0.0 -0.0)
returned #f, and (equal? +nan.0 +nan.0) returned #f
but (eqv? +nan.0 +nan.0) returned #t.

* libguile/numbers.c (scm_real_equalp, scm_bigequal,
  scm_complex_equalp, scm_i_fraction_equalp): Move to eq.c.

* libguile/eq.c (scm_real_equalp): Compare flonums using
  real_eqv instead of ==, so that NaNs are now considered
  equal, and to distinguish signed zeroes.

  (scm_complex_equalp): Compare real and imaginary
  components using real_eqv instead of ==, so that NaNs are
  now considered equal, and to distinguish signed zeroes.

  (scm_bigequal): Use scm_i_bigcmp instead of duplicating it.

  (real_eqv): Test for NaNs using isnan(x) instead of
  (x != x), and use SCM_UNLIKELY for optimization.

  (scm_eqv_p): Use scm_bigequal, scm_real_equalp,
  scm_complex_equalp, and scm_i_fraction_equalp to compare
  numbers, instead of inline code.  Those predicates now do
  what scm_eqv_p formerly did internally.  Replace if
  statements with switch statements, as is done in
  scm_equal_p.  Remove useless code to check equality of
  fractions with different SCM_CELL_TYPEs; this was for a
  tentative "lazy reduction bit" which was never developed.

  (scm_eqv_p, scm_equal_p): Remove useless code to check
  equality between inexact reals and non-real complex numbers
  with zero imaginary part.  Such numbers do not exist,
  because the current code is careful to never create them.

* test-suite/tests/numbers.test: Add test cases for
  `eqv?' and `equal?'.  Change existing test case for
  `(equal? +nan.0 +nan.0)' to expect #t instead of #f.

* NEWS: Add NEWS entries.

NEWS

@@ -12,6 +12,21 @@ Changes in 1.9.15 (since the 1.9.14 prerelease):
 
 ** Changes and bugfixes in numerics code
 
+*** `eqv?' and `equal?' now compare numbers equivalently
+
+scm_equal_p `equal?' now behaves equivalently to scm_eqv_p `eqv?' for
+numeric values, per R5RS.  Previously, equal? worked differently,
+e.g. `(equal? 0.0 -0.0)' returned #t but `(eqv? 0.0 -0.0)' returned #f,
+and `(equal? +nan.0 +nan.0)' returned #f but `(eqv? +nan.0 +nan.0)'
+returned #t.
+
+*** `(equal? +nan.0 +nan.0)' now returns #t
+
+Previously, `(equal? +nan.0 +nan.0)' returned #f, although
+`(let ((x +nan.0)) (equal? x x))' and `(eqv? +nan.0 +nan.0)'
+both returned #t.  R5RS requires that `equal?' behave like
+`eqv?' when comparing numbers.
+
 *** Infinities are no longer integers.
 
 Following the R6RS, infinities (+inf.0 and -inf.0) are no longer

libguile/eq.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -21,6 +21,8 @@
 #  include <config.h>
 #endif
 
+#include <math.h>
+
 #include "libguile/_scm.h"
 #include "libguile/array-map.h"
 #include "libguile/stackchk.h"
@@ -118,7 +120,40 @@ scm_eq_p (SCM x, SCM y)
 static int
 real_eqv (double x, double y)
 {
-  return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
+  return !memcmp (&x, &y, sizeof(double))
+    || (SCM_UNLIKELY (isnan (x)) && SCM_UNLIKELY (isnan (y)));
+}
+
+SCM
+scm_real_equalp (SCM x, SCM y)
+{
+  return scm_from_bool (real_eqv (SCM_REAL_VALUE (x),
+				  SCM_REAL_VALUE (y)));
+}
+
+SCM
+scm_bigequal (SCM x, SCM y)
+{
+  return scm_from_bool (scm_i_bigcmp (x, y) == 0);
+}
+
+SCM
+scm_complex_equalp (SCM x, SCM y)
+{
+  return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
+				  SCM_COMPLEX_REAL (y))
+			&& real_eqv (SCM_COMPLEX_IMAG (x),
+				     SCM_COMPLEX_IMAG (y)));
+}
+
+SCM
+scm_i_fraction_equalp (SCM x, SCM y)
+{
+  return scm_from_bool
+    (scm_is_true (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
+			       SCM_FRACTION_NUMERATOR (y)))
+     && scm_is_true (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
+				  SCM_FRACTION_DENOMINATOR (y))));
 }
 
 static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
@@ -166,47 +201,25 @@ SCM scm_eqv_p (SCM x, SCM y)
     return SCM_BOOL_F;
   if (SCM_IMP (y))
     return SCM_BOOL_F;
+
   /* this ensures that types and scm_length are the same. */
-
   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
-    {
-      /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
-	 but this checks the entire type word, so fractions may be accidentally
-	 flagged here as unequal.  Perhaps I should use the 4th double_cell word?
-      */
-
-      /* treat mixes of real and complex types specially */
-      if (SCM_INEXACTP (x))
-	{
-	  if (SCM_REALP (x))
-	    return scm_from_bool (SCM_COMPLEXP (y)
-			     && real_eqv (SCM_REAL_VALUE (x),
-					  SCM_COMPLEX_REAL (y))
-			     && SCM_COMPLEX_IMAG (y) == 0.0);
-	  else
-	    return scm_from_bool (SCM_REALP (y)
-			     && real_eqv (SCM_COMPLEX_REAL (x),
-					  SCM_REAL_VALUE (y))
-			     && SCM_COMPLEX_IMAG (x) == 0.0);
-	}
-
-      if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
-	return scm_i_fraction_equalp (x, y);
     return SCM_BOOL_F;
-    }
+  switch (SCM_TYP7 (x))
-  if (SCM_NUMP (x))
     {
-      if (SCM_BIGP (x)) {
+    default:
-	return scm_from_bool (scm_i_bigcmp (x, y) == 0);
+      break;
-      } else if (SCM_REALP (x)) {
+    case scm_tc7_number:
-	return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
+      switch SCM_TYP16 (x)
-      } else if (SCM_FRACTIONP (x)) {
+        {
+        case scm_tc16_big:
+          return scm_bigequal (x, y);
+        case scm_tc16_real:
+          return scm_real_equalp (x, y);
+        case scm_tc16_complex:
+          return scm_complex_equalp (x, y);
+	case scm_tc16_fraction:
           return scm_i_fraction_equalp (x, y);
-      } else { /* complex */
-	return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
-				   SCM_COMPLEX_REAL (y)) 
-			 && real_eqv (SCM_COMPLEX_IMAG (x),
-				      SCM_COMPLEX_IMAG (y)));
         }
     }
   return SCM_BOOL_F;
@@ -309,19 +322,6 @@ scm_equal_p (SCM x, SCM y)
   /* This ensures that types and scm_length are the same.  */
   if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
     {
-      /* treat mixes of real and complex types specially */
-      if (SCM_INEXACTP (x) && SCM_INEXACTP (y))
-	{
-	  if (SCM_REALP (x))
-	    return scm_from_bool (SCM_COMPLEXP (y)
-			     && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
-			     && SCM_COMPLEX_IMAG (y) == 0.0);
-	  else
-	    return scm_from_bool (SCM_REALP (y)
-			     && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
-			     && SCM_COMPLEX_IMAG (x) == 0.0);
-	}
-
       /* Vectors can be equal to one-dimensional arrays.
        */
       if (scm_is_array (x) && scm_is_array (y))

libguile/numbers.c

@@ -3249,40 +3249,6 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
 /*** END strs->nums ***/
 
 
-SCM
-scm_bigequal (SCM x, SCM y)
-{
-  int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
-  scm_remember_upto_here_2 (x, y);
-  return scm_from_bool (0 == result);
-}
-
-SCM
-scm_real_equalp (SCM x, SCM y)
-{
-  return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
-}
-
-SCM
-scm_complex_equalp (SCM x, SCM y)
-{
-  return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
-		   && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
-}
-
-SCM
-scm_i_fraction_equalp (SCM x, SCM y)
-{
-  if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
-			       SCM_FRACTION_NUMERATOR (y)))
-      || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
-				  SCM_FRACTION_DENOMINATOR (y))))
-    return SCM_BOOL_F;
-  else
-    return SCM_BOOL_T;
-}
-
-
 SCM_DEFINE (scm_number_p, "number?", 1, 0, 0, 
             (SCM x),
 	    "Return @code{#t} if @var{x} is a number, @code{#f}\n"

test-suite/tests/numbers.test

@@ -1605,12 +1605,24 @@
 
 (with-test-prefix "equal?"
   (pass-if (documented? equal?))
+
+  ;; The following test will fail on platforms
+  ;; without distinct signed zeroes 0.0 and -0.0.
+  (pass-if (not (equal? 0.0 -0.0)))
+
   (pass-if (equal? 0 0))
   (pass-if (equal? 7 7))
   (pass-if (equal? -7 -7))
   (pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max)))
   (pass-if (equal? (- fixnum-min 1) (- fixnum-min 1)))
+  (pass-if (equal?  0.0  0.0))
+  (pass-if (equal? -0.0 -0.0))
   (pass-if (not (equal? 0 1)))
+  (pass-if (not (equal? 0 0.0)))
+  (pass-if (not (equal? 1 1.0)))
+  (pass-if (not (equal? 0.0 0)))
+  (pass-if (not (equal? 1.0 1)))
+  (pass-if (not (equal? -1.0 -1)))
   (pass-if (not (equal? fixnum-max (+ 1 fixnum-max))))
   (pass-if (not (equal? (+ 1 fixnum-max) fixnum-max)))
   (pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max))))
@@ -1631,7 +1643,10 @@
   (pass-if (not (equal? (- (ash 1 1024)) -inf.0)))
   (pass-if (not (equal? -inf.0 (- (ash 1 1024)))))
 
-  (pass-if (not (equal? +nan.0 +nan.0)))
+  (pass-if (equal? +nan.0 +nan.0))
+  (pass-if (equal? +nan.0 +nan.0))
+  (pass-if (not (equal? +nan.0 0.0+nan.0i)))
+
   (pass-if (not (equal? 0 +nan.0)))
   (pass-if (not (equal? +nan.0 0)))
   (pass-if (not (equal? 1 +nan.0)))
@@ -1654,6 +1669,75 @@
   (pass-if (not (equal? (ash 3 1023) +nan.0)))
   (pass-if (not (equal? +nan.0 (ash 3 1023)))))
 
+;;;
+;;; eqv?
+;;;
+
+(with-test-prefix "eqv?"
+  (pass-if (documented? eqv?))
+
+  ;; The following test will fail on platforms
+  ;; without distinct signed zeroes 0.0 and -0.0.
+  (pass-if (not (eqv? 0.0 -0.0)))
+
+  (pass-if (eqv? 0 0))
+  (pass-if (eqv? 7 7))
+  (pass-if (eqv? -7 -7))
+  (pass-if (eqv? (+ 1 fixnum-max) (+ 1 fixnum-max)))
+  (pass-if (eqv? (- fixnum-min 1) (- fixnum-min 1)))
+  (pass-if (eqv?  0.0  0.0))
+  (pass-if (eqv? -0.0 -0.0))
+  (pass-if (not (eqv? 0 1)))
+  (pass-if (not (eqv? 0 0.0)))
+  (pass-if (not (eqv? 1 1.0)))
+  (pass-if (not (eqv? 0.0 0)))
+  (pass-if (not (eqv? 1.0 1)))
+  (pass-if (not (eqv? -1.0 -1)))
+  (pass-if (not (eqv? fixnum-max (+ 1 fixnum-max))))
+  (pass-if (not (eqv? (+ 1 fixnum-max) fixnum-max)))
+  (pass-if (not (eqv? (+ 1 fixnum-max) (+ 2 fixnum-max))))
+  (pass-if (not (eqv? fixnum-min (- fixnum-min 1))))
+  (pass-if (not (eqv? (- fixnum-min 1) fixnum-min)))
+  (pass-if (not (eqv? (- fixnum-min 1) (- fixnum-min 2))))
+  (pass-if (not (eqv? (+ fixnum-max 1) (- fixnum-min 1))))
+
+  (pass-if (not (eqv? (ash 1 256) +inf.0)))
+  (pass-if (not (eqv? +inf.0 (ash 1 256))))
+  (pass-if (not (eqv? (ash 1 256) -inf.0)))
+  (pass-if (not (eqv? -inf.0 (ash 1 256))))
+
+  ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+  ;; sure we've avoided that
+  (pass-if (not (eqv? (ash 1 1024) +inf.0)))
+  (pass-if (not (eqv? +inf.0 (ash 1 1024))))
+  (pass-if (not (eqv? (- (ash 1 1024)) -inf.0)))
+  (pass-if (not (eqv? -inf.0 (- (ash 1 1024)))))
+
+  (pass-if (eqv? +nan.0 +nan.0))
+  (pass-if (not (eqv? +nan.0 0.0+nan.0i)))
+
+  (pass-if (not (eqv? 0 +nan.0)))
+  (pass-if (not (eqv? +nan.0 0)))
+  (pass-if (not (eqv? 1 +nan.0)))
+  (pass-if (not (eqv? +nan.0 1)))
+  (pass-if (not (eqv? -1 +nan.0)))
+  (pass-if (not (eqv? +nan.0 -1)))
+
+  (pass-if (not (eqv? (ash 1 256) +nan.0)))
+  (pass-if (not (eqv? +nan.0 (ash 1 256))))
+  (pass-if (not (eqv? (- (ash 1 256)) +nan.0)))
+  (pass-if (not (eqv? +nan.0 (- (ash 1 256)))))
+
+  (pass-if (not (eqv? (ash 1 8192) +nan.0)))
+  (pass-if (not (eqv? +nan.0 (ash 1 8192))))
+  (pass-if (not (eqv? (- (ash 1 8192)) +nan.0)))
+  (pass-if (not (eqv? +nan.0 (- (ash 1 8192)))))
+
+  ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+  ;; sure we've avoided that
+  (pass-if (not (eqv? (ash 3 1023) +nan.0)))
+  (pass-if (not (eqv? +nan.0 (ash 3 1023)))))
+
 ;;;
 ;;; =
 ;;;