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))