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) ,@arglist))))) + (,(lisp-fun-name vector) ,@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 ,@arglist)) - (,(fun-name vector) ,@arglist))))) + (,(lisp-fun-name vector) ,@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))