June 2004 - ieeefp-tests-cvs@common-lisp.net

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-cmucl.lisp
by Raymond Toy 17 Jun '04

17 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv545 Modified Files: ieee754-cmucl.lisp Log Message: Misinterpreted what "after X in the direction of Y" meant. Fix it. It means adjust X to be closer to Y. (Noted by Christophe.) Date: Thu Jun 17 10:45:50 2004 Author: rtoy Index: ieeefp-tests/ieee754/ieee754-cmucl.lisp diff -u ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.2 ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.3 --- ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.2 Wed Jun 16 19:59:42 2004 +++ ieeefp-tests/ieee754/ieee754-cmucl.lisp Thu Jun 17 10:45:50 2004 @@ -81,7 +81,7 @@ (double-float -1022))))))) (defun nextafter (x y) - "The next double float after X in the direction of Y, with the + "The next float after X in the direction of Y, with the following exceptions: X = Y returns X, unchanged @@ -101,7 +101,7 @@ (t (multiple-value-bind (f e s) (integer-decode-float x) - (if (>= y 0) + (if (>= y x) (incf f) (decf f)) (* s (scale-float (float f x) e))))))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-sbcl.lisp
by Christophe Rhodes 17 Jun '04

17 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv23125/ieee754 Modified Files: ieee754-sbcl.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/ieee754/ieee754-sbcl.lisp diff -u ieeefp-tests/ieee754/ieee754-sbcl.lisp:1.1 ieeefp-tests/ieee754/ieee754-sbcl.lisp:1.2 --- ieeefp-tests/ieee754/ieee754-sbcl.lisp:1.1 Mon Jun 7 15:16:30 2004 +++ ieeefp-tests/ieee754/ieee754-sbcl.lisp Thu Jun 17 10:32:17 2004 @@ -30,3 +30,5 @@ precision)) (apply #'sb-int:set-floating-point-modes args)) +(defun get-floating-point-modes () + (sb-int:get-floating-point-modes))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp ieeefp-tests/package.lisp
by Christophe Rhodes 17 Jun '04

17 Jun '04

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*"))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-cmucl.lisp
by Raymond Toy 17 Jun '04

17 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv6045/ieee754 Modified Files: ieee754-cmucl.lisp Log Message: First pass at some of the IEEE754 recommended functions. Simple tests work, but still need to write a test-suite for these. Date: Wed Jun 16 19:59:42 2004 Author: rtoy Index: ieeefp-tests/ieee754/ieee754-cmucl.lisp diff -u ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.1 ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.2 --- ieeefp-tests/ieee754/ieee754-cmucl.lisp:1.1 Tue Jun 8 06:44:43 2004 +++ ieeefp-tests/ieee754/ieee754-cmucl.lisp Wed Jun 16 19:59:42 2004 @@ -30,3 +30,78 @@ precision)) (apply #'ext:set-floating-point-modes args)) + +;;; IEEE754 recommended functions + +(defun copysign (x y) + "Copy the sign of Y to X and return the result" + (float-sign y x)) + +(defun scalb (x n) + "Compute x*2^n, without roundoff" + (scale-float x n)) + +(defun finitep (x) + "Returns non-NIL if X is a finite value" + ;; What are we supposed to do when X is a NaN? + (not (ext:float-infinity-p x))) + +(defun nanp (x) + "Returns non-NIL if X is a NaN" + (ext:float-nan-p x)) + +(defun logb (x) + "Return the unbiased exponent of X, except for the following: + + NaN NaN + +infinity +infinity + 0 -infinity, signaling division by zero + + Also, 0 < scalb(x, -logb(x)) < 2, when x is positive and finite; it + is less than 1 only when x is denormalized." + (cond ((nanp x) + x) + ((not (finitep x)) + x) + ((zerop x) + ;; Need to signal division by zero, if enabled; otherwise, + ;; return -infinity. + (/ -1 x)) + (t + ;; Finite x. DECODE-FLOAT is basically what we want, except + ;; it's one too big. And it's also too small for + ;; denormalized numbers. We need to clip at the least + ;; exponent for normalized floats. + (multiple-value-bind (f e s) + (decode-float x) + (declare (ignore f s)) + (max (1- e) + (etypecase x + (single-float -126) + (double-float -1022))))))) + +(defun nextafter (x y) + "The next double float after X in the direction of Y, with the +following exceptions: + + X = Y returns X, unchanged + X or Y is quiet NaN returns the NaN + + Overflow is signaled if nextafter would overflow; underflow is +signaled if nextafter would underflow. In both cases, inexact +is signaled." + + ;; What are we supposed to do if x or y is a signaling NaN? + (cond ((= x y) + x) + ((nanp x) + x) + ((nanp y) + y) + (t + (multiple-value-bind (f e s) + (integer-decode-float x) + (if (>= y 0) + (incf f) + (decf f)) + (* s (scale-float (float f x) e))))))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ucb-patches/ucblib/truncd.input ieeefp-tests/ucb-patches/ucblib/truncs.input
by Christophe Rhodes 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ucb-patches/ucblib In directory common-lisp.net:/tmp/cvs-serv22284/ucb-patches/ucblib Added Files: truncd.input truncs.input Log Message: Add tests for trunc() Minor cleanups of asdf system description and of ieeefp-tests.lisp Date: Wed Jun 16 03:35:54 2004 Author: crhodes

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.asd ieeefp-tests/ieeefp-tests.lisp
by Christophe Rhodes 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv22284 Modified Files: ieeefp-tests.asd ieeefp-tests.lisp Log Message: Add tests for trunc() Minor cleanups of asdf system description and of ieeefp-tests.lisp Date: Wed Jun 16 03:35:54 2004 Author: crhodes Index: ieeefp-tests/ieeefp-tests.asd diff -u ieeefp-tests/ieeefp-tests.asd:1.4 ieeefp-tests/ieeefp-tests.asd:1.5 --- ieeefp-tests/ieeefp-tests.asd:1.4 Tue Jun 15 06:55:07 2004 +++ ieeefp-tests/ieeefp-tests.asd Wed Jun 16 03:35:54 2004 @@ -18,7 +18,10 @@ (cl:defmethod asdf:perform ((o asdf:test-op) (c (cl:eql (asdf:find-system :ieeefp-tests)))) - (cl:mapcar #'cl:load - (cl:symbol-value (cl:intern "*TEST-FILES*" - (cl:find-package "IEEEFP-TESTS")))) + (cl:mapcar (cl:lambda (x) + (cl:format cl:*trace-output* "; loading ~S~%" (namestring x)) + (cl:load x :verbose nil)) + (cl:reverse + (cl:symbol-value (cl:intern "*TEST-FILES*" + (cl:find-package "IEEEFP-TESTS"))))) (cl:funcall (cl:intern "DO-TESTS" (cl:find-package "RT")))) Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.8 ieeefp-tests/ieeefp-tests.lisp:1.9 --- ieeefp-tests/ieeefp-tests.lisp:1.8 Tue Jun 15 15:55:08 2004 +++ ieeefp-tests/ieeefp-tests.lisp Wed Jun 16 03:35:54 2004 @@ -29,7 +29,7 @@ (defmethod initialize-instance :after ((vector test-vector) &key args-and-expected-answer) (ecase (fun-name vector) - ((log exp sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil log10) + ((log exp sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil log10 trunc) (assert (= (length args-and-expected-answer) 2)) (setf (fun-arity vector) 1)) ((add sub mul div pow atan2 hypot) @@ -46,6 +46,7 @@ ((fabs) 'abs) ((floor) 'ffloor) ((ceil) 'fceiling) + ((trunc) 'ftruncate) ((add) '+) ((sub) '-) ((mul) '*) @@ -62,105 +63,59 @@ ((atan2) 'atan) (t (fun-name vector))))) -;; FIXME. This needs to be macroized or something so that each -;; constant is automatically added to *special-values* +(defparameter *special-values* nil) -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; A bunch of constants for common IEEE values so we can read the - ;; tests more easily. - (defconstant +quiet-double-float-nan-mask+ - #X7FF8000000000000) - (defconstant +quiet-single-float-nan-mask+ - #X7FC00000) +(macrolet ((def (name bits) + `(progn + (defconstant ,name ,bits) + (push (cons ,bits ',name) *special-values*)))) + (def +quiet-double-float-nan-mask+ #X7FF8000000000000) + (def +quiet-single-float-nan-mask+ #X7FC00000) ;; NaN is supposed to ignore the sign, but the tests use both ;; positive and negative NaNs, so define them here. - (defconstant +trapping-positive-double-float-nan+ - #x7FF0000000000001) - (defconstant +trapping-negative-double-float-nan+ - #xFFF0000000000001) - (defconstant +single-float-positive-infinity+ - #x7F800000) - (defconstant +single-float-negative-infinity+ - #xFF800000) - (defconstant +double-float-positive-infinity+ - #x7FF0000000000000) - (defconstant +double-float-negative-infinity+ - #xFFF0000000000000) - (defconstant +most-positive-double-float+ - #X7FEFFFFFFFFFFFFF) - (defconstant +most-positive-single-float+ - #x7F7FFFFF) - (defconstant +least-positive-double-float+ - 1) - (defconstant +least-positive-single-float+ - 1) - (defconstant +least-negative-double-float+ - #x8000000000000001) - (defconstant +least-negative-single-float+ - #x80000001) - (defconstant +least-positive-normalized-double-float+ - #x10000000000000) - (defconstant +least-positive-normalized-single-float+ - #x800000) - (defconstant +least-negative-normalized-double-float+ - #x8010000000000000) - (defconstant +least-negative-normalized-single-float+ - #x80800000) - (defconstant +1d0+ - #x3FF0000000000000) - (defconstant +1f0+ - #x3F800000) - (defconstant +negative-0d0+ - #x8000000000000000) - (defconstant +negative-0f0+ - #x80000000) - ) - -;; An alist of integers and the corresponding symbol with that value. -(defparameter *special-values* - (mapcar #'(lambda (x) - `(,(symbol-value x) ,x)) - '(+quiet-double-float-nan-mask+ - +quiet-single-float-nan-mask+ - +trapping-positive-double-float-nan+ - +trapping-negative-double-float-nan+ - +single-float-positive-infinity+ - +single-float-negative-infinity+ - +double-float-positive-infinity+ - +double-float-negative-infinity+ - +most-positive-double-float+ - +most-positive-single-float+ - +least-positive-double-float+ - +least-positive-single-float+ - +least-negative-double-float+ - +least-negative-single-float+ - +least-positive-normalized-double-float+ - +least-positive-normalized-single-float+ - +least-negative-normalized-double-float+ - +least-negative-normalized-single-float+ - +1d0+ - +1f0+ - +negative-0d0+ - +negative-0f0+ - ))) + (def +trapping-positive-double-float-nan+ #x7FF0000000000001) + (def +trapping-negative-double-float-nan+ #xFFF0000000000001) + (def +single-float-positive-infinity+ #x7F800000) + (def +single-float-negative-infinity+ #xFF800000) + (def +double-float-positive-infinity+ #x7FF0000000000000) + (def +double-float-negative-infinity+ #xFFF0000000000000) + (def +most-positive-double-float+ #X7FEFFFFFFFFFFFFF) + (def +most-positive-single-float+ #x7F7FFFFF) + (def +least-positive-double-float+ 1) + (def +least-positive-single-float+ 1) + (def +least-negative-double-float+ #x8000000000000001) + (def +least-negative-single-float+ #x80000001) + (def +least-positive-normalized-double-float+ #x10000000000000) + (def +least-positive-normalized-single-float+ #x800000) + (def +least-negative-normalized-double-float+ #x8010000000000000) + (def +least-negative-normalized-single-float+ #x80800000) + (def +1d0+ #x3FF0000000000000) + (def +1f0+ #x3F800000) + (def +negative-0d0+ #x8000000000000000) + (def +negative-0f0+ #x80000000)) - (defun maybe-replace-special-value (x) ;; Look at x and replace it with named constants, if possible. (let ((value (assoc x *special-values* :test #'=))) (if value - (cadr value) + (cdr value) x))) +(defun vector-pathname (function-name file-name) + (let ((directory (case function-name + ((trunc) '(:relative "ucb-patches" "ucblib")) + (t '(:relative "ucb" "ucblib"))))) + (merge-pathnames + (make-pathname :directory directory + :name file-name + :type "input") + *load-truename*))) + (defun process-vector-file (function-name precision) (let* ((file-name (format nil "~(~A~)~(~A~)" function-name (char (symbol-name precision) 0))) (length (length file-name)) - (input-file (merge-pathnames - (make-pathname :directory '(:relative "ucb" "ucblib") - :name file-name - :type "input") - *load-truename*)) + (input-file (vector-pathname function-name file-name)) tests) (with-open-file (in input-file) @@ -429,7 +384,7 @@ (with-open-file (s (format nil "/tmp/~(~A~)-~(~A~).lisp" fun-name precision) :direction :output :if-exists :supersede) - (format t "; Creating ~S~%" (file-namestring s)) + (format *trace-output* "; creating ~S~%" (namestring s)) (format s "(in-package \"IEEEFP-TESTS\")~2%") (setf *test-counter* 0) (dolist (v (process-vector-file fun-name precision)) @@ -441,11 +396,11 @@ (dolist (fun '(log sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil add sub mul div pow - atan2 log10 hypot)) + atan2 log10 hypot trunc)) (dolist (type *float-types*) (pushnew (make-one-test-file fun type) *test-files* :test #'equal))) -(defvar *revision* "$Revision: 1.8 $") +(defvar *revision* "$Revision: 1.9 $") (defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

1 0

[ieeefp-tests-cvs] CVS update: Directory change: ieeefp-tests/ucb-patches/ucblib
by Christophe Rhodes 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ucb-patches/ucblib In directory common-lisp.net:/tmp/cvs-serv10816/ucb-patches/ucblib Log Message: Directory /project/ieeefp-tests/cvsroot/ieeefp-tests/ucb-patches/ucblib added to the repository Date: Wed Jun 16 03:28:56 2004 Author: crhodes New directory ieeefp-tests/ucb-patches/ucblib added

1 0

[ieeefp-tests-cvs] CVS update: Directory change: ieeefp-tests/ucb-patches
by Christophe Rhodes 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ucb-patches In directory common-lisp.net:/tmp/cvs-serv10670/ucb-patches Log Message: Directory /project/ieeefp-tests/cvsroot/ieeefp-tests/ucb-patches added to the repository Date: Wed Jun 16 03:28:48 2004 Author: crhodes New directory ieeefp-tests/ucb-patches added

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Raymond Toy 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv26648 Modified Files: ieeefp-tests.lisp Log Message: Oops. Fix typo. Date: Tue Jun 15 15:55:08 2004 Author: rtoy Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.7 ieeefp-tests/ieeefp-tests.lisp:1.8 --- ieeefp-tests/ieeefp-tests.lisp:1.7 Tue Jun 15 15:51:19 2004 +++ ieeefp-tests/ieeefp-tests.lisp Tue Jun 15 15:55:08 2004 @@ -96,7 +96,7 @@ 1) (defconstant +least-negative-double-float+ #x8000000000000001) - (defconstant +least-positive-single-float+ + (defconstant +least-negative-single-float+ #x80000001) (defconstant +least-positive-normalized-double-float+ #x10000000000000) @@ -445,7 +445,7 @@ (dolist (type *float-types*) (pushnew (make-one-test-file fun type) *test-files* :test #'equal))) -(defvar *revision* "$Revision: 1.7 $") +(defvar *revision* "$Revision: 1.8 $") (defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Raymond Toy 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv22606 Modified Files: ieeefp-tests.lisp Log Message: Add more constants. Date: Tue Jun 15 15:51:19 2004 Author: rtoy Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.6 ieeefp-tests/ieeefp-tests.lisp:1.7 --- ieeefp-tests/ieeefp-tests.lisp:1.6 Tue Jun 15 15:23:29 2004 +++ ieeefp-tests/ieeefp-tests.lisp Tue Jun 15 15:51:19 2004 @@ -62,6 +62,9 @@ ((atan2) 'atan) (t (fun-name vector))))) +;; FIXME. This needs to be macroized or something so that each +;; constant is automatically added to *special-values* + (eval-when (:compile-toplevel :load-toplevel :execute) ;; A bunch of constants for common IEEE values so we can read the ;; tests more easily. @@ -69,7 +72,11 @@ #X7FF8000000000000) (defconstant +quiet-single-float-nan-mask+ #X7FC00000) - (defconstant +trapping-double-float-nan+ + ;; NaN is supposed to ignore the sign, but the tests use both + ;; positive and negative NaNs, so define them here. + (defconstant +trapping-positive-double-float-nan+ + #x7FF0000000000001) + (defconstant +trapping-negative-double-float-nan+ #xFFF0000000000001) (defconstant +single-float-positive-infinity+ #x7F800000) @@ -83,6 +90,22 @@ #X7FEFFFFFFFFFFFFF) (defconstant +most-positive-single-float+ #x7F7FFFFF) + (defconstant +least-positive-double-float+ + 1) + (defconstant +least-positive-single-float+ + 1) + (defconstant +least-negative-double-float+ + #x8000000000000001) + (defconstant +least-positive-single-float+ + #x80000001) + (defconstant +least-positive-normalized-double-float+ + #x10000000000000) + (defconstant +least-positive-normalized-single-float+ + #x800000) + (defconstant +least-negative-normalized-double-float+ + #x8010000000000000) + (defconstant +least-negative-normalized-single-float+ + #x80800000) (defconstant +1d0+ #x3FF0000000000000) (defconstant +1f0+ @@ -99,13 +122,22 @@ `(,(symbol-value x) ,x)) '(+quiet-double-float-nan-mask+ +quiet-single-float-nan-mask+ - +trapping-double-float-nan+ + +trapping-positive-double-float-nan+ + +trapping-negative-double-float-nan+ +single-float-positive-infinity+ +single-float-negative-infinity+ +double-float-positive-infinity+ +double-float-negative-infinity+ +most-positive-double-float+ +most-positive-single-float+ + +least-positive-double-float+ + +least-positive-single-float+ + +least-negative-double-float+ + +least-negative-single-float+ + +least-positive-normalized-double-float+ + +least-positive-normalized-single-float+ + +least-negative-normalized-double-float+ + +least-negative-normalized-single-float+ +1d0+ +1f0+ +negative-0d0+ @@ -397,6 +429,7 @@ (with-open-file (s (format nil "/tmp/~(~A~)-~(~A~).lisp" fun-name precision) :direction :output :if-exists :supersede) + (format t "; Creating ~S~%" (file-namestring s)) (format s "(in-package \"IEEEFP-TESTS\")~2%") (setf *test-counter* 0) (dolist (v (process-vector-file fun-name precision)) @@ -412,7 +445,7 @@ (dolist (type *float-types*) (pushnew (make-one-test-file fun type) *test-files* :test #'equal))) -(defvar *revision* "$Revision: 1.6 $") +(defvar *revision* "$Revision: 1.7 $") (defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Raymond Toy 16 Jun '04

16 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv19142 Modified Files: ieeefp-tests.lisp Log Message: o Add support for hypot. This is used to test Lisp's ABS function on complex values. o Clean up some comments, remove FIXME about atan2, log10, hypot. Date: Tue Jun 15 15:23:29 2004 Author: rtoy Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.5 ieeefp-tests/ieeefp-tests.lisp:1.6 --- ieeefp-tests/ieeefp-tests.lisp:1.5 Tue Jun 15 15:03:48 2004 +++ ieeefp-tests/ieeefp-tests.lisp Tue Jun 15 15:23:29 2004 @@ -10,6 +10,11 @@ (defun log10 (x) (log x (float 10 x))) +;; So we can run hypot tests and make it test Lisp's ABS function on +;; complex values. +(defun hypot (x y) + (abs (complex x y))) + (defclass test-vector () ((fun-name :initarg :fun-name :accessor fun-name) (lisp-fun-name :accessor lisp-fun-name) @@ -24,18 +29,18 @@ (defmethod initialize-instance :after ((vector test-vector) &key args-and-expected-answer) (ecase (fun-name vector) - ;; 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 log10) (assert (= (length args-and-expected-answer) 2)) (setf (fun-arity vector) 1)) - ((add sub mul div pow atan2) + ((add sub mul div pow atan2 hypot) (assert (= (length args-and-expected-answer) 3)) (setf (fun-arity vector) 2))) (setf (fun-args vector) (butlast args-and-expected-answer)) (setf (expected-answer vector) (car (last args-and-expected-answer))) (setf (exceptions vector) (sort (exceptions vector) #'string<)) + ;; FUN-NAME is currently partially overloaded with 2 meanings: 1. It + ;; is the name of the test. 2. It is the name of the Lisp function + ;; to use. (setf (fun-name vector) (case (fun-name vector) ((fabs) 'abs) @@ -54,14 +59,6 @@ ;; 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))))) @@ -411,11 +408,11 @@ (dolist (fun '(log sin cos tan sinh cosh tanh asin acos atan sqrt fabs floor ceil add sub mul div pow - atan2 log10)) + atan2 log10 hypot)) (dolist (type *float-types*) (pushnew (make-one-test-file fun type) *test-files* :test #'equal))) -(defvar *revision* "$Revision: 1.5 $") +(defvar *revision* "$Revision: 1.6 $") (defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Raymond Toy 16 Jun '04

16 Jun '04

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))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-abcl.lisp
by Peter Graves 15 Jun '04

15 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv17129 Modified Files: ieee754-abcl.lisp Log Message: The package name is "IEEEFP-TESTS", not "IEEE754-TESTS". Date: Tue Jun 15 12:58:31 2004 Author: pgraves Index: ieeefp-tests/ieee754/ieee754-abcl.lisp diff -u ieeefp-tests/ieee754/ieee754-abcl.lisp:1.2 ieeefp-tests/ieee754/ieee754-abcl.lisp:1.3 --- ieeefp-tests/ieee754/ieee754-abcl.lisp:1.2 Tue Jun 15 06:55:08 2004 +++ ieeefp-tests/ieee754/ieee754-abcl.lisp Tue Jun 15 12:58:31 2004 @@ -1,8 +1,8 @@ (in-package "IEEE754-INTERNALS") -(defvar ieee754-tests:*float-types* (list :double)) +(defvar ieeefp-tests:*float-types* (list :double)) -(defvar ieee754-tests:*rounding-modes* (list :nearest)) +(defvar ieeefp-tests:*rounding-modes* (list :nearest)) (defun make-single-float (x) (error "Not supported."))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-abcl.lisp
by Christophe Rhodes 15 Jun '04

15 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv24446/ieee754 Modified Files: ieee754-abcl.lisp Log Message: Move *ROUNDING-MODES* and *FLOAT-TYPES* to the IEEEFP-TESTS package. Make the asdf system description actually do what it's meant to. Date: Tue Jun 15 06:55:08 2004 Author: crhodes Index: ieeefp-tests/ieee754/ieee754-abcl.lisp diff -u ieeefp-tests/ieee754/ieee754-abcl.lisp:1.1 ieeefp-tests/ieee754/ieee754-abcl.lisp:1.2 --- ieeefp-tests/ieee754/ieee754-abcl.lisp:1.1 Wed Jun 9 08:51:02 2004 +++ ieeefp-tests/ieee754/ieee754-abcl.lisp Tue Jun 15 06:55:08 2004 @@ -1,8 +1,8 @@ (in-package "IEEE754-INTERNALS") -(defvar *float-types* (list :double)) +(defvar ieee754-tests:*float-types* (list :double)) -(defvar *rounding-modes* (list :nearest)) +(defvar ieee754-tests:*rounding-modes* (list :nearest)) (defun make-single-float (x) (error "Not supported."))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.asd ieeefp-tests/package.lisp
by Christophe Rhodes 15 Jun '04

15 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv24446 Modified Files: ieeefp-tests.asd package.lisp Log Message: Move *ROUNDING-MODES* and *FLOAT-TYPES* to the IEEEFP-TESTS package. Make the asdf system description actually do what it's meant to. Date: Tue Jun 15 06:55:07 2004 Author: crhodes Index: ieeefp-tests/ieeefp-tests.asd diff -u ieeefp-tests/ieeefp-tests.asd:1.3 ieeefp-tests/ieeefp-tests.asd:1.4 --- ieeefp-tests/ieeefp-tests.asd:1.3 Wed Jun 9 08:51:44 2004 +++ ieeefp-tests/ieeefp-tests.asd Tue Jun 15 06:55:07 2004 @@ -5,14 +5,20 @@ :depends-on ("package") :components ((:file "ieee754-sbcl" - :in-order-to ((compile-op (feature :sbcl)))) + :in-order-to ((asdf:compile-op + (asdf:feature :sbcl)))) (:file "ieee754-cmucl" - :in-order-to ((compile-op (feature :cmu)))) + :in-order-to ((asdf:compile-op + (asdf:feature :cmu)))) (:file "ieee754-abcl" - :in-order-to ((compile-op (feature :abcl))))) + :in-order-to ((asdf:compile-op + (asdf:feature :abcl))))) :if-component-dep-fails :ignore) (:file "ieeefp-tests" :depends-on ("ieee754")))) -(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system :ieeefp-tests)))) - (mapcar #'load (symbol-value (intern "*TEST-FILES*" (find-package "IEEEFP-TESTS")))) - (funcall (intern "DO-TESTS" (find-package "RT")))) +(cl:defmethod asdf:perform ((o asdf:test-op) + (c (cl:eql (asdf:find-system :ieeefp-tests)))) + (cl:mapcar #'cl:load + (cl:symbol-value (cl:intern "*TEST-FILES*" + (cl:find-package "IEEEFP-TESTS")))) + (cl:funcall (cl:intern "DO-TESTS" (cl:find-package "RT")))) Index: ieeefp-tests/package.lisp diff -u ieeefp-tests/package.lisp:1.2 ieeefp-tests/package.lisp:1.3 --- ieeefp-tests/package.lisp:1.2 Wed Jun 9 08:53:42 2004 +++ ieeefp-tests/package.lisp Tue Jun 15 06:55:07 2004 @@ -1,7 +1,6 @@ (defpackage "IEEE754" (:use "CL") - (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*" - "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT" + (:export "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT" "SINGLE-FLOAT-BITS" "DOUBLE-FLOAT-BITS" "SET-FLOATING-POINT-MODES")) @@ -9,4 +8,5 @@ (:use "CL" "IEEE754")) (defpackage "IEEEFP-TESTS" - (:use "CL" "IEEE754" "SPLIT-SEQUENCE")) \ No newline at end of file + (:use "CL" "IEEE754" "SPLIT-SEQUENCE") + (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*"))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Peter Graves 09 Jun '04

09 Jun '04

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))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/package.lisp
by Peter Graves 09 Jun '04

09 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv11184 Modified Files: package.lisp Log Message: Export *FLOAT-TYPES* and *ROUNDING-MODES* from IEEE754 package. Date: Wed Jun 9 08:53:42 2004 Author: pgraves Index: ieeefp-tests/package.lisp diff -u ieeefp-tests/package.lisp:1.1 ieeefp-tests/package.lisp:1.2 --- ieeefp-tests/package.lisp:1.1 Mon Jun 7 15:16:30 2004 +++ ieeefp-tests/package.lisp Wed Jun 9 08:53:42 2004 @@ -1,6 +1,7 @@ (defpackage "IEEE754" (:use "CL") - (:export "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT" + (:export "*FLOAT-TYPES*" "*ROUNDING-MODES*" + "MAKE-SINGLE-FLOAT" "MAKE-DOUBLE-FLOAT" "SINGLE-FLOAT-BITS" "DOUBLE-FLOAT-BITS" "SET-FLOATING-POINT-MODES"))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.asd
by Peter Graves 09 Jun '04

09 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv10306 Modified Files: ieeefp-tests.asd Log Message: Added support for ABCL. Date: Wed Jun 9 08:51:44 2004 Author: pgraves Index: ieeefp-tests/ieeefp-tests.asd diff -u ieeefp-tests/ieeefp-tests.asd:1.2 ieeefp-tests/ieeefp-tests.asd:1.3 --- ieeefp-tests/ieeefp-tests.asd:1.2 Tue Jun 8 06:49:26 2004 +++ ieeefp-tests/ieeefp-tests.asd Wed Jun 9 08:51:44 2004 @@ -7,7 +7,9 @@ ((:file "ieee754-sbcl" :in-order-to ((compile-op (feature :sbcl)))) (:file "ieee754-cmucl" - :in-order-to ((compile-op (feature :cmu))))) + :in-order-to ((compile-op (feature :cmu)))) + (:file "ieee754-abcl" + :in-order-to ((compile-op (feature :abcl))))) :if-component-dep-fails :ignore) (:file "ieeefp-tests" :depends-on ("ieee754"))))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-abcl.lisp
by Peter Graves 09 Jun '04

09 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv9954 Added Files: ieee754-abcl.lisp Log Message: Initial checkin. Date: Wed Jun 9 08:51:02 2004 Author: pgraves

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Raymond Toy 09 Jun '04

09 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv13270 Modified Files: ieeefp-tests.lisp Log Message: Add some constants for some well-known IEEE754 values and use them in the constructed tests to make it easier to read and understand what the tests are doing. Date: Wed Jun 9 06:06:17 2004 Author: rtoy Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.2 ieeefp-tests/ieeefp-tests.lisp:1.3 --- ieeefp-tests/ieeefp-tests.lisp:1.2 Tue Jun 8 07:13:26 2004 +++ ieeefp-tests/ieeefp-tests.lisp Wed Jun 9 06:06:17 2004 @@ -37,6 +37,64 @@ ((pow) 'expt) (t (fun-name vector))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; A bunch of constants for common IEEE values so we can read the + ;; tests more easily. + (defconstant +quiet-double-float-nan-mask+ + #X7FF8000000000000) + (defconstant +quiet-single-float-nan-mask+ + #X7FC00000) + (defconstant +trapping-double-float-nan+ + #xFFF0000000000001) + (defconstant +single-float-positive-infinity+ + #x7F800000) + (defconstant +single-float-negative-infinity+ + #xFF800000) + (defconstant +double-float-positive-infinity+ + #x7FF0000000000000) + (defconstant +double-float-negative-infinity+ + #xFFF0000000000000) + (defconstant +most-positive-double-float+ + #X7FEFFFFFFFFFFFFF) + (defconstant +most-positive-single-float+ + #x7F7FFFFF) + (defconstant +1d0+ + #x3FF0000000000000) + (defconstant +1f0+ + #x3F800000) + (defconstant +negative-0d0+ + #x8000000000000000) + (defconstant +negative-0f0+ + #x80000000) + ) + +;; An alist of integers and the corresponding symbol with that value. +(defparameter *special-values* + (mapcar #'(lambda (x) + `(,(symbol-value x) ,x)) + '(+quiet-double-float-nan-mask+ + +quiet-single-float-nan-mask+ + +trapping-double-float-nan+ + +single-float-positive-infinity+ + +single-float-negative-infinity+ + +double-float-positive-infinity+ + +double-float-negative-infinity+ + +most-positive-double-float+ + +most-positive-single-float+ + +1d0+ + +1f0+ + +negative-0d0+ + +negative-0f0+ + ))) + + +(defun maybe-replace-special-value (x) + ;; Look at x and replace it with named constants, if possible. + (let ((value (assoc x *special-values* :test #'=))) + (if value + (cadr value) + x))) + (defun process-vector-file (function-name precision) (let* ((file-name (format nil "~(~A~)~(~A~)" function-name (char (symbol-name precision) 0))) @@ -82,14 +140,15 @@ (:double #'cddr) (:quad #'cddddr)) collect - (ecase precision + (maybe-replace-special-value + (ecase precision (:single (parse-integer (car x) :radix 16)) (:double (+ (ash (parse-integer (car x) :radix 16) 32) (parse-integer (cadr x) :radix 16))) (:quad (+ (ash (parse-integer (car x) :radix 16) 96) (ash (parse-integer (cadr x) :radix 16) 64) (ash (parse-integer (caddr x) :radix 16) 32) - (parse-integer (cadddr x) :radix 16)))))) + (parse-integer (cadddr x) :radix 16))))))) (push (make-instance 'test-vector :fun-name function-name :precision precision @@ -119,7 +178,8 @@ `(let ((result-bits (double-float-bits result))) ,(ecase (test vector) (:eq `(= result-bits ,(expected-answer vector))) - (:uo `(= (logand #x7ff8000000000000 result-bits) #x7ff8000000000000)) + (:uo `(= (logand +quiet-double-float-nan-mask+ result-bits) + +quiet-double-float-nan-mask+)) ((:vn :nb) `(<= (abs (- ,(expected-answer vector) result-bits)) ,(if (eq (test vector) :vn) 3 10))) @@ -151,7 +211,8 @@ `(let ((result-bits (single-float-bits result))) ,(ecase (test vector) (:eq `(= result-bits ,(expected-answer vector))) - (:uo `(= (logand result-bits #x7fc00000) #x7fc00000)) + (:uo `(= (logand result-bits +quiet-single-float-nan-mask+) + +quiet-single-float-nan-mask+)) ((:vn :nb) `(<= (abs (- ,(expected-answer vector) result-bits)) ,(if (eq (test vector) :vn) 3 10))) @@ -323,7 +384,7 @@ (pushnew (make-one-test-file fun :single) *test-files* :test #'equal) (pushnew (make-one-test-file fun :double) *test-files* :test #'equal)) -(defvar *revision* "$Revision: 1.2 $") +(defvar *revision* "$Revision: 1.3 $") (defun format-date (stream arg colonp atp) (declare (ignore colonp atp))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp
by Christophe Rhodes 08 Jun '04

08 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv22910 Modified Files: ieeefp-tests.lisp Log Message: Add rudimentary report generation. Date: Tue Jun 8 07:13:26 2004 Author: crhodes Index: ieeefp-tests/ieeefp-tests.lisp diff -u ieeefp-tests/ieeefp-tests.lisp:1.1 ieeefp-tests/ieeefp-tests.lisp:1.2 --- ieeefp-tests/ieeefp-tests.lisp:1.1 Mon Jun 7 15:16:30 2004 +++ ieeefp-tests/ieeefp-tests.lisp Tue Jun 8 07:13:26 2004 @@ -321,4 +321,39 @@ (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)) \ No newline at end of file + (pushnew (make-one-test-file fun :double) *test-files* :test #'equal)) + +(defvar *revision* "$Revision: 1.2 $") + +(defun format-date (stream arg colonp atp) + (declare (ignore colonp atp)) + (multiple-value-bind (s m h da mo yr dow dst tz) + (decode-universal-time arg) + (declare (ignore dow)) + (let* ((tz (+ (if dst 1 0) tz))) + (multiple-value-bind (tzh tzm) + (truncate tz) + (let ((tzmm (truncate tzm 1/60))) + (format stream "~2,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[+~;-~]~2,'0D:~2,'0D" + yr mo da h m s (minusp tzh) tzh tzmm)))))) + +(defun report (&optional (stream *standard-output*)) + (let ((*standard-output* stream)) + (format t ";;;; IEEEFP-TESTS results for ~A ~A~%;;;~%" + (lisp-implementation-type) (lisp-implementation-version)) + (format t ";;; Machine: ~A ~A (~A)~%" + (machine-type) (machine-version) (machine-instance)) + ;; KLUDGE: no way of querying for libm version... + (format t ";;; Software: ~A ~A~%" + (software-type) (software-version)) + (format t ";;; Report generated: ~/ieeefp-tests::format-date/~%" + (get-universal-time)) + (let ((revision (subseq *revision* 11 (1- (length *revision*))))) + (format t ";;; using ieeefp-tests.lisp version ~A~%" revision)) + (let ((failures (rt:pending-tests))) + (format t ";;;~%;;; ~D out of ~D tests failed.~%;;; Failures:~%(~%" + (length failures) + ;; KLUDGE: unexported symbol + (length (cdr rt::*entries*))) + (with-standard-io-syntax + (format t "~{~A~%~})~%" (sort (copy-list failures) #'string<))))))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.asd
by Raymond Toy 08 Jun '04

08 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests In directory common-lisp.net:/tmp/cvs-serv5983 Modified Files: ieeefp-tests.asd Log Message: Support for ieee754-cmucl. (I think.) Date: Tue Jun 8 06:49:26 2004 Author: rtoy Index: ieeefp-tests/ieeefp-tests.asd diff -u ieeefp-tests/ieeefp-tests.asd:1.1 ieeefp-tests/ieeefp-tests.asd:1.2 --- ieeefp-tests/ieeefp-tests.asd:1.1 Mon Jun 7 15:16:30 2004 +++ ieeefp-tests/ieeefp-tests.asd Tue Jun 8 06:49:26 2004 @@ -5,7 +5,9 @@ :depends-on ("package") :components ((:file "ieee754-sbcl" - :in-order-to ((compile-op (feature :sbcl))))) + :in-order-to ((compile-op (feature :sbcl)))) + (:file "ieee754-cmucl" + :in-order-to ((compile-op (feature :cmu))))) :if-component-dep-fails :ignore) (:file "ieeefp-tests" :depends-on ("ieee754"))))

1 0

[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieee754/ieee754-cmucl.lisp
by Raymond Toy 08 Jun '04

08 Jun '04

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754 In directory common-lisp.net:/tmp/cvs-serv3004/ieee754 Added Files: ieee754-cmucl.lisp Log Message: CMUCL port of the ieee754 routines. Date: Tue Jun 8 06:44:43 2004 Author: rtoy

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

ieeefp-tests-cvs June 2004