From: Taylor R Campbell <campbell@mumble.net>
Date: Tue, 4 Jun 2013 17:18:11 +0000 (+0000)
Subject: Make EQV? distinguish signed flonum zeros.
X-Git-Tag: release-9.2.0~162
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f185d6c9596792181dbb3f508a84b793ef2b18f2;p=mit-scheme.git

Make EQV? distinguish signed flonum zeros.
---

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 7fbed2182..5a01bd1fe 100644
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -1058,6 +1058,14 @@ USA.
 	     x
 	     (flo:/ (rat:->inexact x) y)))
 	(else ((copy rat:/) x y))))
+
+(define (real:eqv? x y)
+  (if (flonum? x)
+      (and (flonum? y)
+	   (flo:eqv? x y))
+      (and (not (flonum? y))
+	   ;; Both are exact, so RAT:= will DTRT.
+	   ((copy rat:=) x y))))
 
 (define (real:= x y)
   (if (flonum? x)
@@ -1335,6 +1343,18 @@ USA.
       (error:wrong-type-argument x #f name))
   (rec:real-part x))
 
+(define (complex:eqv? z1 z2)
+  (if (recnum? z1)
+      (if (recnum? z2)
+	  (and (real:eqv? (rec:real-part z1) (rec:real-part z2))
+	       (real:eqv? (rec:imag-part z1) (rec:imag-part z2)))
+	  (and (real:exact0= (rec:imag-part z1))
+	       (real:eqv? (rec:real-part z1) z2)))
+      (if (recnum? z2)
+	  (and (real:exact0= (rec:imag-part z2))
+	       (real:eqv? z1 (rec:imag-part z2)))
+	  ((copy real:eqv?) z1 z2))))
+
 (define (complex:= z1 z2)
   (if (recnum? z1)
       (if (recnum? z2)
diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index a94ff2813..91793df72 100644
--- a/src/runtime/equals.scm
+++ b/src/runtime/equals.scm
@@ -37,15 +37,13 @@ USA.
       (if (object-type? (object-type x) y)
 	  (and (not (fix:fixnum? x))
 	       (if (number? y)
-		   (and (= x y)
-			(boolean=? (exact? x) (exact? y)))
+		   (number:eqv? x y)
 		   (and (object-type? (ucode-type vector) y)
 			(fix:zero? (vector-length x))
 			(fix:zero? (vector-length y)))))
 	  (and (number? x)
 	       (number? y)
-	       (= x y)
-	       (boolean=? (exact? x) (exact? y))))))
+	       (number:eqv? x y)))))
 
 (define (equal? x y)
   (or (eq? x y)
@@ -64,8 +62,7 @@ USA.
 		((string? y)
 		 (string=? x y))
 		((number? y)
-		 (and (= x y)
-		      (boolean=? (exact? x) (exact? y))))
+		 (number:eqv? x y))
 		((cell? y)
 		 (equal? (cell-contents x) (cell-contents y)))
 		((bit-string? y)
@@ -79,5 +76,4 @@ USA.
 		(else #f))
 	  (and (number? x)
 	       (number? y)
-	       (= x y)
-	       (boolean=? (exact? x) (exact? y))))))
\ No newline at end of file
+	       (number:eqv? x y)))))
\ No newline at end of file
diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index b3321f246..394407e62 100644
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -167,11 +167,23 @@ USA.
 	((flo:= x y) y)
 	(else (error:bad-range-argument (if (flo:finite? x) x y) 'FLO:MAX))))
 
+;;; XXX FLO:FINITE?, FLO:NAN?, FLO:EQV?, &c., are cute, but should be
+;;; replaced by primitives.
+
 (define (flo:finite? x)
   (if (or (flo:> x 1.) (flo:< x -1.))
       (not (flo:= x (flo:/ x 2.)))
       (and (flo:<= x 1.) (flo:>= x -1.))))
 
+(define (flo:eqv? x y)
+  ;; (bit-string=? (flo:->bit-string x) (flo:->bit-string y))
+  (if (flo:= x y)
+      (or (not (flo:zero? x))
+          ;; XXX Kludgey but expedient test for zero sign.
+          (flo:= (flo:atan2 x -1.) (flo:atan2 y -1.)))
+      ;; XXX (and (flo:nan? x) (flo:nan? y) ...)
+      #f))
+
 (define-integrable (int:->flonum n)
   ((ucode-primitive integer->flonum 2) n #b10))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 61428f1b7..f9118acbf 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -227,6 +227,7 @@ USA.
 	  flo:ceiling
 	  flo:ceiling->exact
 	  flo:cos
+	  flo:eqv?
 	  flo:exp
 	  flo:expm1
 	  flo:expt
@@ -2881,6 +2882,7 @@ USA.
 	  (make-polar complex:make-polar)
 	  (make-rectangular complex:make-rectangular)
 	  (negative? complex:negative?)
+	  (number:eqv? complex:eqv?)
 	  (number? complex:complex?)
 	  (numerator complex:numerator)
 	  (numerator->exact complex:numerator->exact)