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