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

[Sean Ross]

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

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

Index: cl-store/acl/custom.lisp
diff -u cl-store/acl/custom.lisp:1.2 cl-store/acl/custom.lisp:1.3
--- cl-store/acl/custom.lisp:1.2	Wed Nov 24 14:27:10 2004
+++ cl-store/acl/custom.lisp	Fri Feb 11 13:00:35 2005
@@ -4,33 +4,24 @@
 (in-package :cl-store)
 
 
-;; Custom float storing
+;; setup special floats
+(defvar +single-positive-infinity+ (expt most-positive-single-float 2))
+(defvar +single-negative-infinity+ (expt most-negative-single-float 3))
+(defvar +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))
 
-(defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)    
-  (write-byte (float-type obj) stream)
-  (etypecase obj
-    (single-float (store-object (multiple-value-list 
-                                 (excl:single-float-to-shorts obj))
-                                stream))
-    (double-float (store-object (multiple-value-list 
-                                 (excl:double-float-to-shorts obj))
-                                stream))))
+(defvar +double-positive-infinity+ (expt most-positive-double-float 2))
+(defvar +double-negative-infinity+ (expt most-negative-double-float 3))
+(defvar +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+))
 
-(defun acl-restore-single-float (stream)
-  (apply #'excl:shorts-to-single-float (restore-object stream)))
 
-(defun acl-restore-double-float (stream)
-  (apply #'excl:shorts-to-double-float (restore-object stream)))
+(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+)))
 
-(defvar *acl-float-restorers* 
-  (list (cons 0 'acl-restore-single-float)
-        (cons 1 'acl-restore-double-float)))
 
-(defrestore-cl-store (float stream)
-  (let ((byte (read-byte stream)))
-    (ecase byte
-      (0 (acl-restore-single-float stream))
-      (1 (acl-restore-double-float stream)))))
 
 ;; EOF