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

[Sean Ross]

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

Modified Files:
	custom-xml.lisp custom.lisp 
Added Files:
	.cvsignore 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:45 2004
Author: sross



Index: cl-store/sbcl/custom-xml.lisp
diff -u cl-store/sbcl/custom-xml.lisp:1.1 cl-store/sbcl/custom-xml.lisp:1.2
--- cl-store/sbcl/custom-xml.lisp:1.1	Mon Aug 30 17:10:24 2004
+++ cl-store/sbcl/custom-xml.lisp	Wed Oct  6 16:41:45 2004
@@ -1,7 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;; See the file LICENCE for licence information.
 
-(in-package :cl-store)
+(in-package :cl-store-xml)
 
 
 (defstore-xml (obj structure-object stream)
@@ -12,6 +12,27 @@
 
 (defrestore-xml (structure-object place)
   (restore-xml-type-object place))
+
+
+(defstore-xml (obj single-float stream)
+  (with-tag ("SINGLE-FLOAT" stream)
+    (princ-and-store "BITS" (sb-kernel::single-float-bits obj)
+                     stream)))
+
+(defrestore-xml (single-float stream)
+  (sb-kernel::make-single-float
+   (restore-first (get-child "BITS" stream))))
+
+(defstore-xml (obj double-float stream)
+  (with-tag ("DOUBLE-FLOAT" stream)
+    (princ-and-store "HIGH-BITS" (sb-kernel::double-float-high-bits obj)
+                     stream)
+    (princ-and-store "LOW-BITS" (sb-kernel::double-float-low-bits obj)
+                     stream)))
+
+(defrestore-xml (double-float stream)
+  (sb-kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream))
+                                (restore-first (get-child "LOW-BITS" stream))))
          
 
 ;; EOF


Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.1 cl-store/sbcl/custom.lisp:1.2
--- cl-store/sbcl/custom.lisp:1.1	Mon Aug 30 17:10:24 2004
+++ cl-store/sbcl/custom.lisp	Wed Oct  6 16:41:45 2004
@@ -4,6 +4,38 @@
 (in-package :cl-store)
 
 
+;; 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 (restore-object stream)))
+
+(defun sbcl-restore-double-float (stream)
+  (sb-kernel:make-double-float (restore-object stream)
+                               (restore-object stream)))
+
+(defvar *sbcl-float-restorers* 
+  (list (cons 0 'sbcl-restore-single-float)
+        (cons 1 'sbcl-restore-double-float)))
+
+(defrestore-cl-store (float stream)
+  (let ((byte (read-byte stream)))
+    (aif (cdr (assoc byte *sbcl-float-restorers*))
+         (funcall it stream)
+         (restore-error "Unknown float type designator ~S." byte))))
+
+
+;; Custom structure storing
 (defstore-cl-store (obj structure-object stream)
   (output-type-code +structure-object-code+ stream)
   (store-type-object obj stream))