From sross at common-lisp.net  Fri Oct  1 08:49:48 2004
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 01 Oct 2004 10:49:48 +0200
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README
	cl-store/cl-store.asd cl-store/default-backend.lisp
	cl-store/tests.lisp 
Message-ID: <E1CDJ6q-0005At-00@common-lisp.net>

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

Modified Files:
	ChangeLog README cl-store.asd default-backend.lisp tests.lisp 
Log Message:
Changelog 2004-10-01

Date: Fri Oct  1 10:49:46 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.8 cl-store/ChangeLog:1.9
--- cl-store/ChangeLog:1.8	Mon Sep 27 13:24:18 2004
+++ cl-store/ChangeLog	Fri Oct  1 10:49:46 2004
@@ -1,3 +1,7 @@
+2004-10-01 Sean Ross <sdr at jhb.ucs.co.za>
+	* lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard.
+	* tests.lisp: Infite float tests for lispworks.
+	
 2004-09-27 Sean Ross <sdr at jhb.ucs.co.za>
 	* plumbing.lisp: Slightly nicer error handling (I think).
 	All conditions caught in store and restore are resignalled


Index: cl-store/README
diff -u cl-store/README:1.6 cl-store/README:1.7
--- cl-store/README:1.6	Mon Aug 30 17:10:20 2004
+++ cl-store/README	Fri Oct  1 10:49:46 2004
@@ -1,7 +1,7 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.2
+Version: 0.2.5
 
 0. About.
    CL-STORE is an portable serialization package which 
@@ -34,8 +34,8 @@
    The two main entry points are 
     - cl-store:store (obj place &optional (backend *default-backend*)) i
           => obj
-       Where place is a path designator, stream or socket and
-       backend is one of the registered backend.
+       Where place is a path designator or stream and
+       backend is one of the registered backends.
 
     - cl-store:restore (place &optional (backend *default-backend*)) 
           => restored-obj
@@ -81,6 +81,11 @@
    Two backends are in releases now, a default backend which is much
    what cl-store used to be (pre 0.2) and an xml backend which writes out
    xml to character streams. 
+
+   NOTE: As of 0.2.5 the xml backend isn't actively being developed.
+   It's turning out to more of a pain than it's worth. It is now 
+   only there as an example.
+
    Store and Restore now take an optional backend argument which 
    currently can be one of *default-backend* or *xml-backend*. 
 
@@ -90,7 +95,7 @@
 
  
 5. Issues
-   There are a number of issues with CL-STORE as it stands (0.2).
+   There are a number of issues with CL-STORE as it stands (0.2.5).
    
    - Functions, closures and anything remotely funcallable is unserializable.
    - MOP classes are largely unsupported at the moment.


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.8 cl-store/cl-store.asd:1.9
--- cl-store/cl-store.asd:1.8	Mon Sep 27 13:24:18 2004
+++ cl-store/cl-store.asd	Fri Oct  1 10:49:46 2004
@@ -39,7 +39,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.2.3"
+  :version "0.2.5"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.6 cl-store/default-backend.lisp:1.7
--- cl-store/default-backend.lisp:1.6	Mon Sep 27 13:24:18 2004
+++ cl-store/default-backend.lisp	Fri Oct  1 10:49:46 2004
@@ -46,7 +46,11 @@
 (defconstant +array-code+ (register-code 19 'array))
 (defconstant +simple-vector-code+ (register-code 20 'simple-vector))
 (defconstant +package-code+ (register-code 21 'package))
-(defconstant +function-code+ (register-code 22 'function))
+
+;; Used by lispworks
+(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity))
+(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity))
+  
 
 ;; setups for type code mapping
 (defun output-type-code (code stream)
@@ -148,6 +152,7 @@
 ;; Is integer-decode-float the Right Thing, or should we 
 ;; be using something like sb-kernel:single-float-bits
 ;; and sb-kernel:make-single-float
+#-lispworks
 (defstore-cl-store (obj float stream)
   (output-type-code +float-code+ stream)    
   (multiple-value-bind (significand exponent sign)
@@ -158,11 +163,10 @@
     (store-object sign stream)))
 
 (defrestore-cl-store (float stream)
-  (let ((type (get-float-type (read-byte stream)))
-        (significand (restore-object stream))
-        (exponent (restore-object stream))
-        (sign (restore-object stream)))
-    (float (* (* significand (* 1.0d0 (expt 2 exponent))) sign) type)))
+  (float (* (get-float-type (read-byte stream))
+            (* (restore-object stream)
+               (* 1.0d0 (expt 2 (restore-object stream))))
+            (restore-object stream))))
 
 ;; ratio
 (defstore-cl-store (obj ratio stream)
@@ -178,22 +182,18 @@
   (output-type-code +character-code+ stream)    
   (store-object (char-code obj) stream))
 
-
 (defrestore-cl-store (character stream)
   (code-char (restore-object stream)))
 
 ;; complex
 (defstore-cl-store (obj complex stream)
   (output-type-code +complex-code+ stream)    
-  (let ((real (realpart obj))
-        (imag (imagpart obj)))
-    (store-object real stream)
-    (store-object imag stream)))
+  (store-object (realpart obj) stream)
+  (store-object (imagpart obj) stream))
 
 (defrestore-cl-store (complex stream)
-  (let ((real (restore-object stream))
-        (imag (restore-object stream)))
-    (complex real imag)))
+  (complex (restore-object stream)
+           (restore-object stream)))
 
 ;; symbols
 (defstore-cl-store (obj symbol stream)
@@ -208,7 +208,6 @@
   (let ((package (restore-simple-standard-string stream))
         (name (restore-simple-standard-string stream)))
     (values (intern name package))))
-
 
 ;; lists
 (defstore-cl-store (obj cons stream)


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.5 cl-store/tests.lisp:1.6
--- cl-store/tests.lisp:1.5	Mon Aug 30 17:10:20 2004
+++ cl-store/tests.lisp	Fri Oct  1 10:49:46 2004
@@ -61,6 +61,13 @@
 (deftestit double-float.5 most-positive-double-float)
 (deftestit double-float.6 most-negative-double-float)
 
+;; infinite floats
+#+lispworks
+(deftestit infinite-float.1 cl-store::+negative-infinity+)
+#+lispworks
+(deftestit infinite-float.2 cl-store::+positive-infinity+)
+
+
 ;; characters
 (deftestit char.1 #\Space)
 (deftestit char.2 #\f )
@@ -426,7 +433,7 @@
 
 (defclass random-obj () ((size :accessor size :initarg :size)))
 
-(defvar *random-obj-code* (register-code 22 'random-obj))
+(defvar *random-obj-code* (register-code 100 'random-obj))
 
 (defstore-cl-store (obj random-obj buff)
   (output-type-code *random-obj-code* buff)
@@ -452,9 +459,6 @@
 (defun run-tests ()
   (format t "~&RUNNING TESTS USING CL-STORE-BACKEND~%")
   (with-backend (cl-store)
-    (regression-test:do-tests))
-  (format t "~&RUNNING TESTS USING XML-BACKEND~%")
-  (with-backend (xml)
     (regression-test:do-tests))
   (when (probe-file *test-file*)
     (delete-file *test-file*)))




From sross at common-lisp.net  Fri Oct  1 08:49:50 2004
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 01 Oct 2004 10:49:50 +0200
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp 
Message-ID: <E1CDJ6s-0005B5-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2004-10-01

Date: Fri Oct  1 10:49:47 2004
Author: sross

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.1 cl-store/lispworks/custom.lisp:1.2
--- cl-store/lispworks/custom.lisp:1.1	Mon Aug 30 17:10:23 2004
+++ cl-store/lispworks/custom.lisp	Fri Oct  1 10:49:47 2004
@@ -3,7 +3,54 @@
 
 (in-package :cl-store)
 
+;; custom support for infinite floats from Alain Picard.
+(defconstant +positive-infinity+ (expt most-positive-double-float 2))
+(defconstant +negative-infinity+ (expt most-negative-double-float 3))
 
+(defun positive-infinity-p (number)
+  (> number most-positive-double-float))
+
+(defun negative-infinity-p (number)
+  (< number most-negative-double-float))
+
+;; Attempt at fixing broken storing infinity problem
+(defstore-cl-store (obj float stream)
+  (block body
+    (let (significand exponent sign)
+      (handler-bind ((simple-error
+                      #'(lambda (err)
+                          (declare (ignore err))
+                          (cond
+                            ((positive-infinity-p obj)
+                             (output-type-code +positive-infinity-code+ stream)
+                             (return-from body)) ; success
+                            ((negative-infinity-p obj)
+                             (output-type-code +negative-infinity-code+ stream)
+                             (return-from body)) ; success
+                            (t
+                             ;; Unclear what _other_ sort of error we can
+                             ;; get by failing to decode a float, but,
+                             ;; anyway, let the caller handle them...
+                             nil)))))
+        (multiple-value-setq (significand exponent sign)
+          (integer-decode-float obj))
+        (output-type-code +float-code+ stream)
+        (write-byte (float-type obj) stream)
+        (store-object significand stream)
+        (store-object exponent stream)
+        (store-object sign stream)))))
+
+ 
+(defrestore-cl-store (negative-infinity stream)
+  (declare (ignore stream))
+  +negative-infinity+)
+
+(defrestore-cl-store (positive-infinity stream)
+  (declare (ignore stream))
+  +positive-infinity+)
+
+
+;; Custom structure storing from Alain Picard.
 (defstore-cl-store (obj structure-object stream)
   (output-type-code +structure-object-code+ stream)
   (let* ((slot-names (structure:structure-class-slot-names (class-of obj))))




From sross at common-lisp.net  Wed Oct  6 13:48:40 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 15:48:40 +0200
Subject: [cl-store-cvs] CVS update: Directory change: cl-store/doc/html
Message-ID: <E1CFC9o-0000yD-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html
In directory common-lisp.net:/tmp/cvs-serv3727/doc/html

Log Message:
Directory /project/cl-store/cvsroot/cl-store/doc/html added to the repository

Date: Wed Oct  6 15:48:40 2004
Author: sross
New directory cl-store/doc/html added



From sross at common-lisp.net  Wed Oct  6 13:52:13 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 15:52:13 +0200
Subject: [cl-store-cvs] CVS update: Directory change:
	cl-store/doc/html/CL-STORE
Message-ID: <E1CFCDF-0000yZ-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE
In directory common-lisp.net:/tmp/cvs-serv3749/CL-STORE

Log Message:
Directory /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE added to the repository

Date: Wed Oct  6 15:52:13 2004
Author: sross
New directory cl-store/doc/html/CL-STORE added



From sross at common-lisp.net  Wed Oct  6 13:52:13 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 15:52:13 +0200
Subject: [cl-store-cvs] CVS update: Directory change:
	cl-store/doc/html/CL-STORE-XML
Message-ID: <E1CFCDF-0000yj-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE-XML
In directory common-lisp.net:/tmp/cvs-serv3749/CL-STORE-XML

Log Message:
Directory /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE-XML added to the repository

Date: Wed Oct  6 15:52:13 2004
Author: sross
New directory cl-store/doc/html/CL-STORE-XML added



From sross at common-lisp.net  Wed Oct  6 13:52:14 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 15:52:14 +0200
Subject: [cl-store-cvs] CVS update: Directory change: cl-store/doc/html/icons
Message-ID: <E1CFCDG-0000yr-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html/icons
In directory common-lisp.net:/tmp/cvs-serv3749/icons

Log Message:
Directory /project/cl-store/cvsroot/cl-store/doc/html/icons added to the repository

Date: Wed Oct  6 15:52:13 2004
Author: sross
New directory cl-store/doc/html/icons added



From sross at common-lisp.net  Wed Oct  6 14:41:07 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:07 +0200
Subject: [cl-store-cvs] CVS update: cl-store/cl-store-xml.asd
	cl-store/xml-package.lisp cl-store/xml-tests.lisp
	cl-store/ChangeLog cl-store/README cl-store/backends.lisp
	cl-store/circularities.lisp cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/package.lisp
	cl-store/plumbing.lisp cl-store/tests.lisp
	cl-store/utils.lisp cl-store/xml-backend.lisp 
Message-ID: <E1CFCyZ-0001jo-00@common-lisp.net>

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

Modified Files:
	ChangeLog README backends.lisp circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp xml-backend.lisp 
Added Files:
	cl-store-xml.asd xml-package.lisp xml-tests.lisp 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:04 2004
Author: sross







Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.9 cl-store/ChangeLog:1.10
--- cl-store/ChangeLog:1.9	Fri Oct  1 10:49:46 2004
+++ cl-store/ChangeLog	Wed Oct  6 16:41:02 2004
@@ -1,20 +1,45 @@
-2004-10-01 Sean Ross <sdr at jhb.ucs.co.za>
+2004-10-06 Sean Ross <sross at common-lisp.net>
+	* cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend
+	into it's own package files.
+	* xml-backend.lisp, sbcl/custom-xml.lisp, cmucl/custom-xml.lisp, lispworks/custom-xml.lisp:
+	Added support for infinite floats to sbcl, cmucl and lispworks.
+	* xml-backend.lisp, default-backend.lisp:
+	Fixed floating point contagion warning signalled by clisp.
+	* plumbing.lisp: Changed error handing to signal a store-error or restore-error
+	inside a handler-bind and leave the original error unhandled.
+	* docs/: Rudimentary Documentation.
+	
+2004-10-05 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: New Magic number.
+	* backends.lisp: Changed with-backend to take a variable instead of a backend name.
+	* backends.lisp, plumbing.lisp: Added previous magic number field to backends and
+	an appropriate error if an incompatible magic number is read. 
+	* circularities.lisp, plumbing.lisp: Removed check-stream-element-type.
+	* default-backend.lisp: Added a small optimization for 32 byte integers and
+	support for symbols with unicode strings as names. 
+				
+2004-10-04 Sean Ross <sross at common-lisp.net>
+	* sbcl/custom.lisp: Custom float storing (supports inifinities).
+	* cmucl/custom.lisp: Custom float storing (supports inifinities).
+	* xml-backend.lisp, tests.xml: Deprecated xml-backend.
+	
+2004-10-01 Sean Ross <sross at common-lisp.net>
 	* lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard.
 	* tests.lisp: Infite float tests for lispworks.
 	
-2004-09-27 Sean Ross <sdr at jhb.ucs.co.za>
+2004-09-27 Sean Ross <sross at common-lisp.net>
 	* plumbing.lisp: Slightly nicer error handling (I think).
 	All conditions caught in store and restore are resignalled
 	and rethrown as a store or restore error respectively.
 
-2004-09-01 Sean Ross <sdr at jhb.ucs.co.za>
+2004-09-01 Sean Ross <sross at common-lisp.net>
 	* sbcl/custom.lisp, sbcl/custom-xml.lisp: Custom structure storing.
 	* cmucl/custom.lisp, cmucl/custom-xml.lisp: Custom structure storing.
 	* lispworks/custom.lisp, lispworks/custom-xml.lisp: Custom structure storing
 	for Lispworks from Alain Picard.
 	* test.lisp: Enabled structure tests for Lispworks.
 
-2004-07-29 Sean Ross <sdr at jhb.ucs.co.za>
+2004-07-29 Sean Ross <sross at common-lisp.net>
 	* cl-store.asd: New version (0.2)
 	* sbcl/sockets.lisp: Removed.
 	* store.lisp: Removed.
@@ -27,13 +52,13 @@
 	objects in xml format.
 	* tests.lisp : More and more tests.
 	
-2004-06-04 Sean Ross <sdr at jhb.ucs.co.za>
+2004-06-04 Sean Ross <sross at common-lisp.net>
 	* circularities.lisp: spelling fix.
 	* cl-store.asd: Specialized operation-done-p to stop some errors in asdf.
 	* package.lisp: Imports for openmcl from Robert Sedgewick,
 	Along with extra imports for cmucl.
 
-2004-05-21 Sean Ross <sdr at jhb.ucs.co.za>
+2004-05-21 Sean Ross <sross at common-lisp.net>
 	* store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp, 
 	tests.lisp, utils.lisp, cl-store.asd:
 	   Added ability to specify the type code of an object 
@@ -41,12 +66,12 @@
 	   accessor methods for CLISP when restoring classes.
 	   EQ floats are now restored correctly.
 	
-2004-05-18 Sean Ross <sdr at jhb.ucs.co.za>
+2004-05-18 Sean Ross <sross at common-lisp.net>
 	* store.lisp, fix-clisp.lisp, sbcl/sockets.lisp:
 	Added fix for sbcl to use non-blocking IO when working with sockets.
 	Created directory structure and moved fix-clisp
 
-2004-05-17 Sean Ross <sdr at jhb.ucs.co.za>
+2004-05-17 Sean Ross <sross at common-lisp.net>
 	* store.lisp, fast-io.lisp, circularities.lisp, package.lisp,
 	fix-clisp.lisp, utils.lisp, cl-store.asd, tests.lisp:
 	Initial import


Index: cl-store/README
diff -u cl-store/README:1.7 cl-store/README:1.8
--- cl-store/README:1.7	Fri Oct  1 10:49:46 2004
+++ cl-store/README	Wed Oct  6 16:41:03 2004
@@ -1,7 +1,7 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.2.5
+Version: 0.2.9
 
 0. About.
    CL-STORE is an portable serialization package which 
@@ -23,8 +23,8 @@
    This requires xmls which can be found on http://www.cliki.net and
    is asdf-installable.
   
-   Run (asdf:oos 'asdf:test-op :cl-store) to make sure that
-   everything works. Running these tests will try to 
+   Run (asdf:oos 'asdf:test-op :cl-store) and (asdf:oos 'asdf:test-op :cl-store-xml)  
+   to make sure that everything works. Running these tests will try to 
    load the RT package, which is asdf-installable. 
    If anything breaks drop me a line, see 
    http://www.common-lisp.net/project/cl-store/ for mailing-lists.
@@ -61,7 +61,7 @@
 
     (defclass random-obj () ((a :accessor a :initarg :a)))
 
-    (defvar *random-obj-code* (register-code 22 'random-obj))
+    (defvar *random-obj-code* (register-code 110 'random-obj))
 
     (defstore-cl-store (obj random-obj stream)
       (output-type-code *random-obj-code* stream)
@@ -82,20 +82,17 @@
    what cl-store used to be (pre 0.2) and an xml backend which writes out
    xml to character streams. 
 
-   NOTE: As of 0.2.5 the xml backend isn't actively being developed.
-   It's turning out to more of a pain than it's worth. It is now 
-   only there as an example.
-
    Store and Restore now take an optional backend argument which 
-   currently can be one of *default-backend* or *xml-backend*. 
-
+   currently can be one of *default-backend*, *xml-backend* or 
+   a self defined backend.
+   
    The xml written out is not very human readable.
    I recommend using a tool like tidy <http://tidy.sourceforge.net/>
    to view it in a nice format.
 
  
 5. Issues
-   There are a number of issues with CL-STORE as it stands (0.2.5).
+   There are a number of issues with CL-STORE as it stands (0.2.9).
    
    - Functions, closures and anything remotely funcallable is unserializable.
    - MOP classes are largely unsupported at the moment.
@@ -105,7 +102,7 @@
    - Older cmucl versions, where (eq 'cl:class 'pcl::class)
      returns nil, cannot store classes obtained using cl:find-class.
      The solution for this is to use pcl::find-class.
-     
+
 
 Enjoy
  Sean.


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.1 cl-store/backends.lisp:1.2
--- cl-store/backends.lisp:1.1	Tue Aug 17 13:12:43 2004
+++ cl-store/backends.lisp	Wed Oct  6 16:41:03 2004
@@ -14,12 +14,14 @@
   (error "~A is a required argument" name))
 
 (defclass backend ()
-  ((name :accessor name :initform "Unknown" :initarg :name)
-   (magic-number :accessor magic-number :initarg :magic-number)
-   (stream-type :accessor stream-type :initarg :stream-type
+  ((name :accessor name :initform "Unknown" :initarg :name :type symbol)
+   (magic-number :accessor magic-number :initarg :magic-number :type integer)
+   (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers
+                      :type integer)
+   (stream-type :accessor stream-type :initarg :stream-type :type symbol
                 :initform (required-arg "stream-type"))
    (restorer-funs :accessor restorer-funs :initform (make-hash-table)
-                  :initarg :restorer-funs))
+                  :initarg :restorer-funs :type hash-table))
   (:documentation "Core class which custom backends must extend"))
 
 (defparameter *registered-backends* nil 
@@ -46,7 +48,7 @@
         , at body))))
 
 (defun get-restore-macro (name)
-  "Return the defrestore-? macros which will be used by a custom backend"
+  "Return the defrestore-? macro which will be used by a custom backend"
   (let ((macro-name (symbolicate 'defrestore- name)))
     `(defmacro ,macro-name ((type place) &body body)
       (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
@@ -64,12 +66,13 @@
     (char 'character)
     (binary 'integer)))
 
-(defun register-backend (name class magic-number stream-type)
+(defun register-backend (name class magic-number stream-type old-magic-numbers)
   (declare (type symbol name))
   (assert (member stream-type '(char binary)))
   (let ((instance (make-instance class
                                  :name name
                                  :magic-number magic-number
+                                 :old-magic-numbers old-magic-numbers
                                  :stream-type (real-stream-type stream-type))))
     (if (assoc name *registered-backends*)
         (cerror "Redefine backend" "Backend is already defined ~A" name)
@@ -84,11 +87,12 @@
 (defun get-class-form (name fields extends)
   `(defclass ,name (,extends)
     ,fields
-    (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)." 
+    (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)."
                              name))))
 
 (defmacro defbackend (name &key (stream-type (required-arg "stream-type"))
-                      (magic-number nil) fields (extends 'backend))
+                      (magic-number nil) fields (extends 'backend) 
+                      (old-magic-numbers nil))
   "Defines a new backend called NAME. Stream type must be either 'char or 'binary. 
 FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will
 be written down stream as verification and checked on restoration.
@@ -99,16 +103,18 @@
     `(eval-when (:compile-toplevel :load-toplevel :execute)
       (prog2 
           ,(get-class-form class-name fields extends)
-          (register-backend ',name ',class-name ,magic-number ,stream-type )
+          (register-backend ',name ',class-name ,magic-number 
+                            ,stream-type ',old-magic-numbers)
         ,(get-store-macro name class-name)
         ,(get-restore-macro name)))))
 
 
-(defmacro with-backend ((backend-name) &body body)
-  "Run BODY with *default-backend* bound to the backend BACKEND-NAME"
-  `(let ((*default-backend* (or (find-backend ',backend-name)
-                                (error "Can't find backend ~A" 
-                                       ',backend-name))))
+(defmacro with-backend (backend &body body)
+  "Run BODY with *default-backend* bound to BACKEND"
+  `(let ((*default-backend* (or (and (typep ,backend 'backend) 
+                                     ,backend)
+                                (error "~A is not a legal backend" 
+                                       ,backend))))
     , at body))
 
 ;; EOF


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.7 cl-store/circularities.lisp:1.8
--- cl-store/circularities.lisp:1.7	Mon Sep 27 13:24:18 2004
+++ cl-store/circularities.lisp	Wed Oct  6 16:41:03 2004
@@ -120,7 +120,6 @@
   "Store OBJ into PLACE. Does the setup for counters and seen values."
   (let ((*stored-counter* 0) 
         (*stored-values* (make-hash-table :test #'eq))) 
-    (check-stream-element-type place backend)
     (store-backend-code place backend)
     (backend-store-object obj place backend)
     obj))
@@ -183,9 +182,8 @@
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*restored-values* (make-hash-table)))
-    (check-stream-element-type place backend)
-    (check-magic-number place backend)
-    (prog1 
+    (prog2 
+        (check-magic-number place backend)
         (backend-restore-object place backend)
       (dolist (fn *need-to-fix*)
         (funcall (the function fn))))))
@@ -198,13 +196,16 @@
               (new-val (funcall (the function reader) place)))
         (funcall (the function reader) place))))
 
-(defun int-sym-or-char-p (fn backend)
-  "Is function FN registered to restore an integer, character or symbol
+
+(defgeneric int-sym-or-char-p (fn backend)
+  (:argument-precedence-order backend fn)
+  (:method ((fn t) (backend t))
+    "Is function FN registered to restore an integer, character or symbol
   in BACKEND."
-  (let ((readers (restorer-funs backend)))
-    (or (eq fn (lookup-reader 'integer readers))
-        (eq fn (lookup-reader 'character readers))
-        (eq fn (lookup-reader 'symbol readers)))))
+    (let ((readers (restorer-funs backend)))
+      (or (eq fn (lookup-reader 'integer readers))
+          (eq fn (lookup-reader 'character readers))
+          (eq fn (lookup-reader 'symbol readers))))))
   
 
 (defun new-val (val)


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.9 cl-store/cl-store.asd:1.10
--- cl-store/cl-store.asd:1.9	Fri Oct  1 10:49:46 2004
+++ cl-store/cl-store.asd	Wed Oct  6 16:41:03 2004
@@ -3,7 +3,8 @@
 (in-package #:cl-user)
 
 (defpackage #:cl-store.system
-  (:use #:cl #:asdf))
+  (:use #:cl #:asdf)
+  (:export #:non-required-file))
 
 
 (in-package #:cl-store.system)
@@ -34,12 +35,11 @@
   (when (probe-file (component-pathname c))
     (call-next-method)))
 
-
 (defsystem cl-store
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.2.5"
+  :version "0.2.9"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"
@@ -52,34 +52,20 @@
                (:file "default-backend" :depends-on ("circularities"))
                (:non-required-file "custom" :depends-on ("default-backend"))))
 
-(defsystem cl-store-xml
-  :name "CL-STORE-XML"
-  :author "Sean Ross <sdr at jhb.ucs.co.za>"
-  :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :description "Xml Backend for cl-store"
-  :licence "MIT"
-  :components ((:file "xml-backend")
-               (:non-required-file "custom-xml" :depends-on ("xml-backend")))
-  :depends-on (:cl-store :xmls))
-
-
 (defmethod perform :after ((o load-op) (c (eql (find-system :cl-store))))
   (provide 'cl-store))
 
-(defmethod perform :after ((o load-op) (c (eql (find-system :cl-store-xml))))
-  (provide 'cl-store-xml))
-
-
 (defmethod perform ((op test-op) (sys (eql (find-system :cl-store))))
   (oos 'load-op :cl-store-tests)
   (oos 'test-op :cl-store-tests))
 
 (defsystem cl-store-tests
-  :depends-on (rt cl-store cl-store-xml)
+  :depends-on (rt cl-store)
   :components ((:file "tests")))
 
 (defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests))))
-  (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS"))
+  (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
+               (symbol-value (find-symbol "*CL-STORE-BACKEND*" "CL-STORE")))
       (error "Test-op Failed.")))
 
 


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.7 cl-store/default-backend.lisp:1.8
--- cl-store/default-backend.lisp:1.7	Fri Oct  1 10:49:46 2004
+++ cl-store/default-backend.lisp	Wed Oct  6 16:41:03 2004
@@ -3,13 +3,7 @@
 
 ;; The cl-store backend. 
 
-;;  functions
-;;  closures (once done add initform, and default-initargs)
-;;  funcallable instances (methods and generic functions)
-;;  add variable *store-methods-with-classes*
-;;  some sort of optimization for bignums
-;;  cater for unicode characters in symbol names
-;;  Other MOP classes.
+;;  DOCUMENTATION
 
 (in-package :cl-store)
 
@@ -17,17 +11,17 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *cl-store-backend*
-    (defbackend cl-store :magic-number 1886611788 :stream-type 'binary
+    (defbackend cl-store :magic-number 1347635532  
+                :stream-type 'binary
+                :old-magic-numbers (1912923 1886611788)
                 :extends resolving-backend
-                :fields ((restorers :accessor restorers :initform
-                                    nil))))
+                :fields ((restorers :accessor restorers :initform nil))))
   (defun register-code (code name)
     (push (cons code name) (restorers *cl-store-backend*))
     code))
 
 ;;  Type code constants
 (defconstant +referrer-code+ (register-code 1 'referrer))
-(defconstant +non-return-code+ (register-code 2 'non-return))
 (defconstant +integer-code+ (register-code 4 'integer))
 (defconstant +simple-string-code+ (register-code 5 'simple-string))
 (defconstant +float-code+ (register-code 6 'float))
@@ -50,7 +44,10 @@
 ;; Used by lispworks
 (defconstant +positive-infinity-code+ (register-code 22 'positive-infinity))
 (defconstant +negative-infinity-code+ (register-code 23 'negative-infinity))
-  
+
+;; new storing for 32 byte ints
+(defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer))
+
 
 ;; setups for type code mapping
 (defun output-type-code (code stream)
@@ -61,7 +58,6 @@
   (read-byte stream))
 
 
-
 ;; get-next-reader needs to return a symbol which will be used by the
 ;; backend to lookup the function that was defined by
 ;; defrestore-cl-store to restore it, or nil if not found. 
@@ -79,19 +75,33 @@
   (make-referrer (read-32-byte stream nil)))
 
 
+;; integers
+;; The theory is that most numbers will fit in 32 bytes 
+;; so we try and cater for them
 
-;; non return only used with standard-classes
-(defun store-non-return (obj stream)
-  (output-type-code +non-return-code+ stream)
-  (store-object obj stream))
-
-(defrestore-cl-store (non-return stream)
-  (restore-object stream)
-  (restore-object stream))
-
+;; We need this for circularity stuff.
+(defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend))
+  (let ((readers (restorer-funs backend)))
+    (or (eq fn (lookup-reader 'integer readers))
+        (eq fn (lookup-reader 'character readers))
+        (eq fn (lookup-reader '32-byte-integer readers))
+        (eq fn (lookup-reader 'symbol readers)))))
 
-;; integers
 (defstore-cl-store (obj integer stream)
+  (if (typep obj '(signed-byte 32))
+      (store-32-byte-integer obj stream)
+      (store-arbitrary-integer obj stream)))
+
+(defun store-32-byte-integer (obj stream)
+  (output-type-code +32-byte-integer-code+ stream)
+  (write-byte (if (minusp obj) 1 0) stream)
+  (store-32-byte (abs obj) stream))
+
+(defrestore-cl-store (32-byte-integer stream)
+  (funcall (if (zerop (read-byte stream)) #'+ #'-)
+           (read-32-byte stream nil)))
+
+(defun store-arbitrary-integer (obj stream)
   (output-type-code +integer-code+ stream)
   (loop for n = (abs obj) then (ash n -32)
         for counter from 0
@@ -149,10 +159,11 @@
   (restore-simple-standard-string stream))
 
 ;; Floats
-;; Is integer-decode-float the Right Thing, or should we 
-;; be using something like sb-kernel:single-float-bits
-;; and sb-kernel:make-single-float
-#-lispworks
+;; SBCL and CMUCL use a different mechanism for dealing
+;; with floats which supports infinities.
+;; Lispworks uses a slightly different version as well
+;; manually handling negative and positive infinity
+#-(or lispworks cmu sbcl)
 (defstore-cl-store (obj float stream)
   (output-type-code +float-code+ stream)    
   (multiple-value-bind (significand exponent sign)
@@ -162,10 +173,11 @@
     (store-object exponent stream)
     (store-object sign stream)))
 
+#-(or cmu sbcl)
 (defrestore-cl-store (float stream)
   (float (* (get-float-type (read-byte stream))
             (* (restore-object stream)
-               (* 1.0d0 (expt 2 (restore-object stream))))
+               (expt 2 (restore-object stream)))
             (restore-object stream))))
 
 ;; ratio
@@ -198,17 +210,16 @@
 ;; symbols
 (defstore-cl-store (obj symbol stream)
   (output-type-code +symbol-code+ stream)    
-  (output-simple-standard-string (package-name (or (symbol-package obj)
-                                                   *package*))
-                                 stream)
-  (output-simple-standard-string (symbol-name obj)
-                                 stream))
+  (store-object (symbol-name obj) stream)
+  (store-object (package-name (or (symbol-package obj) 
+                                  *package*))
+                stream))
 
 (defrestore-cl-store (symbol stream)
-  (let ((package (restore-simple-standard-string stream))
-        (name (restore-simple-standard-string stream)))
-    (values (intern name package))))
+  (values (intern (restore-object stream)
+                  (restore-object stream))))
 
+  
 ;; lists
 (defstore-cl-store (obj cons stream)
   (output-type-code +cons-code+ stream)    
@@ -317,23 +328,28 @@
   (restore-type-object stream))
 
 
-
-
 ;; classes
 (defstore-cl-store (obj standard-class stream)
   (output-type-code +standard-class-code+ stream)
-  (when *store-class-superclasses*
-    (loop for x in (class-direct-superclasses obj) do
-          (when (and x (not (eql x #.(find-class 'standard-object))))
-            (store-non-return x stream))))
-  (store-object (get-class-details obj) stream))
+  (store-object (class-name obj) stream)
+  (store-object (mapcar #'get-slot-details (class-direct-slots obj))
+                stream)
+  (store-object (mapcar (if *store-class-superclasses*
+                            #'identity 
+                            #'class-name)
+                        (remove (find-class 'standard-object)
+                                (class-direct-superclasses obj)))
+                stream)
+  (store-object (type-of obj) stream))
 
 (defrestore-cl-store (standard-class stream)
-  (let* ((vals (restore-object stream))
+  (let* ((class (restore-object stream))
+         (slots (restore-object stream))
+         (supers (restore-object stream))
+         (meta (restore-object stream))
          (keywords '(:direct-slots :direct-superclasses
                      :metaclass))
-         (final (mappend #'list keywords (cdr vals)))
-         (class (car vals)))
+         (final (mappend #'list keywords (list slots supers meta))))
     (cond ((find-class class nil)
            (cond (*nuke-existing-classes*
                   (apply #'ensure-class class final)


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.10 cl-store/package.lisp:1.11
--- cl-store/package.lisp:1.10	Mon Sep 27 13:24:18 2004
+++ cl-store/package.lisp	Wed Oct  6 16:41:03 2004
@@ -3,45 +3,29 @@
 
 (defpackage #:cl-store
   (:use #:cl) 
-  (:export #:backend
-           #:magic-number
-           #:stream-type
-           #:restorer-funs
-           #:restorers
-           #:find-backend
-           #:defbackend
-           #:with-backend
-           #:fix-circularities
-           #:*default-backend*
-           #:*cl-store-backend*
-           #:*current-backend*
-           #:*store-class-slots*
-           #:*nuke-existing-classes*
-           #:*store-class-superclasses*
-           #:cl-store-error
-           #:store-error
-           #:restore-error
-           #:store
-           #:restore
-           #:backend-store
-           #:check-stream-element-type
-           #:store-backend-code
-           #:store-object
-           #:backend-store-object
-           #:get-class-details
-           #:get-array-values
-           #:restore
-           #:backend-restore
-           #:check-magic-number
-           #:get-next-reader
-           #:restore-object
-           #:backend-restore-object
-           #:cl-store
-           #:defstore-cl-store
-           #:defrestore-cl-store
-           #:register-code
-           #:output-type-code
-           #:xml)
+  (:export #:backend #:magic-number #:stream-type #:restorer-funs
+           #:restorers #:resolving-backend #:find-backend #:defbackend
+           #:*restore-counter* #:*need-to-fix* #:*restored-values*
+           #:with-backend #:fix-circularities #:*default-backend*
+           #:*cl-store-backend* #:*current-backend* #:*store-class-slots*
+           #:*nuke-existing-classes* #:*store-class-superclasses*
+           #:cl-store-error #:store-error #:restore-error #:store
+           #:restore #:backend-store #:store-backend-code #:store-object
+           #:backend-store-object #:get-class-details #:get-array-values
+           #:check-stream-element-type #:restore #:backend-restore
+           #:check-magic-number #:get-next-reader #:int-sym-or-char-p
+           #:restore-object #:backend-restore-object #:cl-store
+           #:defstore-cl-store #:defrestore-cl-store #:register-code
+           #:output-type-code #:store-referrer #:resolving-object
+           #:internal-store-object #:setting #:simple-standard-string
+           #:float-type #:get-float-type #:compute-slots
+           #:slot-definition-allocation #:slot-definition-name
+           #:slot-definition-type #:slot-definition-initargs
+           #:slot-definition-readers #:slot-definition-writers
+           #:class-direct-superclasses #:class-direct-slots
+           #:ensure-class #:make-referrer #:setting-hash
+           #:+positive-infinity+ #:+negative-infinity+
+           #:positive-infinity-p #:negative-infinity-p)
   #+sbcl (:import-from #:sb-mop
                        #:slot-definition-name
                        #:slot-value-using-class


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.2 cl-store/plumbing.lisp:1.3
--- cl-store/plumbing.lisp:1.2	Mon Sep 27 13:24:18 2004
+++ cl-store/plumbing.lisp	Wed Oct  6 16:41:03 2004
@@ -22,9 +22,8 @@
 
 ;; conditions
 ;; From 0.2.3 all conditions which are signalled from 
-;; store or restore will be rethrown as store-error and
-;; restore-error respectively. The original condition
-;; is still signalled.
+;; store or restore will signal a store-error or a 
+;; restore-error respectively inside a handler-bind.
 (define-condition cl-store-error (condition)
   ((caused-by :accessor caused-by :initarg :caused-by 
               :initform nil)
@@ -70,18 +69,16 @@
   (:method ((obj t) (place t) &optional (backend *default-backend*))
     "Store OBJ into Stream PLACE using backend BACKEND."
     (let ((*current-backend* backend))
-      (handler-case (backend-store obj place backend)
-        (condition (c) 
-          (signal c)
-          (error (make-condition 'store-error 
-                                 :caused-by c)))))))
+      (handler-bind ((error (lambda (c)
+                              (signal (make-condition 'store-error 
+                                                      :caused-by c)))))
+        (backend-store obj place backend)))))
 
 (defgeneric backend-store (obj place backend)
   (:argument-precedence-order backend place obj)
   (:method ((obj t) (place stream) (backend t))
     "The default. Checks the streams element-type, stores the backend code
      and calls store-object."
-    (check-stream-element-type place backend)
     (store-backend-code place backend)
     (store-object obj place backend)
     obj)
@@ -94,16 +91,6 @@
   (:documentation "Method wrapped by store, override this method for 
     custom behaviour (see circularities.lisp)."))
 
-
-
-(defun check-stream-element-type (stream backend)
-  "Ensure that the stream-element-type of STREAM is compatible with BACKEND."
-  (let ((stream-type (stream-element-type stream))
-        (backend-type (stream-type backend)))
-    (unless (subtypep stream-type backend-type)
-      (store-error  "Streams element type is ~A, backend expecting ~A."
-                    stream-type backend-type))))
-
 (defun store-backend-code (stream backend)
   "Store magic-number of BACKEND, when present, into STREAM."
   (let ((code (magic-number backend)))
@@ -143,10 +130,15 @@
   (:method (place &optional (backend *default-backend*))
     "Entry point for restoring objects (setfable)."
     (let ((*current-backend* backend))
-      (handler-case (backend-restore place backend)
-        (condition (c) (signal c) 
-                   (error (make-condition 'restore-error
-                                          :caused-by c)))))))
+      (handler-bind ((error (lambda (c)
+                              (signal (make-condition 'restore-error
+                                                      :caused-by c)))))
+        (backend-restore place backend)))))
+
+(declaim (inline check-stream-element-type))
+(defun check-stream-element-type (stream)
+  (declare (ignore stream))
+  nil)
   
 (defgeneric backend-restore (place backend)
   (:argument-precedence-order backend place)
@@ -155,7 +147,6 @@
     "Restore the object found in stream PLACE using backend BACKEND.
      Checks stream-element-type and magic-number and 
      invokes backend-restore-object"
-    (check-stream-element-type place backend)
     (check-magic-number place backend)
     (backend-restore-object place backend))
   (:method ((place string) (backend t))
@@ -184,9 +175,13 @@
       (let ((val (ecase (stream-type backend)
                    (integer (read-32-byte stream))
                    (character (retrieve-string-code stream)))))
-        (unless (equal val magic-number)
-          (restore-error "Stream does not contain a stored object for backend ~A."
-                         (name backend)))))))
+        (cond ((eql val magic-number) nil)
+              ((member val (old-magic-numbers backend))
+               (restore-error "Stream contains an object stored with a ~
+incompatible version of backend ~A." (name backend)))
+              (t (restore-error "Stream does not contain a stored object~
+ for backend ~A."
+                                (name backend))))))))
 
 (defun lookup-reader (val readers)
   (gethash val readers))
@@ -232,4 +227,4 @@
              place)))
 
 
-;; EOF
\ No newline at end of file
+;; EOF


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.6 cl-store/tests.lisp:1.7
--- cl-store/tests.lisp:1.6	Fri Oct  1 10:49:46 2004
+++ cl-store/tests.lisp	Wed Oct  6 16:41:04 2004
@@ -6,7 +6,6 @@
 
 (in-package :cl-store-tests)
 
-
 (rem-all-tests)
 (defvar *test-file* "filetest.cls")
 
@@ -14,6 +13,8 @@
   (store val *test-file*)
   (let ((restored (restore *test-file*)))
     (or (and (numberp val) (= val restored))
+        (and (stringp val) (string= val restored))
+        (and (characterp val) (char= val restored))
         (eq val restored)
         (eql val restored)
         (equal val restored)
@@ -30,6 +31,7 @@
 (deftestit integer.4 -2322993)
 (deftestit integer.5 most-positive-fixnum)
 (deftestit integer.6 most-negative-fixnum)
+
 ;; ratios
 (deftestit ratio.1 1/2)
 (deftestit ratio.2 234232/23434)
@@ -62,10 +64,14 @@
 (deftestit double-float.6 most-negative-double-float)
 
 ;; infinite floats
-#+lispworks
-(deftestit infinite-float.1 cl-store::+negative-infinity+)
-#+lispworks
-(deftestit infinite-float.2 cl-store::+positive-infinity+)
+#+(or sbcl cmu lispworks)
+(progn 
+  #+sbcl (sb-int:set-floating-point-modes :traps nil)
+  #+cmu (ext:set-floating-point-modes :traps nil)
+  (deftestit infinite-float.1 (expt most-positive-single-float 3))
+  (deftestit infinite-float.2 (expt most-positive-double-float 3))
+  (deftestit infinite-float.3 (expt most-negative-single-float 3))
+  (deftestit infinite-float.4 (expt most-negative-double-float 3)))
 
 
 ;; characters
@@ -442,23 +448,15 @@
 (defrestore-cl-store (random-obj buff)
   (random (restore-object buff)))
 
-
-(add-xml-mapping "RANDOM-OBJ")
-(defstore-xml (obj random-obj stream)
-  (princ-and-store "RANDOM-OBJ" (size obj) stream))
-
-(defrestore-xml (random-obj stream)
-  (random (restore-first stream)))
-
+  
 (deftest custom.1
   (progn (store (make-instance 'random-obj :size 5) *test-file* )
          (typep (restore *test-file*) '(integer 0 4)))
   t)
 
 
-(defun run-tests ()
-  (format t "~&RUNNING TESTS USING CL-STORE-BACKEND~%")
-  (with-backend (cl-store)
+(defun run-tests (backend)
+  (with-backend backend
     (regression-test:do-tests))
   (when (probe-file *test-file*)
     (delete-file *test-file*)))


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.3 cl-store/utils.lisp:1.4
--- cl-store/utils.lisp:1.3	Tue Aug 17 13:12:43 2004
+++ cl-store/utils.lisp	Wed Oct  6 16:41:04 2004
@@ -6,7 +6,6 @@
 (declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 
-
 (defmacro aif (test then &optional else)
   `(let ((it ,test))
     (if it ,then ,else)))
@@ -30,18 +29,6 @@
         :readers (slot-definition-readers slot-definition)
         :type (slot-definition-type slot-definition)
         :writers (slot-definition-writers slot-definition)))
-
-(defun get-class-details (x)
-  "Return a list of class details which can be 
-   used as arguments to ensure-class"
-  (list (class-name x)
-        ;; can't use this value either (see get-slot-details)
-        ;;(class-direct-default-initargs x)
-        (mapcar #'get-slot-details (class-direct-slots x))
-        (mapcar #'class-name
-                (class-direct-superclasses x))
-        (type-of x)))
-
 
 (defmacro awhen (test &body body)
   `(aif ,test


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.3 cl-store/xml-backend.lisp:1.4
--- cl-store/xml-backend.lisp:1.3	Mon Aug 30 17:10:20 2004
+++ cl-store/xml-backend.lisp	Wed Oct  6 16:41:04 2004
@@ -1,14 +1,10 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;; See the file LICENCE for licence information.
 
-(in-package :cl-store)
+(in-package :cl-store-xml)
 
 (declaim (optimize (speed 3) (safety 0) (debug 0)))
 
-(export '(*xml-backend* xml-backend defstore-xml defrestore-xml princ-and-store
-          princ-xml restore-first with-tag first-child second-child get-child
-          add-xml-mapping))
-
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *xml-backend*
     (defbackend xml :stream-type 'char :extends resolving-backend)))
@@ -41,6 +37,15 @@
 (add-xml-mapping "SIMPLE-VECTOR")
 (add-xml-mapping "PACKAGE")
 
+;; Used by cmucl and sbcl
+(add-xml-mapping "DOUBLE-FLOAT")
+(add-xml-mapping "SINGLE-FLOAT")
+
+;; Used by lispworks
+(add-xml-mapping "POSITIVE-INFINITY")
+(add-xml-mapping "NEGATIVE-INFINITY")
+
+
 (defmethod get-next-reader ((place list) (backend xml-backend))
   (gethash (car place) *xml-mapping*))
 
@@ -85,7 +90,6 @@
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*restored-values* (make-hash-table)))
-    (check-stream-element-type place backend)
     (let ((obj (backend-restore-object (xmls:parse place) backend)))
       (dolist (fn *need-to-fix*)
         (funcall (the function fn)))
@@ -100,8 +104,6 @@
   (make-referrer (parse-integer (third place))))
 
 
-
-
 ;; integer
 (defstore-xml (obj integer stream)
   (princ-xml "INTEGER" obj stream))
@@ -124,6 +126,7 @@
 
 
 ;; float
+#-(or lispworks sbcl cmu)
 (defstore-xml (obj float stream)
   (with-tag ("FLOAT" stream)
     (multiple-value-bind (signif exp sign) 
@@ -133,9 +136,10 @@
       (princ-and-store "SIGN" sign stream)
       (princ-and-store "TYPE" (float-type obj) stream))))
 
+#-(or sbcl cmu)
 (defrestore-xml (float place)
   (float (* (* (restore-first (get-child "SIGNIFICAND" place))
-               (* 1.0d0 (expt 2 (restore-first (get-child "EXPONENT" place)))))
+               (expt 2 (restore-first (get-child "EXPONENT" place))))
             (restore-first (get-child "SIGN" place)))
          (get-float-type (restore-first (get-child "TYPE" place)))))
 
@@ -445,4 +449,6 @@
 (defrestore-xml (package place)
   (find-package (restore-first place)))
 
+
+(setf *default-backend* *xml-backend*)
 ;; EOF




From sross at common-lisp.net  Wed Oct  6 14:41:12 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:12 +0200
Subject: [cl-store-cvs] CVS update: cl-store/cmucl/.cvsignore
	cl-store/cmucl/custom-xml.lisp cl-store/cmucl/custom.lisp 
Message-ID: <E1CFCye-0001k5-00@common-lisp.net>

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

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



Index: cl-store/cmucl/custom-xml.lisp
diff -u cl-store/cmucl/custom-xml.lisp:1.1 cl-store/cmucl/custom-xml.lisp:1.2
--- cl-store/cmucl/custom-xml.lisp:1.1	Mon Aug 30 17:10:22 2004
+++ cl-store/cmucl/custom-xml.lisp	Wed Oct  6 16:41:07 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)
@@ -11,6 +11,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" (kernel::single-float-bits obj)
+                     stream)))
+
+(defrestore-xml (single-float stream)
+  (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" (kernel::double-float-high-bits obj)
+                     stream)
+    (princ-and-store "LOW-BITS" (kernel::double-float-low-bits obj)
+                     stream)))
+
+(defrestore-xml (double-float stream)
+  (kernel::make-double-float (restore-first (get-child "HIGH-BITS" stream))
+                             (restore-first (get-child "LOW-BITS" stream))))
          
 
 ;; EOF


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




From sross at common-lisp.net  Wed Oct  6 14:41:13 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:13 +0200
Subject: [cl-store-cvs] CVS update: cl-store/doc/index.html
	cl-store/doc/style.css 
Message-ID: <E1CFCyf-0001kJ-00@common-lisp.net>

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

Added Files:
	index.html style.css 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:12 2004
Author: sross







From sross at common-lisp.net  Wed Oct  6 14:41:30 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:30 +0200
Subject: [cl-store-cvs] CVS update: cl-store/doc/html/albert.css
	cl-store/doc/html/book.xml
	cl-store/doc/html/classxcl-storexbackend.html
	cl-store/doc/html/classxcl-storexresolving-backend.html
	cl-store/doc/html/global-index.xml
	cl-store/doc/html/globalindex.html cl-store/doc/html/index.html
	cl-store/doc/html/indexreference.html
	cl-store/doc/html/packagexcl-store-xml.html
	cl-store/doc/html/packagexcl-store.html
	cl-store/doc/html/packagexcl-storexcontent.html
	cl-store/doc/html/packagexcl-storexvariables.html
	cl-store/doc/html/packagexcontentxcl-store-xml.html
	cl-store/doc/html/packagexcontentxcl-store.html 
Message-ID: <E1CFCyw-0001kx-00@common-lisp.net>

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

Added Files:
	albert.css book.xml classxcl-storexbackend.html 
	classxcl-storexresolving-backend.html global-index.xml 
	globalindex.html index.html indexreference.html 
	packagexcl-store-xml.html packagexcl-store.html 
	packagexcl-storexcontent.html packagexcl-storexvariables.html 
	packagexcontentxcl-store-xml.html 
	packagexcontentxcl-store.html 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:13 2004
Author: sross































From sross at common-lisp.net  Wed Oct  6 14:41:32 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:32 +0200
Subject: [cl-store-cvs] CVS update: cl-store/doc/html/CL-STORE/BACKEND.xml
	cl-store/doc/html/CL-STORE/RESOLVING-BACKEND.xml
	cl-store/doc/html/CL-STORE/contentlist.xml 
Message-ID: <E1CFCyy-0001lH-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE
In directory common-lisp.net:/tmp/cvs-serv6638/doc/html/CL-STORE

Added Files:
	BACKEND.xml RESOLVING-BACKEND.xml contentlist.xml 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:30 2004
Author: sross









From sross at common-lisp.net  Wed Oct  6 14:41:33 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:33 +0200
Subject: [cl-store-cvs] CVS update:
	cl-store/doc/html/CL-STORE-XML/contentlist.xml 
Message-ID: <E1CFCyz-0001lT-00@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/doc/html/CL-STORE-XML
In directory common-lisp.net:/tmp/cvs-serv6638/doc/html/CL-STORE-XML

Added Files:
	contentlist.xml 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:32 2004
Author: sross





From sross at common-lisp.net  Wed Oct  6 14:41:40 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:40 +0200
Subject: [cl-store-cvs] CVS update: cl-store/doc/html/icons/README
	cl-store/doc/html/icons/exported.png
	cl-store/doc/html/icons/gnome_down.png
	cl-store/doc/html/icons/gnome_home.png
	cl-store/doc/html/icons/gnome_index.png
	cl-store/doc/html/icons/gnome_left.png
	cl-store/doc/html/icons/gnome_no.png
	cl-store/doc/html/icons/gnome_right.png
	cl-store/doc/html/icons/gnome_up.png
	cl-store/doc/html/icons/gnome_yes.png
	cl-store/doc/html/icons/internal.png 
Message-ID: <E1CFCz6-0001m2-00@common-lisp.net>

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

Added Files:
	README exported.png gnome_down.png gnome_home.png 
	gnome_index.png gnome_left.png gnome_no.png gnome_right.png 
	gnome_up.png gnome_yes.png internal.png 
Log Message:
Changelog 2004-10-06
Date: Wed Oct  6 16:41:37 2004
Author: sross

























From sross at common-lisp.net  Wed Oct  6 14:41:45 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:45 +0200
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/.cvsignore
	cl-store/lispworks/custom-xml.lisp 
Message-ID: <E1CFCzB-0001mJ-00@common-lisp.net>

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

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



Index: cl-store/lispworks/custom-xml.lisp
diff -u cl-store/lispworks/custom-xml.lisp:1.1 cl-store/lispworks/custom-xml.lisp:1.2
--- cl-store/lispworks/custom-xml.lisp:1.1	Mon Aug 30 17:10:23 2004
+++ cl-store/lispworks/custom-xml.lisp	Wed Oct  6 16:41:40 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)
   (with-tag ("STRUCTURE-OBJECT" stream)
@@ -23,4 +23,35 @@
                    (restore-first (get-child "VALUE" slot))))))))
 
 
-;; EOF
\ No newline at end of file
+
+(defstore-xml (obj float stream)
+  (block body
+    (handler-bind ((simple-error
+                    #'(lambda (err)
+                        (declare (ignore err))
+                        (cond
+                         ((positive-infinity-p obj)
+                          (with-tag ("POSITIVE-INFINITY" stream))
+                          (return-from body)) 
+                         ((negative-infinity-p obj)
+                          (with-tag ("NEGATIVE-INFINITY" stream))
+                          (return-from body))
+                         (t nil)))))
+        (multiple-value-bind (signif exp sign) 
+            (integer-decode-float obj)
+          (with-tag ("FLOAT" stream)
+            (princ-and-store "SIGNIFICAND" signif stream)
+            (princ-and-store "EXPONENT" exp stream)
+            (princ-and-store "SIGN" sign stream)
+            (princ-and-store "TYPE" (float-type obj) stream))))))
+
+(defrestore-xml (positive-infinity stream)
+  (declare (ignore stream))
+  +positive-infinity+)
+
+(defrestore-xml (negative-infinity stream)
+  (declare (ignore stream))
+  +negative-infinity+)
+
+
+;; EOF




From sross at common-lisp.net  Wed Oct  6 14:41:47 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 06 Oct 2004 16:41:47 +0200
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/.cvsignore
	cl-store/sbcl/custom-xml.lisp cl-store/sbcl/custom.lisp 
Message-ID: <E1CFCzD-0001mZ-00@common-lisp.net>

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




From sross at common-lisp.net  Wed Oct 13 12:36:03 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 13 Oct 2004 14:36:03 +0200
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/README
	cl-store/circularities.lisp cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/package.lisp
	cl-store/plumbing.lisp cl-store/tests.lisp
	cl-store/utils.lisp cl-store/xml-backend.lisp 
Message-ID: <E1CHiMN-0002jx-00@common-lisp.net>

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

Modified Files:
	ChangeLog README circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp xml-backend.lisp 
Log Message:
Changelogs 2004-10-07 to 2004-10-13
Date: Wed Oct 13 14:35:58 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.10 cl-store/ChangeLog:1.11
--- cl-store/ChangeLog:1.10	Wed Oct  6 16:41:02 2004
+++ cl-store/ChangeLog	Wed Oct 13 14:35:57 2004
@@ -1,3 +1,23 @@
+2004-10-13 Sean Ross <sross at common-lisp.net>
+	* cl-store.asd: New Version (0.3)
+	* circularities.lisp, default-backend.lisp, xml-backend.lisp:
+	Changed referrer representation to a structure.
+	Removed cl-store-referrer package.
+	
+2004-10-12 Sean Ross <sross at common-lisp.net>
+	* lispworks/custom.lisp, lispworks/custom-xml.lisp, default-backend.lisp: 
+	Added support for NaN floats.
+	* tests.lisp: Test NaN floats, Test multiple values.
+	* default-backend.lisp: fix typo which broke clisp support.
+	
+2004-10-11 Sean Ross <sross at common-lisp.net>
+	* default-backend: Added multiple-value-store.
+	* xml-backend: Added support for multiple return values.
+	
+2004-10-07 Sean Ross <sross at common-lisp.net>
+	* circularities.lisp: Added support for multiple return values from
+	functions defined with defrestore-?.
+	
 2004-10-06 Sean Ross <sross at common-lisp.net>
 	* cl-store-xml.asd, xml-package.lisp, xml-tests.lisp: Moved the xml backend
 	into it's own package files.
@@ -25,7 +45,7 @@
 	
 2004-10-01 Sean Ross <sross at common-lisp.net>
 	* lispworks/custom.lisp: Lispworks support for inifinite floats from Alain Picard.
-	* tests.lisp: Infite float tests for lispworks.
+	* tests.lisp: Infinite float tests for lispworks.
 	
 2004-09-27 Sean Ross <sross at common-lisp.net>
 	* plumbing.lisp: Slightly nicer error handling (I think).


Index: cl-store/README
diff -u cl-store/README:1.8 cl-store/README:1.9
--- cl-store/README:1.8	Wed Oct  6 16:41:03 2004
+++ cl-store/README	Wed Oct 13 14:35:57 2004
@@ -1,12 +1,12 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.2.9
+Version: 0.3
 
 0. About.
    CL-STORE is an portable serialization package which 
    should give you the ability to store all common-lisp
-   data types (well not all yet) into files, streams or whatever.   
+   data types (well not all yet) into streams.
 
 
 1. Installation.
@@ -31,20 +31,29 @@
   
 
 2. Usage
-   The two main entry points are 
-    - cl-store:store (obj place &optional (backend *default-backend*)) i
+   The main entry points are 
+    - [Function] cl-store:store (obj place &optional (backend *default-backend*)) i
           => obj
        Where place is a path designator or stream and
        backend is one of the registered backends.
 
-    - cl-store:restore (place &optional (backend *default-backend*)) 
-          => restored-obj
+    - [Function] cl-store:restore (place &optional (backend *default-backend*)) 
+          => restored-objects
        Where place and backend is as above.
 
+    - [Macro] cl-store:multiple-value-store (values-form place &optional (backend *default-backend*))
+          => objects
+       Stores all the values returned by VALUES-FORM into place as per cl-store:store.
+    
     - cl-store:restore is setfable, which I think makes
       for a great serialized hit counter.
       eg. (incf (restore place))
+
   
+    NOTE.
+     All errors signalled within store and restore can 
+     be handled by catching store-error and restore-error respectively.
+   
 
 3. Extending 
    CL-STORE is more or less extensible. Using defstore-<backend-name>
@@ -92,7 +101,7 @@
 
  
 5. Issues
-   There are a number of issues with CL-STORE as it stands (0.2.9).
+   There are a number of issues with CL-STORE as it stands.
    
    - Functions, closures and anything remotely funcallable is unserializable.
    - MOP classes are largely unsupported at the moment.


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.8 cl-store/circularities.lisp:1.9
--- cl-store/circularities.lisp:1.8	Wed Oct  6 16:41:03 2004
+++ cl-store/circularities.lisp	Wed Oct 13 14:35:57 2004
@@ -61,7 +61,7 @@
     `(macrolet ((setting (place getting)
                  (let ((setf-place (get-setf-place place ',obj)))
                    `(let ((,',value ,getting))
-                     (if (referrerp ,',value)
+                     (if (referrer-p ,',value)
                          (push (lambda ()
                                  (setf ,setf-place
                                        (referred-value ,',value 
@@ -70,13 +70,13 @@
                          (setf ,setf-place ,',value)))))
                 (setting-hash (getting-key getting-place)
                  `(let ((,',key ,getting-key))
-                   (if (referrerp ,',key)
+                   (if (referrer-p ,',key)
                        (let ((,',value ,getting-place))
                          (push (lambda () 
                                  (setf (gethash 
                                         (referred-value ,',key *restored-values*)
                                         ,',obj)
-                                       (if (referrerp ,',value)
+                                       (if (referrer-p ,',value)
                                            (referred-value ,',value 
                                                            *restored-values*)
                                            ,',value)))
@@ -86,27 +86,14 @@
         , at body
         ,obj))))
 
-(defun referrerp (val)
-  "Is val a referrer?"
-  (and (symbolp val)
-       (eq (symbol-package val) #.(find-package :cl-store-referrers))
-       (equal (subseq (symbol-name val) 0 11)
-              *referrer-string*)))
+(defstruct referrer 
+  val)
 
 (defun referred-value (referrer hash)
   "Return the value REFERRER is meant to be by looking in HASH."
-  (gethash (read-from-string (subseq (symbol-name referrer) 11))
+  (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11))
            hash))
 
-
-(defun make-referrer (x)
-  "Create a new referrer suffixed with X."
-  (declare (type fixnum x))
-  (let ((name (intern (format nil "%%Referrer-~D" x)
-                      :cl-store-referrers)))
-    name))
-
-
 (defclass resolving-backend (backend) 
   ()
   (:documentation "A backend which does the setup for resolving circularities."))
@@ -182,18 +169,25 @@
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*restored-values* (make-hash-table)))
-    (prog2 
-        (check-magic-number place backend)
+    (check-magic-number place backend)
+    (multiple-value-prog1
         (backend-restore-object place backend)
       (dolist (fn *need-to-fix*)
         (funcall (the function fn))))))
 
+;; Change to backend-restore-object to allow support for 
+;; multiple return values.
 (defmethod backend-restore-object ((place t) (backend resolving-backend))
   "Retrieve a object from PLACE, does housekeeping for circularity fixing."
   (let ((reader (find-function-for-type place backend)))
     (if (not (int-sym-or-char-p reader backend))
-        (setf (gethash (incf *restore-counter*) *restored-values*)
-              (new-val (funcall (the function reader) place)))
+        (let ((spot (incf *restore-counter*))
+              (vals (mapcar #'new-val
+                            (multiple-value-list (funcall (the function reader) 
+                                                          place)))))
+          (setf (gethash spot *restored-values*)
+                (car vals))
+          (apply #'values vals))
         (funcall (the function reader) place))))
 
 
@@ -210,7 +204,7 @@
 
 (defun new-val (val)
   "Tries to get a referred value to reduce unnecessary cirularity fixing."
-  (if (referrerp val)
+  (if (referrer-p val)
       (aif (referred-value val *restored-values*)
            it
            val)


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.10 cl-store/cl-store.asd:1.11
--- cl-store/cl-store.asd:1.10	Wed Oct  6 16:41:03 2004
+++ cl-store/cl-store.asd	Wed Oct 13 14:35:57 2004
@@ -39,7 +39,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.2.9"
+  :version "0.3"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.8 cl-store/default-backend.lisp:1.9
--- cl-store/default-backend.lisp:1.8	Wed Oct  6 16:41:03 2004
+++ cl-store/default-backend.lisp	Wed Oct 13 14:35:57 2004
@@ -2,8 +2,7 @@
 ;; See the file LICENCE for licence information.
 
 ;; The cl-store backend. 
-
-;;  DOCUMENTATION
+;; TODO: Change condition storing in lispworks to ignore reporter-function
 
 (in-package :cl-store)
 
@@ -15,13 +14,15 @@
                 :stream-type 'binary
                 :old-magic-numbers (1912923 1886611788)
                 :extends resolving-backend
-                :fields ((restorers :accessor restorers :initform nil))))
+                :fields ((restorers :accessor restorers :initform (make-hash-table)))))
   (defun register-code (code name)
-    (push (cons code name) (restorers *cl-store-backend*))
+    (setf (gethash code (restorers *cl-store-backend*))
+          name)
     code))
 
 ;;  Type code constants
 (defconstant +referrer-code+ (register-code 1 'referrer))
+(defconstant +values-code+ (register-code 2 'values-object))
 (defconstant +integer-code+ (register-code 4 'integer))
 (defconstant +simple-string-code+ (register-code 5 'simple-string))
 (defconstant +float-code+ (register-code 6 'float))
@@ -44,6 +45,7 @@
 ;; Used by lispworks
 (defconstant +positive-infinity-code+ (register-code 22 'positive-infinity))
 (defconstant +negative-infinity-code+ (register-code 23 'negative-infinity))
+(defconstant +float-nan-code+ (register-code 25 'nan-float))
 
 ;; new storing for 32 byte ints
 (defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer))
@@ -62,8 +64,9 @@
 ;; backend to lookup the function that was defined by
 ;; defrestore-cl-store to restore it, or nil if not found. 
 (defmethod get-next-reader ((stream stream) (backend cl-store-backend))
-  (cdr (assoc (read-type-code stream)
-              (restorers backend))))
+  (let ((type-code (read-type-code stream)))
+    (or (gethash type-code (restorers backend))
+        (values nil (format nil "Type ~A" type-code)))))
 
 
 ;; referrer, Required for a resolving backend
@@ -72,7 +75,7 @@
   (store-32-byte ref stream))
 
 (defrestore-cl-store (referrer stream)
-  (make-referrer (read-32-byte stream nil)))
+  (make-referrer :val (read-32-byte stream nil)))
 
 
 ;; integers
@@ -140,7 +143,7 @@
 
 (defun restore-simple-standard-string (stream)
   (let* ((length (read-32-byte stream nil))
-         (res (make-string length)))
+         (res (make-string length #+lispworks :element-type #+lispworks 'character)))
     (dotimes (x length)
       (setf (schar res x) (code-char (read-byte stream))))
     res))
@@ -288,7 +291,7 @@
   (let* ((all-slots (remove-if-not (lambda (x)
                                      (slot-boundp obj (slot-definition-name x)))
                                    (compute-slots (class-of obj))))
-         (slots (if *store-class-slots* 
+         (slots (if *store-class-slots*
                     all-slots
                     (remove-if #'(lambda (x) (eql (slot-definition-allocation x)
                                                   :class))
@@ -353,10 +356,10 @@
     (cond ((find-class class nil)
            (cond (*nuke-existing-classes*
                   (apply #'ensure-class class final)
-                  #+clisp (add-methods-for-class class (second vals)))
+                  #+clisp (add-methods-for-class class slots))
                  (t (find-class class))))
           (t (apply #'ensure-class class final)
-             #+clisp (add-methods-for-class class (second vals))))))
+             #+clisp (add-methods-for-class class slots)))))
 
 ;; built in classes
 (defstore-cl-store (obj built-in-class stream)
@@ -443,4 +446,15 @@
   (find-package (restore-object stream)))
 
 (setf *default-backend* (find-backend 'cl-store))
+
+;; multiple values
+
+(defstore-cl-store (obj values-object stream)
+  (output-type-code +values-code+ stream)
+  (store-object (vals obj) stream))
+
+(defrestore-cl-store (values-object stream)
+  (apply #'values (restore-object stream)))
+
+
 ;; EOF


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.11 cl-store/package.lisp:1.12
--- cl-store/package.lisp:1.11	Wed Oct  6 16:41:03 2004
+++ cl-store/package.lisp	Wed Oct 13 14:35:57 2004
@@ -24,8 +24,8 @@
            #:slot-definition-readers #:slot-definition-writers
            #:class-direct-superclasses #:class-direct-slots
            #:ensure-class #:make-referrer #:setting-hash
-           #:+positive-infinity+ #:+negative-infinity+
-           #:positive-infinity-p #:negative-infinity-p)
+           #:multiple-value-store)
+
   #+sbcl (:import-from #:sb-mop
                        #:slot-definition-name
                        #:slot-value-using-class
@@ -113,10 +113,4 @@
                              #:class-slots
                              #:class-direct-superclasses
                              #:ensure-class))
-
-
-
-;; package used to unclutter cl-store by holding all %referrer symbols.
-(defpackage #:cl-store-referrers)
-
 ;; EOF


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.3 cl-store/plumbing.lisp:1.4
--- cl-store/plumbing.lisp:1.3	Wed Oct  6 16:41:03 2004
+++ cl-store/plumbing.lisp	Wed Oct 13 14:35:58 2004
@@ -24,17 +24,19 @@
 ;; From 0.2.3 all conditions which are signalled from 
 ;; store or restore will signal a store-error or a 
 ;; restore-error respectively inside a handler-bind.
+(defun cl-store-report (condition stream)
+  (aif (caused-by condition)
+       (format stream "~A" it)
+       (apply #'format stream (format-string condition) 
+              (format-args condition))))
+
 (define-condition cl-store-error (condition)
   ((caused-by :accessor caused-by :initarg :caused-by 
               :initform nil)
    (format-string :accessor format-string :initarg :format-string 
                   :initform "Unknown")
    (format-args :accessor format-args :initarg :format-args :initform nil))
-  (:report (lambda (condition stream)
-             (aif (caused-by condition)
-                  (format stream "~A" it)
-                  (apply #'format stream (format-string condition) 
-                         (format-args condition)))))
+  (:report cl-store-report)
   (:documentation "Root cl-store condition"))
 
 (define-condition store-error (cl-store-error)
@@ -164,10 +166,22 @@
     (with-open-file (s place :element-type element-type :direction :input)
       (restore s backend))))
      
+(defclass values-object ()
+  ((vals :accessor vals :initarg :vals))
+  (:documentation "Backends supporting multiple return values
+should define a custom storer and restorer for this class"));
+
+(defmacro multiple-value-store (values-form place 
+                                &optional (backend '*default-backend*))
+  "Store all values returned from VALUES-FORM into PLACE"
+  `(let ((vals (multiple-value-list ,values-form)))
+    (store (make-instance 'values-object :vals vals)
+     ,place ,backend)
+    (apply #'values vals)))
+
 (defun (setf restore) (new-val place)
   (store new-val place))
 
-
 (defun check-magic-number (stream backend)
   "Check to see if STREAM actually contains a stored object for BACKEND."
   (let ((magic-number (magic-number backend)))
@@ -189,7 +203,9 @@
 (defgeneric get-next-reader (place backend)
   (:documentation 
    "Method which must be specialized for BACKEND to return 
-   the next function to restore an object from PLACE.")
+   the next function to restore an object from PLACE.
+   If no reader is found return a second value which will be included 
+   in the error.")
   (:method ((place t) (backend t))
     "The default, throw an error."
     (restore-error "get-next-reader must be specialized for backend ~(~A~)."
@@ -200,15 +216,15 @@
    "Return a function registered with defrestore-? which knows
    how to retrieve an object from PLACE, uses get-next-reader.")
   (:method (place backend)
-    (let* ((val (get-next-reader place backend))
-           (reader (lookup-reader val (restorer-funs backend))))
-      (cond ((and val reader) reader)
-            ((not val) 
-             (restore-error "~A is not registered with backend ~(~A~)."
-                            val (name backend)))
-            ((not reader)
-             (restore-error "No restorer defined for ~A in backend ~(~A~)."
-                            val (name backend)))))))
+    (multiple-value-bind (val info) (get-next-reader place backend)
+      (let ((reader (lookup-reader val (restorer-funs backend))))
+        (cond ((and val reader) reader)
+              ((not val) 
+               (restore-error "~A is not registered with backend ~(~A~)."
+                              (or info "Unknown Type") (name backend)))
+              ((not reader)
+               (restore-error "No restorer defined for ~A in backend ~(~A~)."
+                              val (name backend))))))))
 
 ;; Wrapper for backend-restore-object so we don't have to pass
 ;; a backend object around all the time


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.7 cl-store/tests.lisp:1.8
--- cl-store/tests.lisp:1.7	Wed Oct  6 16:41:04 2004
+++ cl-store/tests.lisp	Wed Oct 13 14:35:58 2004
@@ -71,7 +71,11 @@
   (deftestit infinite-float.1 (expt most-positive-single-float 3))
   (deftestit infinite-float.2 (expt most-positive-double-float 3))
   (deftestit infinite-float.3 (expt most-negative-single-float 3))
-  (deftestit infinite-float.4 (expt most-negative-double-float 3)))
+  (deftestit infinite-float.4 (expt most-negative-double-float 3))
+  (deftestit infinite-float.5 (/ (expt most-positive-single-float 3)
+                                 (expt most-positive-single-float 3)))
+  (deftestit infinite-float.6 (/ (expt most-positive-double-float 3)
+                                 (expt most-positive-double-float 3))))
 
 
 ;; characters
@@ -452,6 +456,19 @@
 (deftest custom.1
   (progn (store (make-instance 'random-obj :size 5) *test-file* )
          (typep (restore *test-file*) '(integer 0 4)))
+  t)
+
+
+(deftest values.1 
+  (progn (multiple-value-store (values 1 2 3) *test-file*)
+         (multiple-value-list (restore *test-file*)))
+  (1 2 3))
+
+(deftest values.2 
+  (let ((string "foo"))
+    (multiple-value-store (values string string) *test-file*)
+    (let ((val (multiple-value-list (restore *test-file*))))
+      (eq (car val) (cadr val))))
   t)
 
 


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.4 cl-store/utils.lisp:1.5
--- cl-store/utils.lisp:1.4	Wed Oct  6 16:41:04 2004
+++ cl-store/utils.lisp	Wed Oct 13 14:35:58 2004
@@ -43,7 +43,7 @@
     (t 0)))
 
 (defun get-float-type (num)
-  (case num
+  (ecase num
     (0 1.0)
     (1 1.0d0)))
 


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.4 cl-store/xml-backend.lisp:1.5
--- cl-store/xml-backend.lisp:1.4	Wed Oct  6 16:41:04 2004
+++ cl-store/xml-backend.lisp	Wed Oct 13 14:35:58 2004
@@ -36,6 +36,7 @@
 (add-xml-mapping "ARRAY")
 (add-xml-mapping "SIMPLE-VECTOR")
 (add-xml-mapping "PACKAGE")
+(add-xml-mapping "VALUES-OBJECT")
 
 ;; Used by cmucl and sbcl
 (add-xml-mapping "DOUBLE-FLOAT")
@@ -44,10 +45,12 @@
 ;; Used by lispworks
 (add-xml-mapping "POSITIVE-INFINITY")
 (add-xml-mapping "NEGATIVE-INFINITY")
+(add-xml-mapping "FLOAT-NAN")
 
 
 (defmethod get-next-reader ((place list) (backend xml-backend))
-  (gethash (car place) *xml-mapping*))
+  (or (gethash (car place) *xml-mapping*)
+      (values nil (format nil "Unknown tag ~A" (car place)))))
 
 ;; required methods and miscellaneous util functions
 (defun princ-xml (tag value stream)
@@ -90,18 +93,19 @@
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*restored-values* (make-hash-table)))
-    (let ((obj (backend-restore-object (xmls:parse place) backend)))
+    (multiple-value-prog1
+        (backend-restore-object (or (xmls:parse place)
+                                    (restore-error "Invalid xml"))
+                                backend)
       (dolist (fn *need-to-fix*)
-        (funcall (the function fn)))
-      obj)))
-
+        (funcall (the function fn))))))
 
 ;; referrer, Required for a resolving backend
 (defmethod store-referrer (ref stream (backend xml-backend))
   (princ-xml "REFERRER" ref stream))
 
 (defrestore-xml (referrer place)
-  (make-referrer (parse-integer (third place))))
+  (make-referrer :val (parse-integer (third place))))
 
 
 ;; integer
@@ -448,6 +452,19 @@
 
 (defrestore-xml (package place)
   (find-package (restore-first place)))
+
+;; multiple values
+
+(defstore-xml (obj cl-store::values-object stream)
+  (with-tag ("VALUES-OBJECT" stream)
+    (dolist (x (cl-store::vals obj))
+      (princ-and-store "VALUE" x stream))))
+
+
+(defrestore-xml (values-object stream)
+  (apply #'values (loop for x in (xmls:node-children stream) 
+                        collect (restore-first x))))
+  
 
 
 (setf *default-backend* *xml-backend*)




From sross at common-lisp.net  Wed Oct 13 12:36:05 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 13 Oct 2004 14:36:05 +0200
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/custom-xml.lisp
	cl-store/lispworks/custom.lisp 
Message-ID: <E1CHiMP-0002kB-00@common-lisp.net>

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

Modified Files:
	custom-xml.lisp custom.lisp 
Log Message:
Changelogs 2004-10-07 to 2004-10-13
Date: Wed Oct 13 14:36:03 2004
Author: sross

Index: cl-store/lispworks/custom-xml.lisp
diff -u cl-store/lispworks/custom-xml.lisp:1.2 cl-store/lispworks/custom-xml.lisp:1.3
--- cl-store/lispworks/custom-xml.lisp:1.2	Wed Oct  6 16:41:40 2004
+++ cl-store/lispworks/custom-xml.lisp	Wed Oct 13 14:36:03 2004
@@ -30,12 +30,15 @@
                     #'(lambda (err)
                         (declare (ignore err))
                         (cond
-                         ((positive-infinity-p obj)
+                         ((cl-store::positive-infinity-p obj)
                           (with-tag ("POSITIVE-INFINITY" stream))
                           (return-from body)) 
-                         ((negative-infinity-p obj)
+                         ((cl-store::negative-infinity-p obj)
                           (with-tag ("NEGATIVE-INFINITY" stream))
                           (return-from body))
+                         ((cl-store::float-nan-p obj)
+                          (with-tag ("FLOAT-NAN" stream))
+                          (return-from body))
                          (t nil)))))
         (multiple-value-bind (signif exp sign) 
             (integer-decode-float obj)
@@ -47,11 +50,14 @@
 
 (defrestore-xml (positive-infinity stream)
   (declare (ignore stream))
-  +positive-infinity+)
+  cl-store::+positive-infinity+)
 
 (defrestore-xml (negative-infinity stream)
   (declare (ignore stream))
-  +negative-infinity+)
+  cl-store::+negative-infinity+)
 
+(defrestore-xml (float-nan stream)
+  (declare (ignore stream))
+  cl-store::+nan-float+)
 
 ;; EOF


Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.2 cl-store/lispworks/custom.lisp:1.3
--- cl-store/lispworks/custom.lisp:1.2	Fri Oct  1 10:49:47 2004
+++ cl-store/lispworks/custom.lisp	Wed Oct 13 14:36:03 2004
@@ -6,6 +6,8 @@
 ;; custom support for infinite floats from Alain Picard.
 (defconstant +positive-infinity+ (expt most-positive-double-float 2))
 (defconstant +negative-infinity+ (expt most-negative-double-float 3))
+(defconstant +nan-float+ (/ (expt most-positive-double-float 2)
+                               (expt most-positive-double-float 2)))
 
 (defun positive-infinity-p (number)
   (> number most-positive-double-float))
@@ -13,6 +15,9 @@
 (defun negative-infinity-p (number)
   (< number most-negative-double-float))
 
+(defun float-nan-p (number)
+  (eql number +nan-float+))
+
 ;; Attempt at fixing broken storing infinity problem
 (defstore-cl-store (obj float stream)
   (block body
@@ -27,6 +32,9 @@
                             ((negative-infinity-p obj)
                              (output-type-code +negative-infinity-code+ stream)
                              (return-from body)) ; success
+                            ((float-nan-p obj)
+                             (output-type-code +float-nan-code+ stream)
+                             (return-from body))
                             (t
                              ;; Unclear what _other_ sort of error we can
                              ;; get by failing to decode a float, but,
@@ -49,6 +57,10 @@
   (declare (ignore stream))
   +positive-infinity+)
 
+(defrestore-cl-store (nan-float stream)
+   (declare (ignore stream))
+   +nan-float+)                     
+
 
 ;; Custom structure storing from Alain Picard.
 (defstore-cl-store (obj structure-object stream)
@@ -72,4 +84,4 @@
               (setting (slot-value slot-name) (restore-object stream)))))
     new-instance))
 
-;; EOF
\ No newline at end of file
+;; EOF