From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 30 Jun 2019 19:50:12 +0000 (+0000)
Subject: Fix flo:ulp on NaN.
X-Git-Tag: mit-scheme-pucked-10.1.12~7^2~31
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=885260d2e2dc506342ff8ca8570ac79f2b7a9be0;p=mit-scheme.git

Fix flo:ulp on NaN.
---

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index d893e37ef..0c5a7c4fb 100644
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -375,11 +375,13 @@ USA.
 ;;; this yields some NaN.
 
 (define (flo:ulp x)
-  (if (flo:finite? x)
-      (let* ((x0 (flo:abs x))
-             (x1 (flo:nextafter x0 (flo:+inf.0))))
-        (flo:- x1 x0))
-      (flo:+inf.0)))
+  (cond ((flo:finite? x)
+	 (let* ((x0 (flo:abs x))
+		(x1 (flo:nextafter x0 (flo:+inf.0))))
+	   (flo:- x1 x0)))
+	((flo:infinite? x)
+	 (flo:+inf.0))
+	(else x)))
 
 (define (int:->flonum n)
   ((ucode-primitive integer->flonum 2) n #b10))
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index af2d12598..5c3db4ecb 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -236,7 +236,7 @@ USA.
    (list 3. (* 2 flo:ulp-of-one))
    (list (- 3. (* 2 flo:ulp-of-one)) (* 2 flo:ulp-of-one))
    (list (flo:+inf.0) (flo:+inf.0))
-   (list +nan.123 +nan.123 expect-failure))
+   (list +nan.123 +nan.123))
   (lambda (x u #!optional xfail)
     (flo:with-trapped-exceptions 0
       (lambda ()