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

Modified Files: ieeefp-tests.lisp package.lisp Log Message: Add machinery for testing exceptions (disabled by default, enable using IEEEFP-TESTS:*TEST-EXCEPTIONS*).

Include the original line in the generated test for slightly easier debugging.

Date: Thu Jun 17 10:32:17 2004 Author: crhodes

Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.9 ieeefp-tests/ieeefp-tests.lisp:1.10 --- ieeefp-tests/ieeefp-tests.lisp:1.9 Wed Jun 16 03:35:54 2004 +++ ieeefp-tests/ieeefp-tests.lisp Thu Jun 17 10:32:17 2004 @@ -6,6 +6,8 @@ (defvar *rounding-modes* (list :nearest :zero :positive-infinity :negative-infinity))

+(defvar *test-exceptions* nil) + ;; So we can run log10 tests (defun log10 (x) (log x (float 10 x))) @@ -16,7 +18,8 @@ (abs (complex x y)))

(defclass test-vector () - ((fun-name :initarg :fun-name :accessor fun-name) + ((line :initarg :line :accessor line) + (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) @@ -144,7 +147,7 @@ ;; until we start testing exceptions. I think it ;; means that the following exception may or may not ;; be present. - (#? (setf exceptions nil)))) + (#? (push 'maybe exceptions)))) (setf args-and-expected-answer (loop for x on (nthcdr 4 split) by (ecase precision @@ -162,11 +165,12 @@ (ash (parse-integer (caddr x) :radix 16) 32) (parse-integer (cadddr x) :radix 16))))))) (push (make-instance 'test-vector + :line line :fun-name function-name :precision precision :rounding-mode rounding-mode :test test - :exceptions exceptions + :exceptions (nreverse exceptions) :args-and-expected-answer args-and-expected-answer) tests))))))))

@@ -268,116 +272,122 @@ (set-floating-point-modes :accrued-exceptions nil :current-exceptions nil))

+(defun get-accrued-exceptions () + (getf (get-floating-point-modes) :accrued-exceptions)) + (defun emit-double-value-tests (vector stream) - #| (when (eq (rounding-mode vector) :nearest) .. |# (when (member (rounding-mode vector) *rounding-modes*) (pprint - `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#) + `(rt:deftest ,(make-test-name vector 'value) (progn + ,(line vector) (set-up-fpcw-state ,(rounding-mode vector)) (let ((result - #|(eval '|#(,(lisp-fun-name vector) - ,@(mapcar (lambda (x) - `(prog1 - (make-double-float ,x) - (clear-fpcw-exceptions))) - (fun-args vector)))))#|)|# + (,(lisp-fun-name vector) + ,@(mapcar (lambda (x) + `(make-double-float ,x)) + (fun-args vector))))) ,(make-result-test-form vector))) t) stream)))

(defun emit-single-value-tests (vector stream) - #| (when (eq (rounding-mode vector) :nearest) .. |# (when (member (rounding-mode vector) *rounding-modes*) (pprint - `(rt:deftest ,(make-test-name vector 'value #|'eval-value|#) + `(rt:deftest ,(make-test-name vector 'value) (progn + ,(line vector) (set-up-fpcw-state ,(rounding-mode vector)) (let ((result - #|(eval '|#(,(lisp-fun-name vector) - ,@(mapcar (lambda (x) - `(prog1 - (make-single-float ,x) - (clear-fpcw-exceptions))) - (fun-args vector)))))#|)|# + (,(lisp-fun-name vector) + ,@(mapcar (lambda (x) + `(make-single-float ,x)) + (fun-args vector))))) ,(make-result-test-form vector))) t) - stream) - #+nil + stream))) + +(defun emit-double-exceptions-tests (vector stream) + (when (and (member (rounding-mode vector) *rounding-modes*) + *test-exceptions*) (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 - (,(lisp-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 + (let* ((maybes (loop for x on (exceptions vector) + if (eq (car x) 'maybe) + collect (cadr x))) + (definites (sort + (set-difference (remove 'maybe (exceptions vector)) + maybes) + #'string<))) + `(rt:deftest ,(make-test-name vector 'exceptions) + (block nil + ,(line vector) + (set-up-fpcw-state ,(rounding-mode vector)) + (let ((answer + (,(lisp-fun-name vector) + ,@(mapcar (lambda (x) + `(make-double-float ,x)) + (fun-args vector)))) + (result + (sort + (remove-if-not + (lambda (x) + (member x + '(:invalid :underflow :overflow + :divide-by-zero :inexact))) + (set-difference (get-accrued-exceptions) + ',maybes)) + #'string<))) + (if (complexp answer) + ',definites + result))) + ,definites)) + stream))) + +(defun emit-single-exceptions-tests (vector stream) + (when (and (member (rounding-mode vector) *rounding-modes*) + *test-exceptions*) (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)) - (,(lisp-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) + (let* ((maybes (loop for x on (exceptions vector) + if (eq (car x) 'maybe) + collect (cadr x))) + (definites (sort + (set-difference (remove 'maybe (exceptions vector)) + maybes) + #'string<))) + `(rt:deftest ,(make-test-name vector 'exceptions) + (block nil + ,(line vector) + (set-up-fpcw-state ,(rounding-mode vector)) + (let ((answer + (,(lisp-fun-name vector) + ,@(mapcar (lambda (x) + `(make-single-float ,x)) + (fun-args vector)))) + (result + (sort + (remove-if-not + (lambda (x) + (member x + '(:invalid :underflow :overflow + :divide-by-zero :inexact))) + (set-difference (get-accrued-exceptions) + ',maybes)) + #'string<))) + (if (complexp answer) + ',definites + result))) + ,definites)) stream)))

(defmethod emit-tests-from-one-vector ((vector test-vector) stream) (let ((*print-case* :downcase)) (ecase (precision vector) (:single - #+nil - (pprint - `(rt:deftest ,(intern - (format nil "~@:(~A~)-~@:(~A~)-EVAL-EXCEPTIONS.~D" - (precision vector) - (lisp-fun-name vector) - *test-counter*)) - (progn - (set-floating-point-modes - :traps nil - :accrued-exceptions nil - :current-exceptions nil - :rounding-mode ,(rounding-mode vector)) - (let ((result - (eval '(,(lisp-fun-name vector) ,@(mapcar - (lambda (x) - `(prog1 - (make-single-float ,x) - (set-floating-point-modes - :accrued-exceptions nil - :current-exceptions nil))) - (fun-args vector)))))) - (if (complexp result) - ;; FIXME - ',(exceptions vector) - (sort - (intersection - (getf (sb-int:get-floating-point-modes) :accrued-exceptions) - '(:inexact :invalid :overflow :underflow :divide-by-zero)) - #'string<)))) - ,(exceptions vector)) - stream) - (emit-single-value-tests vector stream)) + (emit-single-value-tests vector stream) + (emit-single-exceptions-tests vector stream)) (:double - (emit-double-value-tests vector stream)) + (emit-double-value-tests vector stream) + (emit-double-exceptions-tests vector stream)) )))

(defun make-one-test-file (fun-name precision) @@ -400,7 +410,7 @@ (dolist (type *float-types*) (pushnew (make-one-test-file fun type) *test-files* :test #'equal)))

-(defvar *revision* "$Revision: 1.9 $") +(defvar *revision* "$Revision: 1.10 $")

(defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

Index: ieeefp-tests/package.lisp diff -u ieeefp-tests/package.lisp:1.3 ieeefp-tests/package.lisp:1.4 --- ieeefp-tests/package.lisp:1.3 Tue Jun 15 06:55:07 2004 +++ ieeefp-tests/package.lisp Thu Jun 17 10:32:17 2004 @@ -2,11 +2,11 @@ (:use "CL") (:export "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT" "SINGLE-FLOAT-BITS" "DOUBLE-FLOAT-BITS" - "SET-FLOATING-POINT-MODES")) + "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES"))

(defpackage "IEEE754-INTERNALS" (:use "CL" "IEEE754"))

(defpackage "IEEEFP-TESTS" (:use "CL" "IEEE754" "SPLIT-SEQUENCE") - (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*")) + (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*" "*TEST-EXCEPTIONS*"))