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

[Raymond Toy]

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

Modified Files:
	ieeefp-tests.lisp 
Log Message:
Add support for atan2 and log10 tests:

o By adding an extra slot to TEST-VECTOR to hold the lisp function
  name we need to use.  (Only really needed for atan2.)
o By adding a log10 function for us to call.


Date: Tue Jun 15 15:03:48 2004
Author: rtoy

Index: ieeefp-tests/ieeefp-tests.lisp
diff -u ieeefp-tests/ieeefp-tests.lisp:1.4 ieeefp-tests/ieeefp-tests.lisp:1.5
--- ieeefp-tests/ieeefp-tests.lisp:1.4	Wed Jun  9 09:05:17 2004
+++ ieeefp-tests/ieeefp-tests.lisp	Tue Jun 15 15:03:48 2004
@@ -6,8 +6,13 @@
 (defvar *rounding-modes*
   (list :nearest :zero :positive-infinity :negative-infinity))
 
+;; So we can run log10 tests
+(defun log10 (x)
+  (log x (float 10 x)))
+
 (defclass test-vector ()
   ((fun-name :initarg :fun-name :accessor fun-name)
+   (lisp-fun-name :accessor lisp-fun-name)
    (fun-arity :accessor fun-arity)
    (precision :initarg :precision :accessor precision)
    (rounding-mode :initarg :rounding-mode :accessor rounding-mode)
@@ -22,10 +27,10 @@
     ;; FIXME: atan comes in two versions; log10 exists; then there's
     ;; hypot() and cabs() which appear not to have equivalents in CL.
     ;; (Could use them to test ABS on complexes, though)
-    ((log exp sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil)
+    ((log exp sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil log10)
      (assert (= (length args-and-expected-answer) 2))
      (setf (fun-arity vector) 1))
-    ((add sub mul div pow)
+    ((add sub mul div pow atan2)
      (assert (= (length args-and-expected-answer) 3))
      (setf (fun-arity vector) 2)))
   (setf (fun-args vector) (butlast args-and-expected-answer))
@@ -41,6 +46,23 @@
 	  ((mul) '*)
 	  ((div) '/)
 	  ((pow) 'expt)
+	  (t (fun-name vector))))
+  ;; Figure out the Lisp function we need to call to test.  Mostly
+  ;; redundant, except for the atan2 tests.  Can't use a fun-name of
+  ;; atan2 because there's no atan2 Lisp function.  And can't change
+  ;; fun-name from atan2 to atan because then all the test names will
+  ;; be atan, overwriting the tests for the single arg atan.
+  (setf (lisp-fun-name vector)
+	(case (fun-name vector)
+	  ((fabs) 'abs)
+	  ((floor) 'ffloor)
+	  ((ceil) 'fceiling)
+	  ((add) '+)
+	  ((sub) '-)
+	  ((mul) '*)
+	  ((div) '/)
+	  ((pow) 'expt)
+	  ((atan2) 'atan)
 	  (t (fun-name vector)))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -270,7 +292,7 @@
                   (progn
                     (set-up-fpcw-state ,(rounding-mode vector))
                     (let ((result
-                           #|(eval '|#(,(fun-name vector)
+                           #|(eval '|#(,(lisp-fun-name vector)
                                        ,@(mapcar (lambda (x)
                                                    `(prog1
                                                      (make-double-float ,x)
@@ -288,7 +310,7 @@
                   (progn
                     (set-up-fpcw-state ,(rounding-mode vector))
                     (let ((result
-                           #|(eval '|#(,(fun-name vector)
+                           #|(eval '|#(,(lisp-fun-name vector)
                                        ,@(mapcar (lambda (x)
                                                    `(prog1
                                                      (make-single-float ,x)
@@ -304,7 +326,7 @@
                     ,(let ((arglist (mapcar (lambda (x) (declare (ignore x)) (gentemp))
                                             (fun-args vector))))
                        `(let ((fn (compile nil '(lambda ,arglist
-                                                 (,(fun-name vector) , at arglist)))))
+                                                 (,(lisp-fun-name vector) , at arglist)))))
                           (set-up-fpcw-state ,(rounding-mode vector))
                           (let ((result (funcall fn ,@(mapcar (lambda (x)
                                                                 `(prog1
@@ -322,7 +344,7 @@
                                             (fun-args vector))))
                        `(let ((fn (compile nil '(lambda ,arglist
                                                  (declare (type single-float , at arglist))
-                                                 (,(fun-name vector) , at arglist)))))
+                                                 (,(lisp-fun-name vector) , at arglist)))))
                           (set-up-fpcw-state ,(rounding-mode vector))
                           (let ((result (funcall fn ,@(mapcar (lambda (x)
                                                                 `(prog1
@@ -342,7 +364,7 @@
 	`(rt:deftest ,(intern
 		    (format nil "~@:(~A~)-~@:(~A~)-EVAL-EXCEPTIONS.~D"
 			    (precision vector)
-			    (fun-name vector)
+			    (lisp-fun-name vector)
 			    *test-counter*))
 	  (progn
 	    (set-floating-point-modes
@@ -351,7 +373,7 @@
 	     :current-exceptions nil
 	     :rounding-mode ,(rounding-mode vector))
 	    (let ((result
-		   (eval '(,(fun-name vector) ,@(mapcar
+		   (eval '(,(lisp-fun-name vector) ,@(mapcar
 					  (lambda (x)
 					    `(prog1
 					      (make-single-float ,x)
@@ -388,11 +410,12 @@
 (defparameter *test-files* nil)
 
 (dolist (fun '(log sin cos tan sinh cosh tanh asin acos
-	       atan sqrt fabs floor ceil add sub mul div pow))
+	       atan sqrt fabs floor ceil add sub mul div pow
+	       atan2 log10))
   (dolist (type *float-types*)
     (pushnew (make-one-test-file fun type) *test-files* :test #'equal)))
 
-(defvar *revision* "$Revision: 1.4 $")
+(defvar *revision* "$Revision: 1.5 $")
 
 (defun format-date (stream arg colonp atp)
   (declare (ignore colonp atp))