From 6ecc2f369458d98f541aa3fa1cf02b9433f63021 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 31 Oct 2018 16:37:32 +0000
Subject: [PATCH] Define (flo:ulp x) to be distance to next float in direction
 of x.

Thus, (flo:ulp 1.) = (flo:ulp -1.) = flo:ulp-of-one.  Bottoms out at
infinity: (flo:ulp x) = x if x is infinite.  This definition applies
to zero, too, giving the smallest subnormal.
---
 src/runtime/primitive-arithmetic.scm |  9 +++++++++
 src/runtime/runtime.pkg              |  1 +
 tests/runtime/test-arith.scm         | 21 +++++++++++++++++++++
 3 files changed, 31 insertions(+)

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index aa00cf993..bbe4b8af4 100644
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -249,6 +249,15 @@ USA.
 	   (eq? (flo:safe-negative? x)
 		(flo:safe-negative? y)))))
 
+(define (flo:ulp x)
+  ;; Measure the distance from x to the next float in the direction of
+  ;; the sign of x.
+  (if (flo:finite? x)
+      (let* ((direction (flo:copysign (flo:+inf.0) x))
+             (x* (flo:nextafter x direction)))
+        (flo:* (flo:copysign 1. x) (flo:- x* x)))
+      x))
+
 (define (int:->flonum n)
   ((ucode-primitive integer->flonum 2) n #b10))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7b3c89686..bb69b109b 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -345,6 +345,7 @@ USA.
 	  flo:tanh
 	  flo:truncate
 	  flo:truncate->exact
+	  flo:ulp
 	  flo:unordered?
 	  flo:vector-cons
 	  flo:vector-length
diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index 523736357..e9730c18a 100644
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -117,6 +117,27 @@ USA.
   (vector (flo:-inf.0) -2. -1 -0. 0 +0. +1 +2. (flo:+inf.0))
   (lambda (v) (assert-nan (/ v (flo:nan.0)))))
 
+(define-enumerated-test 'flo:ulp
+  (vector
+   (vector (flo:-inf.0) (flo:-inf.0))
+   (vector -2. (* 2 flo:ulp-of-one))
+   (vector -1. flo:ulp-of-one)
+   (vector -0. "4.9406564584124654e-324")
+   (vector 0. "4.9406564584124654e-324")
+   (vector 1. flo:ulp-of-one)
+   (vector 2. (* 2 flo:ulp-of-one))
+   (vector (flo:+inf.0) (flo:+inf.0)))
+  (lambda (v)
+    (let ((x (vector-ref v 0))
+          (u (vector-ref v 1)))
+      (flo:with-trapped-exceptions 0
+        (lambda ()
+          (let ((u
+                 (if (string? u)
+                     (string->number u)
+                     u)))
+            (assert-eqv (flo:ulp x) u)))))))
+
 (define-enumerated-test 'log1p-exact
   (vector
    (cons 0 0)
-- 
2.25.1