From 73421c7cf4ea987f47b9c71dcc1e7387809e8a5f Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Thu, 21 Aug 2003 23:10:53 +0000
Subject: [PATCH] Added more epsilon tests, this time using binary search to
 find the actual minimum values satisfying the tests.

---
 ansi-tests/ansi-aux.lsp | 26 ++++++++++++
 ansi-tests/epsilons.lsp | 88 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 113 insertions(+), 1 deletion(-)

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index ebd00858..fd5563dc 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -1536,3 +1536,29 @@ the condition to go uncaught if it cannot be classified."
 	  (unwind-protect (eval ',form) (return-from done :good))
 	  (condition () :good))))
      :good))
+
+;;; Binary search on reals
+
+(defun float-binary-search (fn lo hi)
+  "FN is a function that, if true for X, is true for all Y > X.
+   Find the smallest float in [lo,hi] for which the function
+   return true."
+  
+  (assert (functionp fn))
+  (assert (floatp lo))
+  (assert (floatp hi))
+  (assert (<= lo hi))
+  (assert (funcall fn hi))
+
+  (loop while (<= lo hi)
+	do (let ((mid (/ (+ lo hi) 2)))
+	     (if (funcall fn mid)
+		 (if (= mid hi)
+		     (return hi)
+		   (setq hi mid))
+	       (if (= mid lo)
+		   (return hi)
+		 (setq lo mid))))))
+
+	     
+  
\ No newline at end of file
diff --git a/ansi-tests/epsilons.lsp b/ansi-tests/epsilons.lsp
index 5bf80534..93be6468 100644
--- a/ansi-tests/epsilons.lsp
+++ b/ansi-tests/epsilons.lsp
@@ -35,4 +35,90 @@
 		       long-float-negative-epsilon)
 	unless (= (float 1 e) (- (float 1 e) (/ e 2)))
 	collect e)
-  nil)
\ No newline at end of file
+  nil)
+
+(deftest epsilons.5
+  (loop for (type var) in
+	'(
+	  (short-float short-float-epsilon)
+	  (short-float short-float-negative-epsilon)
+	  (single-float single-float-epsilon)
+	  (single-float single-float-negative-epsilon)
+	  (double-float double-float-epsilon)
+	  (double-float double-float-negative-epsilon)
+	  (long-float long-float-epsilon)
+	  (long-float long-float-negative-epsilon))
+	for val = (symbol-value var)
+	unless (typep val type)
+	collect (list type var val))
+  nil)
+
+(deftest epsilons.6
+  (flet ((%check (x) (/= 1.0s0 (+ 1.0s0 x))))
+    (let ((eps (float-binary-search #'%check 0.0s0 1.0s0)))
+      (if (= eps short-float-epsilon)
+	  :good
+	(list eps short-float-epsilon))))
+  :good)
+
+(deftest epsilons.7
+  (flet ((%check (x) (/= 1.0f0 (+ 1.0f0 x))))
+    (let ((eps (float-binary-search #'%check 0.0f0 1.0f0)))
+      (if (= eps single-float-epsilon)
+	  :good
+	(list eps single-float-epsilon))))
+  :good)
+
+(deftest epsilons.8
+  (flet ((%check (x) (/= 1.0d0 (+ 1.0d0 x))))
+    (let ((eps (float-binary-search #'%check 0.0d0 1.0d0)))
+      (if (= eps double-float-epsilon)
+	  :good
+	(list eps double-float-epsilon))))
+  :good)
+
+(deftest epsilons.9
+  (flet ((%check (x) (/= 1.0l0 (+ 1.0l0 x))))
+    (let ((eps (float-binary-search #'%check 0.0l0 1.0l0)))
+      (if (= eps long-float-epsilon)
+	  :good
+	(list eps long-float-epsilon))))
+  :good)
+
+(deftest epsilons.10
+  (flet ((%check (x) (/= 1.0s0 (- 1.0s0 x))))
+    (let ((eps (float-binary-search #'%check 0.0s0 1.0s0)))
+      (if (= eps short-float-negative-epsilon)
+	  :good
+	(list eps short-float-negative-epsilon))))
+  :good)
+
+(deftest epsilons.11
+  (flet ((%check (x) (/= 1.0f0 (- 1.0f0 x))))
+    (let ((eps (float-binary-search #'%check 0.0f0 1.0f0)))
+      (if (= eps single-float-negative-epsilon)
+	  :good
+	(list eps single-float-negative-epsilon))))
+  :good)
+
+(deftest epsilons.12
+  (flet ((%check (x) (/= 1.0d0 (- 1.0d0 x))))
+    (let ((eps (float-binary-search #'%check 0.0d0 1.0d0)))
+      (if (= eps double-float-negative-epsilon)
+	  :good
+	(list eps double-float-negative-epsilon))))
+  :good)
+
+(deftest epsilons.13
+  (flet ((%check (x) (/= 1.0l0 (- 1.0l0 x))))
+    (let ((eps (float-binary-search #'%check 0.0l0 1.0l0)))
+      (if (= eps long-float-negative-epsilon)
+	  :good
+	(list eps long-float-negative-epsilon))))
+  :good)
+
+
+
+
+
+	
\ No newline at end of file
-- 
GitLab