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