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

[Peter Graves]

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

Modified Files:
	ieeefp-tests.lisp 
Log Message:
Added *FLOAT-TYPES* and *ROUNDING-MODES* to support customization of float
types and rounding modes supported by an implementation.
Date: Wed Jun  9 09:05:17 2004
Author: pgraves

Index: ieeefp-tests/ieeefp-tests.lisp
diff -u ieeefp-tests/ieeefp-tests.lisp:1.3 ieeefp-tests/ieeefp-tests.lisp:1.4
--- ieeefp-tests/ieeefp-tests.lisp:1.3	Wed Jun  9 06:06:17 2004
+++ ieeefp-tests/ieeefp-tests.lisp	Wed Jun  9 09:05:17 2004
@@ -1,5 +1,11 @@
 (in-package "IEEEFP-TESTS")
 
+(defvar *float-types*
+  (list :single :double))
+
+(defvar *rounding-modes*
+  (list :nearest :zero :positive-infinity :negative-infinity))
+
 (defclass test-vector ()
   ((fun-name :initarg :fun-name :accessor fun-name)
    (fun-arity :accessor fun-arity)
@@ -9,7 +15,7 @@
    (exceptions :initarg :exceptions :accessor exceptions)
    (fun-args :accessor fun-args)
    (expected-answer :accessor expected-answer)))
-   
+
 (defmethod initialize-instance :after ((vector test-vector)
 				       &key args-and-expected-answer)
   (ecase (fun-name vector)
@@ -105,7 +111,7 @@
 				     :type "input")
 		      *load-truename*))
 	 tests)
-    
+
   (with-open-file (in input-file)
     (do ((line (read-line in nil nil) (read-line in nil nil)))
 	((null line) (nreverse tests))
@@ -258,72 +264,74 @@
 
 (defun emit-double-value-tests (vector stream)
   #| (when (eq (rounding-mode vector) :nearest) .. |#
-  (pprint
-   `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#)
-     (progn
-       (set-up-fpcw-state ,(rounding-mode vector))
-       (let ((result
-	      #|(eval '|#(,(fun-name vector)
-		      ,@(mapcar (lambda (x)
-				  `(prog1
-				    (make-double-float ,x)
-				    (clear-fpcw-exceptions)))
-				(fun-args vector)))))#|)|#
-	 ,(make-result-test-form vector)))
-     t)
-   stream))
+  (when (member (rounding-mode vector) *rounding-modes*)
+    (pprint
+     `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#)
+                  (progn
+                    (set-up-fpcw-state ,(rounding-mode vector))
+                    (let ((result
+                           #|(eval '|#(,(fun-name vector)
+                                       ,@(mapcar (lambda (x)
+                                                   `(prog1
+                                                     (make-double-float ,x)
+                                                     (clear-fpcw-exceptions)))
+                                                 (fun-args vector)))))#|)|#
+                      ,(make-result-test-form vector)))
+                  t)
+     stream)))
 
 (defun emit-single-value-tests (vector stream)
   #| (when (eq (rounding-mode vector) :nearest) .. |#
-  (pprint
-   `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#)
-     (progn
-       (set-up-fpcw-state ,(rounding-mode vector))
-       (let ((result
-	      #|(eval '|#(,(fun-name vector)
-		      ,@(mapcar (lambda (x)
-				  `(prog1
-				    (make-single-float ,x)
-				    (clear-fpcw-exceptions)))
-				(fun-args vector)))))#|)|#
-	 ,(make-result-test-form vector)))
-     t)
-   stream)
-  #+nil
-  (pprint
-   `(rt:deftest ,(make-test-name vector 'compile-value)
-     (progn
-       ,(let ((arglist (mapcar (lambda (x) (declare (ignore x)) (gentemp))
-			       (fun-args vector))))
-	  `(let ((fn (compile nil '(lambda ,arglist
-				    (,(fun-name vector) , at arglist)))))
-	     (set-up-fpcw-state ,(rounding-mode vector))
-	     (let ((result (funcall fn ,@(mapcar (lambda (x)
-						   `(prog1
-						     (make-single-float ,x)
-						     (clear-fpcw-exceptions)))
-						 (fun-args vector)))))
-	       ,(make-result-test-form vector)))))
-     t)
-   stream)
-  #+nil
-  (pprint
-   `(rt:deftest ,(make-test-name vector 'compile-declared-value)
-     (progn
-       ,(let ((arglist (mapcar (lambda (x) (declare (ignore x)) (gentemp))
-			       (fun-args vector))))
-	  `(let ((fn (compile nil '(lambda ,arglist
-				    (declare (type single-float , at arglist))
-				    (,(fun-name vector) , at arglist)))))
-	     (set-up-fpcw-state ,(rounding-mode vector))
-	     (let ((result (funcall fn ,@(mapcar (lambda (x)
-						   `(prog1
-						     (make-single-float ,x)
-						     (clear-fpcw-exceptions)))
-						 (fun-args vector)))))
-	       ,(make-result-test-form vector)))))
-     t)
-   stream))
+  (when (member (rounding-mode vector) *rounding-modes*)
+    (pprint
+     `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#)
+                  (progn
+                    (set-up-fpcw-state ,(rounding-mode vector))
+                    (let ((result
+                           #|(eval '|#(,(fun-name vector)
+                                       ,@(mapcar (lambda (x)
+                                                   `(prog1
+                                                     (make-single-float ,x)
+                                                     (clear-fpcw-exceptions)))
+                                                 (fun-args vector)))))#|)|#
+                      ,(make-result-test-form vector)))
+                  t)
+     stream)
+    #+nil
+    (pprint
+     `(rt:deftest ,(make-test-name vector 'compile-value)
+                  (progn
+                    ,(let ((arglist (mapcar (lambda (x) (declare (ignore x)) (gentemp))
+                                            (fun-args vector))))
+                       `(let ((fn (compile nil '(lambda ,arglist
+                                                 (,(fun-name vector) , at arglist)))))
+                          (set-up-fpcw-state ,(rounding-mode vector))
+                          (let ((result (funcall fn ,@(mapcar (lambda (x)
+                                                                `(prog1
+                                                                  (make-single-float ,x)
+                                                                  (clear-fpcw-exceptions)))
+                                                              (fun-args vector)))))
+                            ,(make-result-test-form vector)))))
+                  t)
+     stream)
+    #+nil
+    (pprint
+     `(rt:deftest ,(make-test-name vector 'compile-declared-value)
+                  (progn
+                    ,(let ((arglist (mapcar (lambda (x) (declare (ignore x)) (gentemp))
+                                            (fun-args vector))))
+                       `(let ((fn (compile nil '(lambda ,arglist
+                                                 (declare (type single-float , at arglist))
+                                                 (,(fun-name vector) , at arglist)))))
+                          (set-up-fpcw-state ,(rounding-mode vector))
+                          (let ((result (funcall fn ,@(mapcar (lambda (x)
+                                                                `(prog1
+                                                                  (make-single-float ,x)
+                                                                  (clear-fpcw-exceptions)))
+                                                              (fun-args vector)))))
+                            ,(make-result-test-form vector)))))
+                  t)
+     stream)))
 
 (defmethod emit-tests-from-one-vector ((vector test-vector) stream)
   (let ((*print-case* :downcase))
@@ -381,10 +389,10 @@
 
 (dolist (fun '(log sin cos tan sinh cosh tanh asin acos
 	       atan sqrt fabs floor ceil add sub mul div pow))
-  (pushnew (make-one-test-file fun :single) *test-files* :test #'equal)
-  (pushnew (make-one-test-file fun :double) *test-files* :test #'equal))
+  (dolist (type *float-types*)
+    (pushnew (make-one-test-file fun type) *test-files* :test #'equal)))
 
-(defvar *revision* "$Revision: 1.3 $")
+(defvar *revision* "$Revision: 1.4 $")
 
 (defun format-date (stream arg colonp atp)
   (declare (ignore colonp atp))