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

[Peter Graves]

Update of /project/ieeefp-tests/cvsroot/ieeefp-tests/ieee754
In directory common-lisp.net:/tmp/cvs-serv4938

Modified Files:
	ieee754-abcl.lisp 
Log Message:
Single float support, comparison operators.
Date: Thu Aug 25 17:27:45 2005
Author: pgraves

Index: ieeefp-tests/ieee754/ieee754-abcl.lisp
diff -u ieeefp-tests/ieee754/ieee754-abcl.lisp:1.3 ieeefp-tests/ieee754/ieee754-abcl.lisp:1.4
--- ieeefp-tests/ieee754/ieee754-abcl.lisp:1.3	Tue Jun 15 21:58:31 2004
+++ ieeefp-tests/ieee754/ieee754-abcl.lisp	Thu Aug 25 17:27:45 2005
@@ -1,27 +1,48 @@
 (in-package "IEEE754-INTERNALS")
 
-(defvar ieeefp-tests:*float-types* (list :double))
+(defvar ieeefp-tests:*float-types* (list :single :double))
 
 (defvar ieeefp-tests:*rounding-modes* (list :nearest))
 
 (defun make-single-float (x)
-  (error "Not supported."))
+  (sys:make-single-float x))
 
 (defun make-double-float (x)
-  (sys::make-double-float x))
+  (sys:make-double-float x))
 
 (defun single-float-bits (x)
-  (error "Not supported."))
+  (declare (type single-float x))
+  (ldb (byte 32 0) (sys:single-float-bits x)))
 
 (defun double-float-bits (x)
   (declare (type double-float x))
   (ldb (byte 64 0)
-       (logior (ash (sys::double-float-high-bits x) 32)
-	       (sys::double-float-low-bits x))))
+       (logior (ash (sys:double-float-high-bits x) 32)
+	       (sys:double-float-low-bits x))))
 
 (defun set-floating-point-modes (&rest args &key traps accrued-exceptions
 				 current-exceptions rounding-mode precision)
-  (declare (ignore traps accrued-exceptions current-exceptions rounding-mode
-		   precision))
+  (declare (ignore args traps accrued-exceptions current-exceptions
+                   rounding-mode precision))
   ;; Not supported.
   )
+
+(macrolet
+  ((def (x &body body)
+     `(defun ,x (x y)
+        (declare (type float x y))
+        , at body)))
+  (def = (cl:= x y))
+  (def ?<> (not (= x y)))
+  (def > (cl:> x y))
+  (def >= (cl:>= x y))
+  (def < (cl:< x y))
+  (def <= (cl:<= x y))
+  (def ? (or (sys:float-nan-p x) (sys:float-nan-p y)))
+  (def <> (or (< x y) (> x y)))
+  (def <=> (or (< x y) (= x y) (> x y)))
+  (def ?> (or (? x y) (> x y)))
+  (def ?>= (or (? x y) (>= x y)))
+  (def ?< (or (? x y) (< x y)))
+  (def ?<= (or (? x y) (<= x y)))
+  (def ?= (or (? x y) (= x y))))