[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.asd ieeefp-tests/ieeefp-tests.lisp
Christophe Rhodes
crhodes at common-lisp.net
Wed Jun 16 10:35:54 UTC 2004
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))
More information about the Ieeefp-tests-cvs
mailing list