[cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp

[Sean Ross]

Update of /project/cl-store/cvsroot/cl-store/cmucl
In directory common-lisp.net:/tmp/cvs-serv11891/cmucl

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-02-11
Date: Fri Feb 11 13:00:39 2005
Author: sross

Index: cl-store/cmucl/custom.lisp
diff -u cl-store/cmucl/custom.lisp:1.5 cl-store/cmucl/custom.lisp:1.6
--- cl-store/cmucl/custom.lisp:1.5	Thu Dec  2 11:31:59 2004
+++ cl-store/cmucl/custom.lisp	Fri Feb 11 13:00:39 2005
@@ -3,29 +3,31 @@
 
 (in-package :cl-store)
 
-(defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)    
-  (write-byte (float-type obj) stream)
-  (etypecase obj
-    (single-float (store-object (kernel:single-float-bits obj)
-                                stream))
-    (double-float (store-object (kernel:double-float-high-bits obj)
-                                stream)
-                  (store-object (kernel:double-float-low-bits obj)
-                                stream))))
-
-(defun cmucl-restore-single-float (stream)
-  (kernel:make-single-float (restore-object stream)))
-
-(defun cmucl-restore-double-float (stream)
-  (kernel:make-double-float (restore-object stream)
-                            (restore-object stream)))
-
-(defrestore-cl-store (float stream)
-  (let ((byte (read-byte stream)))
-    (ecase byte
-      (0 (cmucl-restore-single-float stream))
-      (1 (cmucl-restore-double-float stream)))))
+(defvar +single-positive-infinity+ most-positive-single-float)
+(defvar +single-negative-infinity+ most-negative-single-float)
+(defvar +single-nan+)
+
+(defvar +double-positive-infinity+ most-positive-double-float)
+(defvar +double-negative-infinity+ most-negative-double-float)
+(defvar +double-nan+)
+
+(ext:with-float-traps-masked (:overflow :invalid)
+  (setf +single-positive-infinity+ (expt +single-positive-infinity+ 2))
+  (setf +single-negative-infinity+ (expt +single-negative-infinity+ 3))
+  (setf +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))
+  (setf +double-positive-infinity+ (expt +double-positive-infinity+ 2))
+  (setf +double-negative-infinity+ (expt +double-negative-infinity+ 3))
+  (setf +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+)))
+
+(setf *special-floats*
+  (list (cons +double-positive-infinity+ +positive-double-infinity-code+)
+        (cons +single-positive-infinity+ +positive-infinity-code+)
+        (cons +single-negative-infinity+ +negative-infinity-code+)
+        (cons +double-negative-infinity+ +negative-double-infinity-code+)
+        (cons +single-nan+ +float-nan-code+)
+        (cons +double-nan+ +float-double-nan-code+)))
+
+
 
 ;; Custom Structures
 (defstore-cl-store (obj structure-object stream)
@@ -34,9 +36,6 @@
 
 (defrestore-cl-store (structure-object stream)
   (restore-type-object stream))
-
-
-
 
 ;; Structure definitions
 (defun get-layout (obj)