[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp ieeefp-tests/package.lisp
Christophe Rhodes
crhodes at common-lisp.net
Thu Jun 17 17:32:17 UTC 2004
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) , 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
+ (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 , at arglist))
- (,(lisp-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)
+ (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*"))
More information about the Ieeefp-tests-cvs
mailing list