[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp ieeefp-tests/package.lisp

[Christophe Rhodes]

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests
In directory common-lisp.net:/tmp/cvs-serv24641

Modified Files:
	ieeefp-tests.lisp package.lisp 
Log Message:
Implement for sbcl comparison operators from Table 4 of ieee754.

Work enough logic into ieeefp-tests to be able to test booleans as well 
as numerical results

Add test vectors for ieee754:=

Make sbcl test exceptions by default

Date: Mon Aug  2 05:54:12 2004
Author: crhodes

Index: ieeefp-tests/ieeefp-tests.lisp
diff -u ieeefp-tests/ieeefp-tests.lisp:1.10 ieeefp-tests/ieeefp-tests.lisp:1.11
--- ieeefp-tests/ieeefp-tests.lisp:1.10	Thu Jun 17 10:32:17 2004
+++ ieeefp-tests/ieeefp-tests.lisp	Mon Aug  2 05:54:12 2004
@@ -37,9 +37,17 @@
      (setf (fun-arity vector) 1))
     ((add sub mul div pow atan2 hypot)
      (assert (= (length args-and-expected-answer) 3))
+     (setf (fun-arity vector) 2))
+    ((ieee754:=)
+     (assert (= (length args-and-expected-answer) 2))
      (setf (fun-arity vector) 2)))
-  (setf (fun-args vector) (butlast args-and-expected-answer))
-  (setf (expected-answer vector) (car (last args-and-expected-answer)))
+  (case (test vector)
+    ((:yea :nay)
+     (setf (fun-args vector) args-and-expected-answer
+	   (expected-answer vector) nil))
+    (t 
+     (setf (fun-args vector) (butlast args-and-expected-answer))
+     (setf (expected-answer vector) (car (last args-and-expected-answer)))))
   (setf (exceptions vector) (sort (exceptions vector) #'string<))
   ;; FUN-NAME is currently partially overloaded with 2 meanings: 1. It
   ;; is the name of the test. 2. It is the name of the Lisp function
@@ -106,7 +114,7 @@
 
 (defun vector-pathname (function-name file-name)
   (let ((directory (case function-name
-		     ((trunc) '(:relative "ucb-patches" "ucblib"))
+		     ((trunc ieee754:=) '(:relative "ucb-patches" "ucblib"))
 		     (t '(:relative "ucb" "ucblib")))))
     (merge-pathnames
      (make-pathname :directory directory
@@ -183,12 +191,14 @@
 			stream list)))
 
 (defun make-result-test-form (vector)
-  `(if (complexp result)
-    t
-    ,(ecase (precision vector)
-      (:single (make-single-result-test-form vector))
-      (:double (make-double-result-test-form vector))
-      )))
+  (case (test vector)
+    ((:yea) `(not (not result)))
+    ((:nay) `(not result))
+    (t `(if (complexp result)
+	 t
+	 ,(ecase (precision vector)
+		 (:single (make-single-result-test-form vector))
+		 (:double (make-double-result-test-form vector)))))))
 
 (defun make-double-result-test-form (vector)
   `(let ((result-bits (double-float-bits result)))
@@ -406,11 +416,11 @@
 
 (dolist (fun '(log sin cos tan sinh cosh tanh asin acos
 	       atan sqrt fabs floor ceil add sub mul div pow
-	       atan2 log10 hypot trunc))
+	       atan2 log10 hypot trunc ieee754:=))
   (dolist (type *float-types*)
     (pushnew (make-one-test-file fun type) *test-files* :test #'equal)))
 
-(defvar *revision* "$Revision: 1.10 $")
+(defvar *revision* "$Revision: 1.11 $")
 
 (defun format-date (stream arg colonp atp)
   (declare (ignore colonp atp))


Index: ieeefp-tests/package.lisp
diff -u ieeefp-tests/package.lisp:1.4 ieeefp-tests/package.lisp:1.5
--- ieeefp-tests/package.lisp:1.4	Thu Jun 17 10:32:17 2004
+++ ieeefp-tests/package.lisp	Mon Aug  2 05:54:12 2004
@@ -1,12 +1,21 @@
 (defpackage "IEEE754"
   (:use "CL")
+  (:shadow "=" ">" "<" ">=" "<=")
   (:export "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT"
 	   "SINGLE-FLOAT-BITS" "DOUBLE-FLOAT-BITS"
-	   "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES"))
+	   "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES"
+
+	   ;; IEEE754 Table 4
+	   "=" "?<>" ">" ">=" "<" "<=" "?"
+	   "<>"
+	   "<=>" "?>" "?>=" "?<" "?<=" "?="
+	   ))
 
 (defpackage "IEEE754-INTERNALS"
+  (:shadowing-import-from "IEEE754" "=" ">" "<" ">=" "<=")
   (:use "CL" "IEEE754"))
 
 (defpackage "IEEEFP-TESTS"
+  (:shadowing-import-from "CL" "=" ">" "<" ">=" "<=")
   (:use "CL" "IEEE754" "SPLIT-SEQUENCE")
   (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*" "*TEST-EXCEPTIONS*"))