[ieeefp-tests-cvs] CVS update: ieeefp-tests/ieeefp-tests.lisp

[Raymond Toy]

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