From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 18 Nov 2018 03:26:52 +0000 (+0000)
Subject: (<= x y) is not (not (> x y)) in the presence of NaN.
X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~42
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=120408e9d2b940140b6610f1970a20af40c69382;p=mit-scheme.git

(<= x y) is not (not (> x y)) in the presence of NaN.
---

diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm
index 77a53f280..d8e0b5faa 100644
--- a/src/runtime/arith.scm
+++ b/src/runtime/arith.scm
@@ -237,13 +237,16 @@ USA.
 	(sc-macro-transformer
 	 (lambda (form environment)
 	   (let ((name (list-ref form 1))
-		 (type (list-ref form 4)))
+		 (comp (list-ref form 2))
+		 (prim (list-ref form 3))
+		 (type (list-ref form 4))
+		 (borked? (list-ref form 5)))
 	     `(set! ,(close-syntax name environment)
 		    (make-arity-dispatched-procedure
 		     (named-lambda (,name self . zs)
 		       self		; ignored
 		       (reduce-comparator
-			,(close-syntax (list-ref form 2) environment)
+			,(close-syntax comp environment)
 			zs ',name))
 		     (named-lambda (,(symbol 'nullary- name)) #t)
 		     (named-lambda (,(symbol 'unary- name) z)
@@ -253,16 +256,16 @@ USA.
 			    z ,(string-append type " number") ',name))
 		       #t)
 		     (named-lambda (,(symbol 'binary- name) z1 z2)
-		       ,(let ((p
-			       `((ucode-primitive ,(list-ref form 3)) z1 z2)))
-			  (if (list-ref form 5)
-			      `(not ,p)
-			      p))))))))))
+		       (,(if borked?
+			     (close-syntax comp environment)
+			     `(ucode-primitive ,prim))
+			z1
+			z2)))))))))
     (relational = complex:= &= "complex" #f)
     (relational < complex:< &< "real" #f)
     (relational > complex:> &> "real" #f)
-    (relational <= (lambda (x y) (not (complex:< y x))) &> "real" #t)
-    (relational >= (lambda (x y) (not (complex:< x y))) &< "real" #t))
+    (relational <= complex:<= &> "real" #t)
+    (relational >= complex:>= &< "real" #t))
 
   (let-syntax
       ((max/min
@@ -285,6 +288,18 @@ USA.
     (max/min min complex:min))
 
   unspecific)
+
+(define (complex:<= x y)
+  ;; XXX Should use a generic trampoline for this.
+  (and (not (and (flo:flonum? x) (flo:nan? x)))
+       (not (and (flo:flonum? y) (flo:nan? y)))
+       (not (complex:> x y))))
+
+(define (complex:>= x y)
+  ;; XXX Should use a generic trampoline for this.
+  (and (not (and (flo:flonum? x) (flo:nan? x)))
+       (not (and (flo:flonum? y) (flo:nan? y)))
+       (not (complex:< x y))))
 
 (define (int:max n m)
   (if (int:< n m) m n))
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index cc9ac8bdd..e062d8def 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -135,14 +135,14 @@ USA.
     (let ((id identity-procedure))
       (assert-false (= x (flo:nan.0)))
       (assert-false (< x (flo:nan.0)))
-      (expect-failure (lambda () (assert-false ((id >=) x (flo:nan.0)))))
+      (assert-false ((id >=) x (flo:nan.0)))
       (assert-false (> x (flo:nan.0)))
-      (expect-failure (lambda () (assert-false ((id <=) x (flo:nan.0)))))
+      (assert-false ((id <=) x (flo:nan.0)))
       (assert-false (= (flo:nan.0) x))
       (assert-false (< (flo:nan.0) x))
-      (expect-failure (lambda () (assert-false ((id >=) (flo:nan.0) x))))
+      (assert-false ((id >=) (flo:nan.0) x))
       (assert-false (> (flo:nan.0) x))
-      (expect-failure (lambda () (assert-false ((id <=) (flo:nan.0) x)))))))
+      (assert-false ((id <=) (flo:nan.0) x)))))
 
 (define-enumerated-test 'inf*0-exact
   (vector (list 0 (flo:+inf.0))