From aa5d1efca83528869a6ce48ca085cf37cee39a53 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 15 Dec 2018 03:48:26 +0000
Subject: [PATCH] Test ordered and unordered comparisons with sNaN raise
 exceptions.

---
 tests/runtime/test-flonum.scm | 63 +++++++++++++++++++++++++++++++++--
 1 file changed, 61 insertions(+), 2 deletions(-)

diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 87fbf0e1c..e19151625 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -82,7 +82,7 @@ USA.
 (define assert-eqv-nan
   (simple-binary-assertion eqv-nan? #f))
 
-(define (assert-only-except/no-traps except procedure)
+(define (assert-only-except/no-traps except procedure #!optional mask)
   (assert-eqv
    (flo:preserving-environment
     (lambda ()
@@ -90,7 +90,10 @@ USA.
       (no-traps
        (lambda ()
          (procedure)
-         (flo:test-exceptions (flo:supported-exceptions))))))
+         (flo:test-exceptions
+          (if (default-object? mask)
+              (flo:supported-exceptions)
+              mask))))))
    except))
 
 (define (assert-no-except/yes-traps procedure)
@@ -642,6 +645,56 @@ USA.
                    cases))
             cases)))))
 
+(define-syntax define-snan-comparison-test
+  (syntax-rules ()
+    ((define-snan-comparison-test name safe-compare unsafe-compare cases)
+     (define-test name
+       (map (lambda (x)
+              (lambda ()
+                (with-test-properties
+                    (lambda ()
+                      (let ((snan (identity-procedure (flo:snan 1234)))
+                            (mask
+                             (fix:andc (flo:supported-exceptions)
+                                       ;; Not reliable.
+                                       (flo:exception:subnormal-operand))))
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (safe-compare x snan))
+                         mask)
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (safe-compare snan x))
+                         mask)
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (safe-compare snan snan)))
+                        (assert-false
+                         (no-traps (lambda () (safe-compare x snan))))
+                        (assert-false
+                         (no-traps (lambda () (safe-compare snan x))))
+                        (assert-false
+                         (no-traps (lambda () (safe-compare snan snan))))
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (unsafe-compare x snan))
+                         mask)
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (unsafe-compare snan x))
+                         mask)
+                        (assert-only-except/no-traps
+                         (flo:exception:invalid-operation)
+                         (lambda () (unsafe-compare snan snan)))
+                        (assert-false
+                         (no-traps (lambda () (unsafe-compare x snan))))
+                        (assert-false
+                         (no-traps (lambda () (unsafe-compare snan x))))
+                        (assert-false
+                         (no-traps (lambda () (unsafe-compare snan snan))))))
+                  'SEED x)))
+            cases)))))
+
 (let* ((subnormal+ flo:smallest-positive-subnormal)
        (subnormal- (no-traps (lambda () (- subnormal+))))
        (cases
@@ -652,6 +705,12 @@ USA.
   (define-comparison-test '<= flo:safe<= flo:<= cases)
   (define-comparison-test '<> flo:safe<> flo:<> cases)
   (define-comparison-test '= flo:safe= flo:= cases)
+  (define-snan-comparison-test '</snan flo:safe< flo:< cases)
+  (define-snan-comparison-test '>/snan flo:safe> flo:> cases)
+  (define-snan-comparison-test '>=/snan flo:safe>= flo:>= cases)
+  (define-snan-comparison-test '<=/snan flo:safe<= flo:<= cases)
+  (define-snan-comparison-test '<>/snan flo:safe<> flo:<> cases)
+  (define-snan-comparison-test '=/snan flo:safe= flo:= cases)
   (define-test 'unordered?
     (map (lambda (x)
            (map (lambda (y)
-- 
2.25.1