Make EQV? distinguish signed flonum zeros.

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 7fbed21826180ceb20f31e9d3d6075baef8e1a0e..5a01bd1fe81153aa7da1e3b3ebd9740275c4022b 100644 (file)
--- 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))))
 \f
 (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))))
+\f
 (define (complex:= z1 z2)
   (if (recnum? z1)
       (if (recnum? z2)

diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index a94ff281307871e2120251b7fd33c41655109c72..91793df7258600a1de361f9bf0e1a2ec8c0e476c 100644 (file)
--- 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 b3321f24654aeddc532c84063c60e7d4c4234dd8..394407e62a8647b58a3c716148982468057c8340 100644 (file)
--- 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 61428f1b7746d0fa216333fc393bc56d09f74d6c..f9118acbf5edb54a6a67ddba1a3286ffbf0b2aec 100644 (file)
--- 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)