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

[Sean Ross]

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

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

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.5 cl-store/sbcl/custom.lisp:1.6
--- cl-store/sbcl/custom.lisp:1.5	Thu Dec  2 11:32:04 2004
+++ cl-store/sbcl/custom.lisp	Fri Feb 11 13:00:47 2005
@@ -2,34 +2,33 @@
 ;; See the file LICENCE for licence information.
 
 (in-package :cl-store)
-;; TODO 
-;; real Functions and closures.
+
+; special floats
+(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+)
+
+(sb-int: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 float storing
-(defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)
-  (write-byte (float-type obj) stream)
-  (etypecase obj
-    (single-float (store-object (sb-kernel:single-float-bits obj)
-                                stream))
-    (double-float (store-object (sb-kernel:double-float-high-bits obj)
-                                stream)
-                  (store-object (sb-kernel:double-float-low-bits obj)
-                                stream))))
-
-(defun sbcl-restore-single-float (stream)
-  (sb-kernel:make-single-float (the integer (restore-object stream))))
-
-(defun sbcl-restore-double-float (stream)
-  (sb-kernel:make-double-float (the integer (restore-object stream))
-                               (the integer (restore-object stream))))
-
-(defrestore-cl-store (float stream)
-  (let ((byte (read-byte stream)))
-    (ecase byte
-      (0 (sbcl-restore-single-float stream))
-      (1 (sbcl-restore-double-float stream)))))
 
 ;; Custom structure storing
 (defstore-cl-store (obj structure-object stream)