From sross at common-lisp.net  Mon Nov  1 14:30:32 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:30:32 +0100
Subject: [cl-store-cvs] CVS update: 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: <E1COdCa-0006wr-00@common-lisp.net>

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

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 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:30:19 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.11 cl-store/ChangeLog:1.12
--- cl-store/ChangeLog:1.11	Wed Oct 13 14:35:57 2004
+++ cl-store/ChangeLog	Mon Nov  1 15:30:18 2004
@@ -1,3 +1,14 @@
+2004-11-01 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Changed storing of sizes of integers
+	and strings from store-32-bit to store-object. Changed all
+	instances of store-32-byte to store-32-bit. 
+	Added a simple function storing method.
+	* docs/cl-store.texi: New documentation.
+	
+
+2004-10-21 Sean Ross <sross at common-lisp.net>
+	* package.lisp, acl/custom.lisp: Added support for Allegro CL.
+	
 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:


Index: cl-store/README
diff -u cl-store/README:1.9 cl-store/README:1.10
--- cl-store/README:1.9	Wed Oct 13 14:35:57 2004
+++ cl-store/README	Mon Nov  1 15:30:18 2004
@@ -1,36 +1,15 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.3
+Version: 0.3.2
 
 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 streams.
+   See the cl-store manual (docs/cl-store.texi) for more in depth information.
 
-
-1. Installation.
-   The first thing you need is a common-lisp, CL-STORE currently
-   supports SBCL, CMUCL, Lispworks, CLISP and OpenMCL.
- 
-   Hopefully you've asdf-install to install this in which case 
-   all should be fine.
-
-   Otherwise symlink cl-store.asd to somewhere on asdf:*central-registry*
-   and run (asdf:oos 'asdf:load-op :cl-store).
-
-   The xml backend can be loaded with (asdf:oos 'asdf:loaded :cl-store-xml).
-   This requires xmls which can be found on http://www.cliki.net and
-   is asdf-installable.
-  
-   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.
-  
-
-2. Usage
+1. Usage
    The main entry points are 
     - [Function] cl-store:store (obj place &optional (backend *default-backend*)) i
           => obj
@@ -48,70 +27,10 @@
     - 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>
-   and defrestore-<backend-name> allows you to customize the storing 
-   and restoring of  your own classes.
-
-   contrived eg.
-
-    (in-package :cl-user)
-
-    (use-package :cl-store)
-
-    (setf *default-backend* *cl-store-backend*)
-
-    (defclass random-obj () ((a :accessor a :initarg :a)))
-
-    (defvar *random-obj-code* (register-code 110 'random-obj))
-
-    (defstore-cl-store (obj random-obj stream)
-      (output-type-code *random-obj-code* stream)
-      (store-object (a obj) stream))
-
-    (defrestore-cl-store (random-obj stream)
-      (random (restore-object stream)))
-
-    (store (make-instance 'random-obj :a 10) "/tmp/random")
-
-    (restore "/tmp/random")
-    => ; some number from 0 to 9
-
-
-4. Backends
-   CL-STORE now has a concept of backends, suggested by Robert Sedgewick.
-   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. 
-
-   Store and Restore now take an optional backend argument which 
-   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.
-   
-   - Functions, closures and anything remotely funcallable is unserializable.
-   - MOP classes are largely unsupported at the moment.
-   - Structure instances are not supported in MCL, OpenMCL and Clisp.
-   - Structure definitions aren't supported at all.
-   - No documentation.
-   - 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.2 cl-store/backends.lisp:1.3
--- cl-store/backends.lisp:1.2	Wed Oct  6 16:41:03 2004
+++ cl-store/backends.lisp	Mon Nov  1 15:30:18 2004
@@ -7,7 +7,7 @@
 ;; in default-backend.lisp and xml-backend.lisp
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 
 (defun required-arg (name)


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.9 cl-store/circularities.lisp:1.10
--- cl-store/circularities.lisp:1.9	Wed Oct 13 14:35:57 2004
+++ cl-store/circularities.lisp	Mon Nov  1 15:30:18 2004
@@ -19,24 +19,19 @@
 ;; programs according to the Hyperspec(notes in EQ).
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
-(defvar *referrer-string* "%%Referrer-" 
-  "String which will be interned to create a symbol we
-  can recognize as a referrer.")
-
-(defvar *prefix-setters* 
-  '(slot-value aref row-major-aref)
-  "Setfable places which take the object to set before the 
-  rest of the arguments.")
+(defvar *postfix-setters* '(gethash)
+  "Setfable places which take the object to set after
+   the rest of the arguments.")
 
 (defun get-setf-place  (place obj)
   "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*."
   (declare (type (or cons symbol) place))
   (cond ((atom place) `(,place ,obj))
-        ((member (car place) *prefix-setters*)
-         `(,(car place) ,obj ,@(cdr place)))
-        (t `(, at place ,obj))))
+        ((member (car place) *postfix-setters*)
+         `(, at place ,obj))
+        (t `(,(car place) ,obj ,@(cdr place)))))
 
 
 ;; The definitions for setting and setting-hash sits in resolving-object.


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.11 cl-store/cl-store.asd:1.12
--- cl-store/cl-store.asd:1.11	Wed Oct 13 14:35:57 2004
+++ cl-store/cl-store.asd	Mon Nov  1 15:30:18 2004
@@ -14,7 +14,8 @@
    "File containing implementation dependent code which may or may not be there."))
 
 (defun lisp-system-shortname ()
-  #+mcl mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl)
+  #+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl
+  #+allegro :acl)
 
 (defmethod component-pathname ((component non-required-file))
   (let ((pathname (call-next-method))
@@ -39,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.3"
+  :version "0.3.2"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"
@@ -69,4 +70,4 @@
       (error "Test-op Failed.")))
 
 
-;; EOF
\ No newline at end of file
+;; EOF


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.9 cl-store/default-backend.lisp:1.10
--- cl-store/default-backend.lisp:1.9	Wed Oct 13 14:35:57 2004
+++ cl-store/default-backend.lisp	Mon Nov  1 15:30:18 2004
@@ -2,53 +2,58 @@
 ;; See the file LICENCE for licence information.
 
 ;; The cl-store backend. 
-;; TODO: Change condition storing in lispworks to ignore reporter-function
 
 (in-package :cl-store)
 
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *cl-store-backend*
-    (defbackend cl-store :magic-number 1347635532  
+    (defbackend cl-store :magic-number 1347643724
                 :stream-type 'binary
-                :old-magic-numbers (1912923 1886611788)
+                :old-magic-numbers (1912923 1886611788 1347635532)
                 :extends resolving-backend
                 :fields ((restorers :accessor restorers :initform (make-hash-table)))))
-  (defun register-code (code name)
-    (setf (gethash code (restorers *cl-store-backend*))
-          name)
+  (defun register-code (code name &optional (errorp t))
+    (aif (and (gethash code (restorers *cl-store-backend*)) errorp)
+         (error "Code ~A is already defined for ~A." code name)
+         (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))
-(defconstant +ratio-code+ (register-code 7 'ratio))
-(defconstant +character-code+ (register-code 8 'character))
-(defconstant +complex-code+ (register-code 9 'complex))
-(defconstant +symbol-code+ (register-code 10 'symbol))
-(defconstant +cons-code+ (register-code 11 'cons))
-(defconstant +pathname-code+ (register-code 12 'pathname))
-(defconstant +hash-table-code+ (register-code 13 'hash-table))
-(defconstant +standard-object-code+ (register-code 14 'standard-object))
-(defconstant +condition-code+ (register-code 15 'condition))
-(defconstant +structure-object-code+ (register-code 16 'structure-object))
-(defconstant +standard-class-code+ (register-code 17 'standard-class))
-(defconstant +built-in-class-code+ (register-code 18 'built-in-class))
-(defconstant +array-code+ (register-code 19 'array))
-(defconstant +simple-vector-code+ (register-code 20 'simple-vector))
-(defconstant +package-code+ (register-code 21 'package))
+(defconstant +referrer-code+ (register-code 1 'referrer nil))
+(defconstant +values-code+ (register-code 2 'values-object nil))
+(defconstant +integer-code+ (register-code 4 'integer nil))
+(defconstant +simple-string-code+ (register-code 5 'simple-string nil))
+(defconstant +float-code+ (register-code 6 'float nil))
+(defconstant +ratio-code+ (register-code 7 'ratio nil))
+(defconstant +character-code+ (register-code 8 'character nil))
+(defconstant +complex-code+ (register-code 9 'complex nil))
+(defconstant +symbol-code+ (register-code 10 'symbol nil))
+(defconstant +cons-code+ (register-code 11 'cons nil))
+(defconstant +pathname-code+ (register-code 12 'pathname nil))
+(defconstant +hash-table-code+ (register-code 13 'hash-table nil))
+(defconstant +standard-object-code+ (register-code 14 'standard-object nil))
+(defconstant +condition-code+ (register-code 15 'condition nil))
+(defconstant +structure-object-code+ (register-code 16 'structure-object nil))
+(defconstant +standard-class-code+ (register-code 17 'standard-class nil))
+(defconstant +built-in-class-code+ (register-code 18 'built-in-class nil))
+(defconstant +array-code+ (register-code 19 'array nil))
+(defconstant +simple-vector-code+ (register-code 20 'simple-vector nil))
+(defconstant +package-code+ (register-code 21 'package nil))
 
 ;; 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))
+(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity nil))
+(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity nil))
 
-;; new storing for 32 byte ints
-(defconstant +32-byte-integer-code+ (register-code 24 '32-byte-integer))
+;; new storing for 32 bit ints
+(defconstant +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
+
+;; More for lispworks
+(defconstant +float-nan-code+ (register-code 25 'nan-float nil))
+
+(defconstant +function-code+ (register-code 26 'function nil))
 
 
 ;; setups for type code mapping
@@ -72,14 +77,14 @@
 ;; referrer, Required for a resolving backend
 (defmethod store-referrer (ref stream (backend cl-store-backend))
   (output-type-code +referrer-code+ stream)
-  (store-32-byte ref stream))
+  (store-32-bit ref stream))
 
 (defrestore-cl-store (referrer stream)
-  (make-referrer :val (read-32-byte stream nil)))
+  (make-referrer :val (read-32-bit stream nil)))
 
 
 ;; integers
-;; The theory is that most numbers will fit in 32 bytes 
+;; The theory is that most numbers will fit in 32 bits 
 ;; so we try and cater for them
 
 ;; We need this for circularity stuff.
@@ -87,22 +92,26 @@
   (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 '32-bit-integer readers))
         (eq fn (lookup-reader 'symbol readers)))))
 
 (defstore-cl-store (obj integer stream)
   (if (typep obj '(signed-byte 32))
-      (store-32-byte-integer obj stream)
+      (store-32-bit-integer obj stream)
       (store-arbitrary-integer obj stream)))
 
-(defun store-32-byte-integer (obj stream)
-  (output-type-code +32-byte-integer-code+ stream)
+
+
+
+;; Should be 32-bit
+(defun store-32-bit-integer (obj stream)
+  (output-type-code +32-bit-integer-code+ stream)
   (write-byte (if (minusp obj) 1 0) stream)
-  (store-32-byte (abs obj) stream))
+  (store-32-bit (abs obj) stream))
 
-(defrestore-cl-store (32-byte-integer stream)
+(defrestore-cl-store (32-bit-integer stream)
   (funcall (if (zerop (read-byte stream)) #'+ #'-)
-           (read-32-byte stream nil)))
+           (read-32-bit stream nil)))
 
 (defun store-arbitrary-integer (obj stream)
   (output-type-code +integer-code+ stream)
@@ -112,18 +121,18 @@
         until (zerop n)
         do (push n collect)
         finally (progn
-                  (store-32-byte (if (minusp obj)
+                  (store-object (if (minusp obj)
                                     (- counter)
                                     counter)
                                 stream)
                   (dolist (num collect)
-                    (store-32-byte num stream)))))
+                    (store-32-bit num stream)))))
 
 (defrestore-cl-store (integer buff)
-  (let ((count (read-32-byte buff))
+  (let ((count (restore-object buff))
         (result 0))
     (loop repeat (abs count) do
-          (setf result (+ (ash result 32) (read-32-byte buff nil))))
+          (setf result (+ (ash result 32) (read-32-bit buff nil))))
     (if (minusp count)
         (- result)
         result)))
@@ -137,13 +146,14 @@
   `(simple-array standard-char (*)))
 
 (defun output-simple-standard-string (obj stream)
-  (store-32-byte (length obj) stream)
-  (dotimes (x (length obj))
-    (write-byte (char-code (schar obj x)) stream)))
+  (store-object (length obj) stream)
+  (loop for x across obj do
+    (write-byte (char-code x) stream)))
 
 (defun restore-simple-standard-string (stream)
-  (let* ((length (read-32-byte stream nil))
-         (res (make-string length #+lispworks :element-type #+lispworks 'character)))
+  (let* ((length (restore-object stream))
+         (res (make-string length 
+                #+lispworks :element-type #+lispworks 'character)))
     (dotimes (x length)
       (setf (schar res x) (code-char (read-byte stream))))
     res))
@@ -166,7 +176,8 @@
 ;; with floats which supports infinities.
 ;; Lispworks uses a slightly different version as well
 ;; manually handling negative and positive infinity
-#-(or lispworks cmu sbcl)
+;; Allegro uses excl:double-float-to-shorts and friends
+#-(or lispworks cmu sbcl allegro)
 (defstore-cl-store (obj float stream)
   (output-type-code +float-code+ stream)    
   (multiple-value-bind (significand exponent sign)
@@ -176,7 +187,7 @@
     (store-object exponent stream)
     (store-object sign stream)))
 
-#-(or cmu sbcl)
+#-(or cmu sbcl allegro)
 (defrestore-cl-store (float stream)
   (float (* (get-float-type (read-byte stream))
             (* (restore-object stream)
@@ -308,6 +319,7 @@
   (output-type-code +standard-object-code+ stream)    
   (store-type-object obj stream))
 
+#-lispworks
 (defstore-cl-store (obj condition stream)
   (output-type-code +condition-code+ stream)    
   (store-type-object obj stream))
@@ -324,6 +336,7 @@
               (setting (slot-value slot-name) (restore-object stream)))))
     new-instance))
 
+#-lispworks
 (defrestore-cl-store (condition stream)
   (restore-type-object stream))
 
@@ -415,8 +428,8 @@
     res))
 
 
-;; clisp doesn't have the class simple-vector
-#-clisp
+;; clisp and allegro doesn't have the class simple-vector
+#-(or clisp allegro)
 (defstore-cl-store (obj simple-vector stream)
   (output-type-code +simple-vector-code+ stream)
   (let ((size (length obj)))
@@ -424,7 +437,7 @@
     (loop for x across obj do
           (store-object x stream))))
 
-#-clisp
+#-(or clisp allegro)
 (defrestore-cl-store (simple-vector stream)
   (let* ((size (restore-object stream))
          (res (make-array size)))
@@ -445,7 +458,6 @@
 (defrestore-cl-store (package stream)
   (find-package (restore-object stream)))
 
-(setf *default-backend* (find-backend 'cl-store))
 
 ;; multiple values
 
@@ -456,5 +468,22 @@
 (defrestore-cl-store (values-object stream)
   (apply #'values (restore-object stream)))
 
+
+
+;; Function storing hack.
+;; This just stores the function name if we can find it
+;; or signals a store-error.
+(defstore-cl-store (obj function stream)
+  (output-type-code +function-code+ stream)
+  (multiple-value-bind (l cp name) (function-lambda-expression obj) 
+    (declare (ignore l cp))
+    (if (and name (symbolp name))
+        (store-object name stream)
+        (store-error "Unable to determine function name for ~A." obj))))
+
+(defrestore-cl-store (function stream)
+  (fdefinition (restore-object stream)))
+
+(setf *default-backend* (find-backend 'cl-store))
 
 ;; EOF


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.12 cl-store/package.lisp:1.13
--- cl-store/package.lisp:1.12	Wed Oct 13 14:35:57 2004
+++ cl-store/package.lisp	Mon Nov  1 15:30:18 2004
@@ -24,7 +24,8 @@
            #:slot-definition-readers #:slot-definition-writers
            #:class-direct-superclasses #:class-direct-slots
            #:ensure-class #:make-referrer #:setting-hash
-           #:multiple-value-store)
+           #:multiple-value-store #:*postfix-setters* #:caused-by
+           #:store-32-bit #:read-32-bit)
 
   #+sbcl (:import-from #:sb-mop
                        #:slot-definition-name
@@ -112,5 +113,24 @@
                              #:class-direct-slots
                              #:class-slots
                              #:class-direct-superclasses
-                             #:ensure-class))
+                             #:ensure-class)
+  
+  #+allegro (:import-from #:mop
+                          #:slot-definition-name
+                          #:slot-value-using-class
+                          #:slot-boundp-using-class
+                          #:slot-definition-allocation
+                          #:compute-slots
+                          #:slot-definition-initform
+                          #:slot-definition-initargs
+                          #:slot-definition-name
+                          #:slot-definition-readers
+                          #:slot-definition-type
+                          #:slot-definition-writers
+                          #:class-direct-default-initargs
+                          #:class-direct-slots
+                          #:class-direct-superclasses
+                          #:class-slots
+                          #:ensure-class)
+  )
 ;; EOF


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.4 cl-store/plumbing.lisp:1.5
--- cl-store/plumbing.lisp:1.4	Wed Oct 13 14:35:58 2004
+++ cl-store/plumbing.lisp	Mon Nov  1 15:30:18 2004
@@ -5,12 +5,11 @@
 ;; 
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
-
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 (defvar *nuke-existing-classes* nil
   "Do we overwrite existing class definitions on restoration.")
-(defvar *store-class-superclasses* t
+(defvar *store-class-superclasses* nil
   "Whether or not to store the superclasses of a stored class.")
 (defvar *store-class-slots* t
   "Whether or not to serialize slots which are class allocated.")
@@ -99,7 +98,7 @@
     (when code
       (ecase (stream-type backend)
         (character (store-string-code code stream))
-        (integer (store-32-byte code stream))))))
+        (integer (store-32-bit code stream))))))
 
 
 
@@ -147,8 +146,7 @@
   (:documentation "Wrapped by restore. Override this to do custom restoration")
   (:method ((place stream) (backend t))
     "Restore the object found in stream PLACE using backend BACKEND.
-     Checks stream-element-type and magic-number and 
-     invokes backend-restore-object"
+     Checks the magic-number and invokes backend-restore-object"
     (check-magic-number place backend)
     (backend-restore-object place backend))
   (:method ((place string) (backend t))
@@ -187,7 +185,7 @@
   (let ((magic-number (magic-number backend)))
     (when magic-number
       (let ((val (ecase (stream-type backend)
-                   (integer (read-32-byte stream))
+                   (integer (read-32-bit stream nil))
                    (character (retrieve-string-code stream)))))
         (cond ((eql val magic-number) nil)
               ((member val (old-magic-numbers backend))


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.8 cl-store/tests.lisp:1.9
--- cl-store/tests.lisp:1.8	Wed Oct 13 14:35:58 2004
+++ cl-store/tests.lisp	Mon Nov  1 15:30:18 2004
@@ -64,7 +64,7 @@
 (deftestit double-float.6 most-negative-double-float)
 
 ;; infinite floats
-#+(or sbcl cmu lispworks)
+#+(or sbcl cmu lispworks allegro)
 (progn 
   #+sbcl (sb-int:set-floating-point-modes :traps nil)
   #+cmu (ext:set-floating-point-modes :traps nil)
@@ -257,9 +257,10 @@
 
 (deftest condition.2
   (handler-case (car (read-from-string "3"))
-    (type-error (c)
+    (#-allegro type-error #+allegro simple-error (c)
       (store c *test-file*)
-      (typep (restore *test-file*) 'type-error)))
+      (typep (restore *test-file*) 
+             #-allegro 'type-error #+allegro 'simple-error)))
   t)
 
 ;; structure-object
@@ -286,9 +287,8 @@
 
 (deftestit pathname.1 #P"/home/foo")
 (deftestit pathname.2 (make-pathname :name "foo"))
-(deftestit pathname.3 (make-pathname :name "foo" :type "bar"
-                                     #-clisp :device #-clisp "foobar"
-                                     ))
+(deftestit pathname.3 (make-pathname :name "foo" :type "bar"))
+                                      
 
 ;; circular objects
 


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.5 cl-store/utils.lisp:1.6
--- cl-store/utils.lisp:1.5	Wed Oct 13 14:35:58 2004
+++ cl-store/utils.lisp	Mon Nov  1 15:30:18 2004
@@ -3,7 +3,7 @@
 
 ;; Miscellaneous utilities used throughout the package.
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 
 (defmacro aif (test then &optional else)
@@ -48,7 +48,7 @@
     (1 1.0d0)))
 
 
-(defun store-32-byte (obj stream)
+(defun store-32-bit (obj stream)
   "Write OBJ down STREAM as a 32 byte integer."
   (write-byte (ldb (byte 8 0) obj) stream)
   (write-byte (ldb (byte 8 8) obj) stream)
@@ -56,7 +56,7 @@
   (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
 
 
-(defun read-32-byte (buf &optional (signed t))
+(defun read-32-bit (buf &optional (signed t))
   "Read a signed or unsigned byte off STREAM."
   (let ((byte1 (read-byte buf))
         (byte2 (read-byte buf))


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.5 cl-store/xml-backend.lisp:1.6
--- cl-store/xml-backend.lisp:1.5	Wed Oct 13 14:35:58 2004
+++ cl-store/xml-backend.lisp	Mon Nov  1 15:30:18 2004
@@ -117,8 +117,8 @@
 
 ;; simple-string
 (defun xml-dump-simple-string (string place)
-  (princ-xml "SIMPLE-STRING" string place))
-
+  (with-tag ("SIMPLE-STRING" place)
+    (format place "~S" string)))
 
 (defstore-xml (obj string stream)
   (if (typep obj 'simple-standard-string)
@@ -126,7 +126,7 @@
       (xml-dump-array obj stream)))
 
 (defrestore-xml (simple-string place)
-  (third place))
+  (read-from-string (third place)))
 
 
 ;; float
@@ -425,7 +425,7 @@
                        (restore-first value)))))))
 
 
-#-clisp    
+#-(or allegro clisp)
 (defstore-xml (obj simple-vector stream)
   (with-tag ("SIMPLE-VECTOR" stream)
     (princ-and-store "LENGTH" (length obj) stream)
@@ -433,7 +433,7 @@
       (loop for x across obj do
             (princ-and-store "ELEMENT" x stream)))))
 
-#-clisp
+#-(or allegro clisp)
 (defrestore-xml (simple-vector place)
   (let* ((size (restore-first (get-child "LENGTH" place)))
          (res (make-array size)))




From sross at common-lisp.net  Mon Nov  1 14:30:37 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:30:37 +0100
Subject: [cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp 
Message-ID: <E1COdCf-0006xA-00@common-lisp.net>

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

Modified Files:
	fix-clisp.lisp 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:30:32 2004
Author: sross

Index: cl-store/clisp/fix-clisp.lisp
diff -u cl-store/clisp/fix-clisp.lisp:1.3 cl-store/clisp/fix-clisp.lisp:1.4
--- cl-store/clisp/fix-clisp.lisp:1.3	Tue Aug 17 13:12:42 2004
+++ cl-store/clisp/fix-clisp.lisp	Mon Nov  1 15:30:32 2004
@@ -2,7 +2,7 @@
 ;; See the file LICENCE for licence information.
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
 
 ;; this is such a pain.
 




From sross at common-lisp.net  Mon Nov  1 14:30:46 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:30:46 +0100
Subject: [cl-store-cvs] CVS update: cl-store/doc/index.html 
Message-ID: <E1COdCo-0006xl-00@common-lisp.net>

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

Modified Files:
	index.html 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:30:37 2004
Author: sross

Index: cl-store/doc/index.html
diff -u cl-store/doc/index.html:1.1 cl-store/doc/index.html:1.2
--- cl-store/doc/index.html:1.1	Wed Oct  6 16:41:12 2004
+++ cl-store/doc/index.html	Mon Nov  1 15:30:37 2004
@@ -17,8 +17,8 @@
    
  <h2>Documentation</h2>
   <ul>
-   <li>Most details can be found in the <a href="../README">README</a> file.</li>
-   <li><a href="html/index.html">Reference Docs</a> (Courtesy of <a href="http://www.cliki.net/Albert">Albert</a>)</li>
+   <li>Basic details can be found in the <a href="../README">README</a> file.</li>
+   <li><a href="cl-store.texi">Texinfo Manual</a></li>
    <li>List of <a href="../ChangeLog">Changes</a></li>
   </ul>
  




From sross at common-lisp.net  Mon Nov  1 14:31:29 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:31:29 +0100
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: <E1COdDV-0006zg-00@common-lisp.net>

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

Removed 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:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:30:46 2004
Author: sross































From sross at common-lisp.net  Mon Nov  1 14:31:40 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:31:40 +0100
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: <E1COdDg-00070D-00@common-lisp.net>

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

Removed Files:
	BACKEND.xml RESOLVING-BACKEND.xml contentlist.xml 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:31:29 2004
Author: sross









From sross at common-lisp.net  Mon Nov  1 14:31:43 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:31:43 +0100
Subject: [cl-store-cvs] CVS update:
	cl-store/doc/html/CL-STORE-XML/contentlist.xml 
Message-ID: <E1COdDj-00070k-00@common-lisp.net>

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

Removed Files:
	contentlist.xml 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:31:40 2004
Author: sross





From sross at common-lisp.net  Mon Nov  1 14:32:02 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:32:02 +0100
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: <E1COdE2-00072C-00@common-lisp.net>

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

Removed 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:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:31:44 2004
Author: sross

























From sross at common-lisp.net  Mon Nov  1 14:32:08 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:32:08 +0100
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp 
Message-ID: <E1COdE8-00072b-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Removed old documentation, added new docs.

Date: Mon Nov  1 15:32:02 2004
Author: sross

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.3 cl-store/lispworks/custom.lisp:1.4
--- cl-store/lispworks/custom.lisp:1.3	Wed Oct 13 14:36:03 2004
+++ cl-store/lispworks/custom.lisp	Mon Nov  1 15:32:02 2004
@@ -84,4 +84,30 @@
               (setting (slot-value slot-name) (restore-object stream)))))
     new-instance))
 
+
+;; Condition in lispworks have a reporter-function slot
+;; which is sometimes a function (as opposed to a symbol)
+;; Fortunately these slots are class allocated so
+;; we ignore reporter functions and use make-condition
+;; to reconstruct our object.
+(defstore-cl-store (obj condition stream)
+  (output-type-code +condition-code+ stream)    
+  (let ((*store-class-slots* nil))
+    (store-type-object obj stream)))
+
+
+(defrestore-cl-store (condition stream)
+  (let* ((class (find-class (restore-object stream)))
+         (length (restore-object stream))
+         (new-instance (make-condition class)))
+    (loop repeat length do
+          (let ((slot-name (restore-object stream)))
+            ;; slot-names are always symbols so we don't
+            ;; have to worry about circularities
+            (resolving-object new-instance
+              (setting (slot-value slot-name) (restore-object stream)))))
+    new-instance))
+
+
+
 ;; EOF




From sross at common-lisp.net  Mon Nov  1 14:44:20 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:44:20 +0100
Subject: [cl-store-cvs] CVS update: Directory change: cl-store/acl
Message-ID: <E1COdPw-0007An-00@common-lisp.net>

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

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

Date: Mon Nov  1 15:44:20 2004
Author: sross
New directory cl-store/acl added



From sross at common-lisp.net  Mon Nov  1 14:49:01 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:49:01 +0100
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog 
Message-ID: <E1COdUT-0007Pr-00@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:
Added acl and new docs.

Date: Mon Nov  1 15:49:00 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.12 cl-store/ChangeLog:1.13
--- cl-store/ChangeLog:1.12	Mon Nov  1 15:30:18 2004
+++ cl-store/ChangeLog	Mon Nov  1 15:49:00 2004
@@ -3,9 +3,11 @@
 	and strings from store-32-bit to store-object. Changed all
 	instances of store-32-byte to store-32-bit. 
 	Added a simple function storing method.
+	New Magic Number
 	* docs/cl-store.texi: New documentation.
+	* lispworks/custom.lisp: Custom storing for conditions
+	to ignore class allocated slots. 
 	
-
 2004-10-21 Sean Ross <sross at common-lisp.net>
 	* package.lisp, acl/custom.lisp: Added support for Allegro CL.
 	




From sross at common-lisp.net  Mon Nov  1 14:49:02 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:49:02 +0100
Subject: [cl-store-cvs] CVS update: cl-store/acl/custom.lisp 
Message-ID: <E1COdUU-0007Q3-00@common-lisp.net>

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

Added Files:
	custom.lisp 
Log Message:
Added acl and new docs.

Date: Mon Nov  1 15:49:01 2004
Author: sross





From sross at common-lisp.net  Mon Nov  1 14:49:05 2004
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 01 Nov 2004 15:49:05 +0100
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <E1COdUX-0007QH-00@common-lisp.net>

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

Added Files:
	cl-store.texi 
Log Message:
Added acl and new docs.

Date: Mon Nov  1 15:49:04 2004
Author: sross





From sross at common-lisp.net  Wed Nov 10 10:43:24 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 11:43:24 +0100
Subject: [cl-store-cvs] CVS update: 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: <E1CRpwi-0001rv-00@common-lisp.net>

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

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 
Log Message:
Changelog 2004-11-10

Date: Wed Nov 10 11:43:17 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.13 cl-store/ChangeLog:1.14
--- cl-store/ChangeLog:1.13	Mon Nov  1 15:49:00 2004
+++ cl-store/ChangeLog	Wed Nov 10 11:43:16 2004
@@ -1,3 +1,19 @@
+2004-11-10 Sean Ross <sross at common-lisp.net>
+	New Version: 0.3.6 New Magic Number (Breaks backwards compatibility)
+	* default-backend.lisp: Storing for functions and generic functions.
+	* tests.lisp: Tests for functions and GF's.
+	* plumbing.lisp, circularities.lisp, default-backend.lisp: 
+	Optimized int-sym-or-charp.
+	* clisp/fix-clisp.lisp: Added generic-function-name.
+	* package.lisp: Import generic-function-name.
+	* default-backend.lisp: More optimizations for strings and ints.
+		
+2004-11-03 Sean Ross <sross at common-lisp.net>
+	* tests.lisp: Added tests for unicode strings and symbols.
+	* default-backend.lisp: We definitely support unicode now.
+	Added small optimization to stop the size of files from
+	ballooning.
+
 2004-11-01 Sean Ross <sross at common-lisp.net>
 	* default-backend.lisp: Changed storing of sizes of integers
 	and strings from store-32-bit to store-object. Changed all


Index: cl-store/README
diff -u cl-store/README:1.10 cl-store/README:1.11
--- cl-store/README:1.10	Mon Nov  1 15:30:18 2004
+++ cl-store/README	Wed Nov 10 11:43:16 2004
@@ -1,7 +1,7 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.3.2
+Version: 0.3.6
 
 0. About.
    CL-STORE is an portable serialization package which 


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.3 cl-store/backends.lisp:1.4
--- cl-store/backends.lisp:1.3	Mon Nov  1 15:30:18 2004
+++ cl-store/backends.lisp	Wed Nov 10 11:43:16 2004
@@ -7,7 +7,7 @@
 ;; in default-backend.lisp and xml-backend.lisp
 
 (in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
 
 
 (defun required-arg (name)
@@ -45,6 +45,7 @@
         ((,var ,type) ,stream (backend ,',class-name))
         ,(format nil "Definition for storing an object of type ~A with ~
 backend ~A" type ',name)
+;        (declare (optimize (speed 3) (safety 1) (debug 0)))
         , at body))))
 
 (defun get-restore-macro (name)
@@ -52,7 +53,9 @@
   (let ((macro-name (symbolicate 'defrestore- name)))
     `(defmacro ,macro-name ((type place) &body body)
       (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
-        `(flet ((,fn-name (,place) , at body))
+        `(flet ((,fn-name (,place) 
+;                  (declare (optimize (speed 3) (safety 1) (debug 0)))
+                  , at body))
           (let* ((backend (find-backend ',',name))
                  (restorers (restorer-funs backend)))
             (when (gethash ',type restorers)


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.10 cl-store/circularities.lisp:1.11
--- cl-store/circularities.lisp:1.10	Mon Nov  1 15:30:18 2004
+++ cl-store/circularities.lisp	Wed Nov 10 11:43:16 2004
@@ -19,7 +19,7 @@
 ;; programs according to the Hyperspec(notes in EQ).
 
 (in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 (defvar *postfix-setters* '(gethash)
   "Setfable places which take the object to set after
@@ -27,9 +27,8 @@
 
 (defun get-setf-place  (place obj)
   "Return a legal setf form for setting PLACE in OBJ, see *prefix-setters*."
-  (declare (type (or cons symbol) place))
   (cond ((atom place) `(,place ,obj))
-        ((member (car place) *postfix-setters*)
+        ((member (the symbol (car place)) *postfix-setters*)
          `(, at place ,obj))
         (t `(,(car place) ,obj ,@(cdr place)))))
 
@@ -48,52 +47,51 @@
   (declare (ignore getting-key getting-value))
   (error "setting-hash can only be used inside a resolving-object form."))
 
-
 (defmacro resolving-object (create &body body)
   "Execute body attempting to resolve circularities found in 
    form CREATE."
   (with-gensyms (obj value key)
     `(macrolet ((setting (place getting)
-                 (let ((setf-place (get-setf-place place ',obj)))
-                   `(let ((,',value ,getting))
-                     (if (referrer-p ,',value)
-                         (push (lambda ()
-                                 (setf ,setf-place
-                                       (referred-value ,',value 
-                                                       *restored-values*)))
-                               *need-to-fix*)
-                         (setf ,setf-place ,',value)))))
-                (setting-hash (getting-key getting-place)
-                 `(let ((,',key ,getting-key))
-                   (if (referrer-p ,',key)
-                       (let ((,',value ,getting-place))
-                         (push (lambda () 
-                                 (setf (gethash 
-                                        (referred-value ,',key *restored-values*)
-                                        ,',obj)
-                                       (if (referrer-p ,',value)
+                  (let ((setf-place (get-setf-place place ',obj)))
+                    `(let ((,',value ,getting))
+                       (if (referrer-p ,',value)
+                           (push #'(lambda ()
+                                     (setf ,setf-place
                                            (referred-value ,',value 
-                                                           *restored-values*)
-                                           ,',value)))
-                               *need-to-fix*))
-                       (setting (gethash ,',key) ,getting-place)))))
-      (let ((,obj ,create))
-        , at body
-        ,obj))))
+                                                           *restored-values*)))
+                                 *need-to-fix*)
+                           (setf ,setf-place ,',value)))))
+                (setting-hash (getting-key getting-place)
+                  `(let ((,',key ,getting-key))
+                     (if (referrer-p ,',key)
+                         (let ((,',value ,getting-place))
+                           (push #'(lambda () 
+                                     (setf (gethash 
+                                            (referred-value ,',key *restored-values*)
+                                            ,',obj)
+                                           (if (referrer-p ,',value)
+                                               (referred-value ,',value 
+                                                               *restored-values*)
+                                               ,',value)))
+                                 *need-to-fix*))
+                         (setting (gethash ,',key) ,getting-place)))))
+       (let ((,obj ,create))
+         , at body
+         ,obj))))
 
 (defstruct referrer 
   val)
 
 (defun referred-value (referrer hash)
   "Return the value REFERRER is meant to be by looking in HASH."
-  (gethash (referrer-val referrer) ;(read-from-string (subseq (symbol-name referrer) 11))
+  (gethash (referrer-val referrer)
            hash))
 
 (defclass resolving-backend (backend) 
   ()
   (:documentation "A backend which does the setup for resolving circularities."))
 
-(declaim (type fixnum *stored-counter*))
+(declaim (type (or null fixnum) *stored-counter*))
 (defvar *stored-counter*)
 (defvar *stored-values*)
 
@@ -153,7 +151,7 @@
 
 
 ;; Restoration.
-(declaim (type fixnum *restore-counter*))
+(declaim (type (or null fixnum) *restore-counter*))
 (defvar *restore-counter*)
 (defvar *need-to-fix*)
 (defvar *restored-values*)
@@ -170,12 +168,10 @@
       (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))
+  (multiple-value-bind (reader sym) (find-function-for-type place backend)
+    (if (not (int-sym-or-char-p sym backend))
         (let ((spot (incf *restore-counter*))
               (vals (mapcar #'new-val
                             (multiple-value-list (funcall (the function reader) 
@@ -186,16 +182,13 @@
         (funcall (the function reader) place))))
 
 
+
 (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))))))
-  
+    (member fn '(integer character symbol))))
 
 (defun new-val (val)
   "Tries to get a referred value to reduce unnecessary cirularity fixing."


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.12 cl-store/cl-store.asd:1.13
--- cl-store/cl-store.asd:1.12	Mon Nov  1 15:30:18 2004
+++ cl-store/cl-store.asd	Wed Nov 10 11:43:16 2004
@@ -40,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.3.2"
+  :version "0.3.6"
   :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.10 cl-store/default-backend.lisp:1.11
--- cl-store/default-backend.lisp:1.10	Mon Nov  1 15:30:18 2004
+++ cl-store/default-backend.lisp	Wed Nov 10 11:43:16 2004
@@ -5,13 +5,13 @@
 
 (in-package :cl-store)
 
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *cl-store-backend*
-    (defbackend cl-store :magic-number 1347643724
+    (defbackend cl-store :magic-number 1349732684
                 :stream-type 'binary
-                :old-magic-numbers (1912923 1886611788 1347635532)
+                :old-magic-numbers (1912923 1886611788 1347635532 1347643724)
                 :extends resolving-backend
                 :fields ((restorers :accessor restorers :initform (make-hash-table)))))
   (defun register-code (code name &optional (errorp t))
@@ -24,6 +24,7 @@
 ;;  Type code constants
 (defconstant +referrer-code+ (register-code 1 'referrer nil))
 (defconstant +values-code+ (register-code 2 'values-object nil))
+(defconstant +unicode-string-code+ (register-code 3 'unicode-string nil))
 (defconstant +integer-code+ (register-code 4 'integer nil))
 (defconstant +simple-string-code+ (register-code 5 'simple-string nil))
 (defconstant +float-code+ (register-code 6 'float nil))
@@ -54,11 +55,11 @@
 (defconstant +float-nan-code+ (register-code 25 'nan-float nil))
 
 (defconstant +function-code+ (register-code 26 'function nil))
-
+(defconstant +gf-code+ (register-code 27 'generic-function nil))
 
 ;; setups for type code mapping
 (defun output-type-code (code stream)
-  (declare (type (mod 256) code))
+  (declare (type ub32 code))
   (write-byte (ldb (byte 8 0) code) stream))
 
 (defun read-type-code (stream)
@@ -77,43 +78,48 @@
 ;; referrer, Required for a resolving backend
 (defmethod store-referrer (ref stream (backend cl-store-backend))
   (output-type-code +referrer-code+ stream)
-  (store-32-bit ref stream))
+  (dump-int ref stream))
 
 (defrestore-cl-store (referrer stream)
-  (make-referrer :val (read-32-bit stream nil)))
+  (make-referrer :val (undump-int stream)))
 
 
 ;; integers
 ;; The theory is that most numbers will fit in 32 bits 
-;; so we try and cater for them
+;; so we we have a little optimization for it
 
 ;; 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-bit-integer readers))
-        (eq fn (lookup-reader 'symbol readers)))))
+  (member fn '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
-  (if (typep obj '(signed-byte 32))
+  (if (typep obj 'sb32)
       (store-32-bit-integer obj stream)
       (store-arbitrary-integer obj stream)))
 
+(defun dump-int (obj stream)
+  (declare (type ub32 obj))
+  (typecase obj 
+    ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream))
+    (t (write-byte 2 stream) (store-32-bit obj stream))))
+
+(defun undump-int (stream)
+  (ecase (read-byte stream)
+    (1 (read-byte stream))
+    (2 (read-32-bit stream nil))))
 
-
-
-;; Should be 32-bit
 (defun store-32-bit-integer (obj stream)
+  (declare (type sb32 obj))
   (output-type-code +32-bit-integer-code+ stream)
   (write-byte (if (minusp obj) 1 0) stream)
-  (store-32-bit (abs obj) stream))
+  (dump-int (abs obj) stream))
 
 (defrestore-cl-store (32-bit-integer stream)
-  (funcall (if (zerop (read-byte stream)) #'+ #'-)
-           (read-32-bit stream nil)))
+  (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-)
+           (undump-int stream)))
 
 (defun store-arbitrary-integer (obj stream)
+  (declare (type integer obj) (stream stream))
   (output-type-code +integer-code+ stream)
   (loop for n = (abs obj) then (ash n -32)
         for counter from 0
@@ -131,46 +137,14 @@
 (defrestore-cl-store (integer buff)
   (let ((count (restore-object buff))
         (result 0))
+    (declare (type integer result count))
     (loop repeat (abs count) do
-          (setf result (+ (ash result 32) (read-32-bit buff nil))))
+          (setf result (the integer (+ (ash result 32) 
+                                       (the ub32 (read-32-bit buff nil))))))
     (if (minusp count)
         (- result)
         result)))
 
-
-;; Strings
-;; If the string to be stored is of type simple-standard-string
-;; we can write it down byte by byte. Otherwise we treat it as 
-;; an array.
-(deftype simple-standard-string ()
-  `(simple-array standard-char (*)))
-
-(defun output-simple-standard-string (obj stream)
-  (store-object (length obj) stream)
-  (loop for x across obj do
-    (write-byte (char-code x) stream)))
-
-(defun restore-simple-standard-string (stream)
-  (let* ((length (restore-object stream))
-         (res (make-string length 
-                #+lispworks :element-type #+lispworks 'character)))
-    (dotimes (x length)
-      (setf (schar res x) (code-char (read-byte stream))))
-    res))
-
-(defun store-simple-standard-string (string stream)
-  (output-type-code +simple-string-code+ stream)
-  (output-simple-standard-string string stream))
-
-
-(defstore-cl-store (obj string stream)
-  (if (typep obj 'simple-standard-string)
-      (store-simple-standard-string obj stream)
-      (store-array obj stream)))
-
-(defrestore-cl-store (simple-string stream)
-  (restore-simple-standard-string stream))
-
 ;; Floats
 ;; SBCL and CMUCL use a different mechanism for dealing
 ;; with floats which supports infinities.
@@ -201,7 +175,8 @@
   (store-object (denominator obj) stream))
 
 (defrestore-cl-store (ratio stream)
-  (/ (restore-object stream) (restore-object stream)))
+  (/ (the integer (restore-object stream))
+     (the integer (restore-object stream))))
 
 ;; chars
 (defstore-cl-store (obj character stream)
@@ -284,6 +259,7 @@
         (size (restore-object stream))
         (test (restore-object stream))
         (count (restore-object stream)))
+    (declare (type integer count size))
     (let ((hash (make-hash-table :test (symbol-function test)
                                  :rehash-size rehash-size
                                  :rehash-threshold rehash-threshold
@@ -298,6 +274,8 @@
                             (restore-object stream))))
       hash)))
 
+
+;; Object and Conditions
 (defun store-type-object (obj stream)
   (let* ((all-slots (remove-if-not (lambda (x)
                                      (slot-boundp obj (slot-definition-name x)))
@@ -307,6 +285,7 @@
                     (remove-if #'(lambda (x) (eql (slot-definition-allocation x)
                                                   :class))
                                all-slots))))
+    (declare (type list slots))
     (store-object (type-of obj) stream)
     (store-object (length slots) stream)
     (dolist (slot slots)
@@ -328,6 +307,7 @@
   (let* ((class (find-class (restore-object stream)))
          (length (restore-object stream))
          (new-instance (allocate-instance class)))
+    (declare (type integer length))
     (loop repeat length do
           (let ((slot-name (restore-object stream)))
             ;; slot-names are always symbols so we don't
@@ -387,9 +367,14 @@
 (defrestore-cl-store (built-in-class stream)
   (find-class (restore-object stream)))
 
-;; arrays and vectors
+
+
+;; Arrays and Vectors and Strings
 (defstore-cl-store (obj array stream)
-  (store-array obj stream))
+  (typecase obj
+    (simple-string (store-simple-string obj stream))
+    (simple-vector (store-simple-vector obj stream))
+    (t (store-array obj stream))))
 
 (defun store-array (obj stream)
   (output-type-code +array-code+ stream)
@@ -418,6 +403,7 @@
                           :element-type element-type
                           :adjustable adjustable
                           :fill-pointer fill-pointer)))
+    (declare (type cons dimensions) (type array-size size))
     (when displaced-to 
       (adjust-array res dimensions :displaced-to displaced-to
                     :displaced-index-offset displaced-offset))
@@ -427,29 +413,65 @@
               (setting (row-major-aref pos) (restore-object stream)))))
     res))
 
-
-;; clisp and allegro doesn't have the class simple-vector
-#-(or clisp allegro)
-(defstore-cl-store (obj simple-vector stream)
+(defun store-simple-vector (obj stream)
+  (declare (type simple-vector obj))
   (output-type-code +simple-vector-code+ stream)
   (let ((size (length obj)))
     (store-object size stream)
     (loop for x across obj do
           (store-object x stream))))
 
-#-(or clisp allegro)
 (defrestore-cl-store (simple-vector stream)
   (let* ((size (restore-object stream))
          (res (make-array size)))
+    (declare (type array-size size))
     (resolving-object res
-      (loop repeat size
-            for i from 0 do
+      (loop for i from 0 to (1- size) do
             ;; we need to copy the index so that
             ;; it's value is preserved for after the loop.
             (let ((x i)) 
               (setting (aref x) (restore-object stream)))))
     res))
 
+;; Dumping (unsigned-byte 32) for each character seems
+;; like a bit much when most of them will be 
+;; standard-chars. So we try to cater for them.
+(defvar *char-marker* (code-char 255)
+  "Largest character that can be represented in 8 bits")
+
+(defun store-simple-string (obj stream)
+  (declare (type simple-string obj))
+  ;; must be a better test than this.
+  (cond ((some #'(lambda (x) (char> x *char-marker*)) obj)
+         ;; contains wide characters
+         (output-type-code +unicode-string-code+ stream)
+         (dump-string #'dump-int obj stream))
+        (t (output-type-code +simple-string-code+ stream)
+           (dump-string #'write-byte obj stream))))
+
+(defun dump-string (dumper obj stream)
+  (declare (simple-string obj) (function dumper) (stream stream))
+  ;(store-object (length obj) stream)
+  (dump-int (length obj) stream)
+  (loop for x across obj do (funcall dumper (char-code x) stream)))
+
+(defrestore-cl-store (simple-string stream)
+  (undump-string #'read-byte stream))
+
+(defrestore-cl-store (unicode-string stream)
+  (undump-string #'undump-int stream))
+
+(defun undump-string (reader stream)
+  (declare (type function reader) (type stream stream))
+  (let* ((length (undump-int stream)) ;(restore-object stream))
+         (res (make-string length 
+                           #+lispworks :element-type #+lispworks 'character)))
+    (dotimes (x length)
+      (setf (schar res x) (code-char (funcall reader stream))))
+    res))
+
+
+
 ;; packages
 (defstore-cl-store (obj package stream)
   (output-type-code +package-code+ stream)
@@ -472,16 +494,35 @@
 
 ;; Function storing hack.
 ;; This just stores the function name if we can find it
-;; or signals a store-error.
+;; or signal a store-error.
 (defstore-cl-store (obj function stream)
   (output-type-code +function-code+ stream)
   (multiple-value-bind (l cp name) (function-lambda-expression obj) 
     (declare (ignore l cp))
-    (if (and name (symbolp name))
-        (store-object name stream)
-        (store-error "Unable to determine function name for ~A." obj))))
+    (cond ((and name (or (symbolp name) (consp name))) (store-object name stream))
+          ;;  Try to deal with sbcl's naming convention
+          ;; of built in functions
+          #+sbcl
+          ((and name (stringp name) (search "top level local call " name))
+           (let ((new-name (subseq name 21)))
+             (when (not (string= new-name ""))
+               (handler-case (store-object (read-from-string new-name) stream)
+                 (sb-ext:package-locked-error (c)
+                   (declare (ignore c))
+                   (store-error "Unable to determine function name for ~A." obj))))))
+          (t (store-error "Unable to determine function name for ~A." obj)))))
 
 (defrestore-cl-store (function stream)
+  (fdefinition (restore-object stream)))
+
+;; Generic function, just dumps the gf-name
+(defstore-cl-store (obj generic-function stream)
+  (output-type-code +gf-code+ stream)
+  (aif (generic-function-name obj)
+       (store-object it stream)
+       (store-error "No generic function name for ~A." obj)))
+
+(defrestore-cl-store (generic-function stream)
   (fdefinition (restore-object stream)))
 
 (setf *default-backend* (find-backend 'cl-store))


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.13 cl-store/package.lisp:1.14
--- cl-store/package.lisp:1.13	Mon Nov  1 15:30:18 2004
+++ cl-store/package.lisp	Wed Nov 10 11:43:16 2004
@@ -12,7 +12,7 @@
            #: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
+           #: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
@@ -28,6 +28,7 @@
            #:store-32-bit #:read-32-bit)
 
   #+sbcl (:import-from #:sb-mop
+                       #:generic-function-name
                        #:slot-definition-name
                        #:slot-value-using-class
                        #:slot-boundp-using-class
@@ -44,8 +45,9 @@
                        #:class-direct-superclasses
                        #:class-slots
                        #:ensure-class)
-  
+
   #+cmu  (:import-from #:pcl
+                       #:generic-function-name
                        #:slot-definition-name
                        #:slot-value-using-class
                        #:slot-boundp-using-class
@@ -70,6 +72,7 @@
                                 #:class-of)
   
   #+openmcl (:import-from #:openmcl-mop
+                          #:generic-function-name
                           #:slot-definition-name
                           #:slot-value-using-class
                           #:slot-boundp-using-class
@@ -99,6 +102,7 @@
   
   #+lispworks  (:import-from #:clos
                              #:slot-definition-name
+                             #:generic-function-name
                              #:slot-value-using-class
                              #:slot-boundp-using-class
                              #:slot-definition-allocation
@@ -117,6 +121,7 @@
   
   #+allegro (:import-from #:mop
                           #:slot-definition-name
+                          #:generic-function-name
                           #:slot-value-using-class
                           #:slot-boundp-using-class
                           #:slot-definition-allocation


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.5 cl-store/plumbing.lisp:1.6
--- cl-store/plumbing.lisp:1.5	Mon Nov  1 15:30:18 2004
+++ cl-store/plumbing.lisp	Wed Nov 10 11:43:16 2004
@@ -5,7 +5,7 @@
 ;; 
 
 (in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
 
 (defvar *nuke-existing-classes* nil
   "Do we overwrite existing class definitions on restoration.")
@@ -24,6 +24,7 @@
 ;; store or restore will signal a store-error or a 
 ;; restore-error respectively inside a handler-bind.
 (defun cl-store-report (condition stream)
+  (declare (stream stream))
   (aif (caused-by condition)
        (format stream "~A" it)
        (apply #'format stream (format-string condition) 
@@ -92,15 +93,13 @@
   (:documentation "Method wrapped by store, override this method for 
     custom behaviour (see circularities.lisp)."))
 
-(defun store-backend-code (stream backend)
-  "Store magic-number of BACKEND, when present, into STREAM."
-  (let ((code (magic-number backend)))
-    (when code
-      (ecase (stream-type backend)
-        (character (store-string-code code stream))
-        (integer (store-32-bit code stream))))))
-
-
+(defgeneric store-backend-code (stream backend)
+  (:argument-precedence-order backend stream)
+  (:method ((stream t) (backend t))
+    (let ((code (magic-number backend)))
+      (store-32-bit code stream)))
+  (:documentation
+   "Store magic-number of BACKEND, when present, into STREAM."))
 
 (defun store-object (obj stream &optional (backend *current-backend*))
   "Store OBJ into STREAM. Not meant to be overridden, 
@@ -136,10 +135,6 @@
                                                       :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)
@@ -180,20 +175,23 @@
 (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)))
-    (when magic-number
-      (let ((val (ecase (stream-type backend)
-                   (integer (read-32-bit stream nil))
-                   (character (retrieve-string-code stream)))))
-        (cond ((eql val magic-number) nil)
-              ((member val (old-magic-numbers backend))
-               (restore-error "Stream contains an object stored with a ~
+(defgeneric check-magic-number (stream backend)
+  (:argument-precedence-order backend stream)
+  (:method ((stream t) (backend t))
+    (let ((magic-number (magic-number backend)))
+      (declare (type ub32 magic-number))
+      (when magic-number
+        (let ((val (read-32-bit stream nil)))
+          (declare (type ub32 val))
+          (cond ((= val magic-number) nil)
+                ((member val (old-magic-numbers backend) :test #'=)
+                 (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~
+                (t (restore-error "Stream does not contain a stored object~
  for backend ~A."
-                                (name backend))))))))
+                                  (name backend))))))))
+  (:documentation   
+   "Check to see if STREAM actually contains a stored object for BACKEND."))
 
 (defun lookup-reader (val readers)
   (gethash val readers))
@@ -216,7 +214,7 @@
   (:method (place backend)
     (multiple-value-bind (val info) (get-next-reader place backend)
       (let ((reader (lookup-reader val (restorer-funs backend))))
-        (cond ((and val reader) reader)
+        (cond ((and val reader) (values reader val))
               ((not val) 
                (restore-error "~A is not registered with backend ~(~A~)."
                               (or info "Unknown Type") (name backend)))


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.9 cl-store/tests.lisp:1.10
--- cl-store/tests.lisp:1.9	Mon Nov  1 15:30:18 2004
+++ cl-store/tests.lisp	Wed Nov 10 11:43:16 2004
@@ -95,6 +95,12 @@
   (make-array 10 :initial-element #\f :element-type 'character
               :fill-pointer 3))
 
+#+(or (and sbcl sb-unicode) lispworks clisp acl)
+(progn
+  (deftestit unicode.1 (map 'string #'code-char (list #X20AC #X3BB)))
+  (deftestit unicode.2 (intern (map 'string #'code-char (list #X20AC #X3BB))
+                               :cl-store-tests)))
+
 ;; vectors
 (deftestit vector.1 #(1 2 3 4))
 
@@ -470,6 +476,19 @@
     (let ((val (multiple-value-list (restore *test-file*))))
       (eq (car val) (cadr val))))
   t)
+
+
+(deftestit function.1 #'restores)
+(deftestit function.2 #'car)
+(deftestit function.3 #'cl-store::get-setf-place)
+#-(or clisp lispworks allegro openmcl)
+(deftestit function.4 #'(setf car))
+
+(deftestit gfunction.1 #'cl-store:restore)
+(deftestit gfunction.2 #'cl-store:store)
+#-(or clisp lispworks openmcl)
+(deftestit gfunction.3 #'(setf cl-store:restore))
+
 
 
 (defun run-tests (backend)


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.6 cl-store/utils.lisp:1.7
--- cl-store/utils.lisp:1.6	Mon Nov  1 15:30:18 2004
+++ cl-store/utils.lisp	Wed Nov 10 11:43:16 2004
@@ -3,7 +3,7 @@
 
 ;; Miscellaneous utilities used throughout the package.
 (in-package :cl-store)
-;;(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 
 (defmacro aif (test then &optional else)
@@ -47,15 +47,29 @@
     (0 1.0)
     (1 1.0d0)))
 
+(deftype ub32 ()
+  `(unsigned-byte 32))
+
+(deftype sb32 ()
+  `(signed-byte 32))
+
+(deftype array-size ()
+  "The maximum size of an array"
+  `(integer 0 ,array-dimension-limit))
+
 
 (defun store-32-bit (obj stream)
-  "Write OBJ down STREAM as a 32 byte integer."
+  "Write OBJ down STREAM as a 32 bit integer."
+  (declare (ub32 obj))
   (write-byte (ldb (byte 8 0) obj) stream)
   (write-byte (ldb (byte 8 8) obj) stream)
   (write-byte (ldb (byte 8 16) obj) stream)
   (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
 
 
+(defmacro make-ub32 (a b c d)
+  `(the ub32 (logior (ash ,a 24) (ash ,b 16) (ash ,c 8) ,d)))
+
 (defun read-32-bit (buf &optional (signed t))
   "Read a signed or unsigned byte off STREAM."
   (let ((byte1 (read-byte buf))
@@ -63,7 +77,7 @@
         (byte3 (read-byte buf))
         (byte4 (read-byte buf)))
     (declare (type (mod 256) byte1 byte2 byte3 byte4))
-    (let ((ret (+ byte1 (* 256 (+ byte2 (* 256 (+ byte3 (* 256 byte4))))))))
+    (let ((ret (make-ub32 byte4 byte3 byte2 byte1)))
       (if (and signed (> byte1 127))
           (logior (ash -1 32) ret)
           ret))))
@@ -71,7 +85,7 @@
 
 (defun store-string-code (string stream)
   "Write length of STRING then STRING into stream"
-  (declare (type simple-string string))
+  (declare (simple-string string) (stream stream))
   (format stream "~S" string))
 
 (defun retrieve-string-code (stream)


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.6 cl-store/xml-backend.lisp:1.7
--- cl-store/xml-backend.lisp:1.6	Mon Nov  1 15:30:18 2004
+++ cl-store/xml-backend.lisp	Wed Nov 10 11:43:16 2004
@@ -3,7 +3,7 @@
 
 (in-package :cl-store-xml)
 
-(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 0)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *xml-backend*




From sross at common-lisp.net  Wed Nov 10 10:43:27 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 11:43:27 +0100
Subject: [cl-store-cvs] CVS update: cl-store/clisp/fix-clisp.lisp 
Message-ID: <E1CRpwl-0001s7-00@common-lisp.net>

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

Modified Files:
	fix-clisp.lisp 
Log Message:
Changelog 2004-11-10

Date: Wed Nov 10 11:43:25 2004
Author: sross

Index: cl-store/clisp/fix-clisp.lisp
diff -u cl-store/clisp/fix-clisp.lisp:1.4 cl-store/clisp/fix-clisp.lisp:1.5
--- cl-store/clisp/fix-clisp.lisp:1.4	Mon Nov  1 15:30:32 2004
+++ cl-store/clisp/fix-clisp.lisp	Wed Nov 10 11:43:23 2004
@@ -65,4 +65,9 @@
                   (setf (slot-value clos::object ',x) clos::new-value))))
     (find-class class)))
 
+(defmethod generic-function-name ((gf generic-function))
+  (multiple-value-bind (l cp name) (function-lambda-expression gf)
+    (declare (ignore l cp))
+    name))
+
 ;; EOF




From sross at common-lisp.net  Wed Nov 10 10:43:32 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 11:43:32 +0100
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <E1CRpwq-0001sL-00@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Changelog 2004-11-10

Date: Wed Nov 10 11:43:27 2004
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.1 cl-store/doc/cl-store.texi:1.2
--- cl-store/doc/cl-store.texi:1.1	Mon Nov  1 15:49:03 2004
+++ cl-store/doc/cl-store.texi	Wed Nov 10 11:43:26 2004
@@ -108,6 +108,7 @@
 @item CLOS Classes
 @item Structure Instances
 @item Functions (where function-lambda-expression returns a symbol as a function name)
+ at item Generic Functions (stores generic-function-name)
 @end itemize
 
 @section Supported Implementations
@@ -126,10 +127,8 @@
 
 CL-STORE uses @uref{http://cliki.net/asdf,,asdf} as it's system definition tool and 
 is required whenever you load the package.  
-You will need to download it, or if you have @uref{http://sbcl.org,,sbcl} try
- at lisp 
-(require 'asdf) 
- at end lisp
+You will need to download it, or if you have @uref{http://sbcl.org,,sbcl}
+ at lisp (require 'asdf) @end lisp
 
 
 @section Downloading
@@ -137,9 +136,7 @@
 @item ASDF-INSTALL 
 CL-STORE is available through asdf-install. If you are new
 to Common Lisp this is the suggested download method. With asdf-install loaded run 
- at lisp 
-(asdf-install:install :cl-store)
- at end lisp
+ at lisp (asdf-install:install :cl-store) @end lisp
 This will download and install the package for you. Asdf-install will try to verify 
 that the package signature is correct and that you trust the author. If the key is 
 not found or the trust level is not sufficient a continuable error will be signalled. 
@@ -163,9 +160,7 @@
 
 @section Installing
 Once downloaded and symlinked you can load CL-STORE at anytime using
- at lisp 
-(asdf:oos 'asdf:load-op :cl-store)
- at end lisp
+ at lisp (asdf:oos 'asdf:load-op :cl-store) @end lisp
 This will compile CL-STORE the first time it is loaded.
 
 @section Testing
@@ -711,9 +706,8 @@
 @itemize @bullet
 @item  CLISP, OpenMCL, Allegro CL cannot store structure instances.
 @item  Structure definitions aren't supported.
- at item  Anything remotely funcallable isn't supported.
 @item  MOP classes aren't supported.
- at item  Due to the fact that function's aren't supported CLOS Classes initfunction slot cannot be serialized.
+ at item  Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized.
 @end itemize
 
 @node Credits




From sross at common-lisp.net  Wed Nov 10 10:43:36 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 11:43:36 +0100
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <E1CRpwu-0001sZ-00@common-lisp.net>

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

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

Date: Wed Nov 10 11:43:34 2004
Author: sross

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.2 cl-store/sbcl/custom.lisp:1.3
--- cl-store/sbcl/custom.lisp:1.2	Wed Oct  6 16:41:45 2004
+++ cl-store/sbcl/custom.lisp	Wed Nov 10 11:43:33 2004
@@ -7,7 +7,7 @@
 ;; Custom float storing
 
 (defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ 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)
@@ -18,20 +18,21 @@
                                 stream))))
 
 (defun sbcl-restore-single-float (stream)
-  (sb-kernel:make-single-float (restore-object stream)))
+  (sb-kernel:make-single-float (the integer (restore-object stream))))
 
 (defun sbcl-restore-double-float (stream)
-  (sb-kernel:make-double-float (restore-object stream)
-                               (restore-object stream)))
+  (sb-kernel:make-double-float (the integer (restore-object stream))
+                               (the integer (restore-object stream))))
 
 (defvar *sbcl-float-restorers* 
-  (list (cons 0 'sbcl-restore-single-float)
-        (cons 1 'sbcl-restore-double-float)))
+  (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)
+    (declare (type (integer 0 1) byte))
+    (aif (cdr (assoc byte *sbcl-float-restorers* :test #'=))
+         (funcall (the function it) stream)
          (restore-error "Unknown float type designator ~S." byte))))
 
 




From sross at common-lisp.net  Wed Nov 10 10:47:49 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 11:47:49 +0100
Subject: [cl-store-cvs] CVS update: cl-store/acl/.cvsignore 
Message-ID: <E1CRq0z-00023o-00@common-lisp.net>

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

Added Files:
	.cvsignore 
Log Message:
Added acl .cvsignore

Date: Wed Nov 10 11:47:48 2004
Author: sross





From sross at common-lisp.net  Wed Nov 10 11:14:31 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 10 Nov 2004 12:14:31 +0100
Subject: [cl-store-cvs] CVS update: cl-store/default-backend.lisp 
Message-ID: <E1CRqQp-0002OG-00@common-lisp.net>

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

Modified Files:
	default-backend.lisp 
Log Message:

Date: Wed Nov 10 12:14:30 2004
Author: sross

Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.11 cl-store/default-backend.lisp:1.12
--- cl-store/default-backend.lisp:1.11	Wed Nov 10 11:43:16 2004
+++ cl-store/default-backend.lisp	Wed Nov 10 12:14:30 2004
@@ -507,7 +507,7 @@
            (let ((new-name (subseq name 21)))
              (when (not (string= new-name ""))
                (handler-case (store-object (read-from-string new-name) stream)
-                 (sb-ext:package-locked-error (c)
+                 (error (c)
                    (declare (ignore c))
                    (store-error "Unable to determine function name for ~A." obj))))))
           (t (store-error "Unable to determine function name for ~A." obj)))))




From sross at common-lisp.net  Wed Nov 24 13:27:10 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 24 Nov 2004 14:27:10 +0100
Subject: [cl-store-cvs] CVS update: 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 
Message-ID: <E1CWxAs-00049r-00@common-lisp.net>

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

Modified Files:
	ChangeLog README backends.lisp circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp 
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:04 2004
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.14 cl-store/ChangeLog:1.15
--- cl-store/ChangeLog:1.14	Wed Nov 10 11:43:16 2004
+++ cl-store/ChangeLog	Wed Nov 24 14:27:03 2004
@@ -1,9 +1,26 @@
+2004-11-24 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: New Magic Number (Breaks backwards compatibility)
+	* cl-store.asd New Version 0.4
+	* default-backend.lisp: Changed symbol storing to be smarter
+	with symbols with no home package.
+	* sbcl/custom.lisp: Support for structure definitions from defstruct.
+	* tests.lisp: Tests for structure definitions.
+	* circularities.lisp: Optimization for referrers and values-object's.
+	Added *store-hash-size* and *restore-hash-size* which can be bound
+	to reduce the calls to rehash which conses like crazy.
+	Added *check-for-circs* which can be bound to nil to stop
+	checking for circularities which reduces consing drastically but objects
+	will not be eq and will hang on circular objects (see README).
+	* default-backend.lisp: New Magic Number ,again.
+	Cater for SB! package names for built-in function names
+	in SBCL.
+	
 2004-11-10 Sean Ross <sross at common-lisp.net>
 	New Version: 0.3.6 New Magic Number (Breaks backwards compatibility)
 	* default-backend.lisp: Storing for functions and generic functions.
 	* tests.lisp: Tests for functions and GF's.
 	* plumbing.lisp, circularities.lisp, default-backend.lisp: 
-	Optimized int-sym-or-charp.
+	Optimized int-sym-or-char-p.
 	* clisp/fix-clisp.lisp: Added generic-function-name.
 	* package.lisp: Import generic-function-name.
 	* default-backend.lisp: More optimizations for strings and ints.


Index: cl-store/README
diff -u cl-store/README:1.11 cl-store/README:1.12
--- cl-store/README:1.11	Wed Nov 10 11:43:16 2004
+++ cl-store/README	Wed Nov 24 14:27: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.3.6
+Version: 0.4
 
 0. About.
    CL-STORE is an portable serialization package which 
@@ -11,12 +11,12 @@
 
 1. Usage
    The main entry points are 
-    - [Function] cl-store:store (obj place &optional (backend *default-backend*)) i
+    - [Method] 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.
 
-    - [Function] cl-store:restore (place &optional (backend *default-backend*)) 
+    - [Method] cl-store:restore (place &optional (backend *default-backend*)) 
           => restored-objects
        Where place and backend is as above.
 
@@ -31,6 +31,34 @@
     NOTE.
      All errors signalled within store and restore can 
      be handled by catching store-error and restore-error respectively.
-   
+
+2. Optimizing.
+    
+   While cl-store is generally quickish it still has a tendency to 
+   do a lot of consing. Thanks to profilers this has been pinned down 
+   to the rehashing of the hash-tables which track object circularities.
+   From 0.4.0 cl-store has three new variables *store-hash-size*, *restore-hash-size*
+   and *check-for-circs*, proper usage of these new variables can greatly reduce
+   the consing (and time taken) when storing and restoring large objects.
+  
+   - *store-hash-size* and *restore-hash-size
+     At the beginning of storing and restoring an eq hash-table is created with a 
+     default size of 1000 to track objects which have been (re)stored. On large objects however
+     the rehashing of these hash-tables imposes a severe drain on performance.
+     By binding these two variables to appropriately large values 
+     about (100010 for a hash-table with 100000 int->string mappings) you
+     can obtain a decent performance improvement. This may require a bit 
+     of fiddling to find the best tradeoff between rehashing and creating 
+     a large hash-table.
+ 
+   - *check-for-circs*
+     Binding this variable to nil when storing or restoring
+     an object inhibits all checks for circularities which gives a 
+     severe boost to performance. The downside of this is that no 
+     restored objects will be eq and attempting to store circular objects 
+     will hang. The speed improvements are definitely worth it if you 
+     know that there will be no circularities or shared references in 
+     your data (eg spam-filter hash-tables). 
+
 Enjoy
  Sean.


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.4 cl-store/backends.lisp:1.5
--- cl-store/backends.lisp:1.4	Wed Nov 10 11:43:16 2004
+++ cl-store/backends.lisp	Wed Nov 24 14:27:03 2004
@@ -7,7 +7,7 @@
 ;; in default-backend.lisp and xml-backend.lisp
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
+;(declaim (optimize (speed 3) (safety 1) (debug 0)))
 
 
 (defun required-arg (name)


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.11 cl-store/circularities.lisp:1.12
--- cl-store/circularities.lisp:1.11	Wed Nov 10 11:43:16 2004
+++ cl-store/circularities.lisp	Wed Nov 24 14:27:03 2004
@@ -21,6 +21,10 @@
 (in-package :cl-store)
 (declaim (optimize (speed 3) (safety 1) (debug 1)))
 
+
+(defvar *check-for-circs* t)
+
+
 (defvar *postfix-setters* '(gethash)
   "Setfable places which take the object to set after
    the rest of the arguments.")
@@ -91,15 +95,17 @@
   ()
   (:documentation "A backend which does the setup for resolving circularities."))
 
-(declaim (type (or null fixnum) *stored-counter*))
+(declaim (type (or fixnum null) *stored-counter*))
 (defvar *stored-counter*)
 (defvar *stored-values*)
 
+(defvar *store-hash-size* 1000)
+
 
 (defmethod backend-store ((obj t) (place stream) (backend resolving-backend))
   "Store OBJ into PLACE. Does the setup for counters and seen values."
   (let ((*stored-counter* 0) 
-        (*stored-values* (make-hash-table :test #'eq))) 
+        (*stored-values* (make-hash-table :test #'eq :size *store-hash-size*))) 
     (store-backend-code place backend)
     (backend-store-object obj place backend)
     obj))
@@ -109,12 +115,10 @@
   (incf *stored-counter*)
   (gethash obj *stored-values*))
 
-(declaim (inline update-seen))
-
 (defun update-seen (obj)
   "Register OBJ as having been stored."
-  (setf (gethash obj *stored-values*)  *stored-counter*)
-  obj)
+  (setf (gethash obj *stored-values*) *stored-counter*)
+  nil)
 
 (deftype not-circ ()
   "Type grouping integer, characters and symbols, which we
@@ -125,67 +129,93 @@
   "Do we need to check if this object has been stored before?"
   (not (typep obj 'not-circ)))
 
-(defun value-or-referrer (obj)
-  "Returns the number of the referrer and t if this object 
-  has already been stored in this STORE call."
-  (if (needs-checkp obj)
-      (aif (seen obj)
-           (values it t)
-           (values (update-seen obj) nil))
-      obj))
-
 (defgeneric store-referrer (obj place backend)
   (:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.")
   (:method ((obj t) (place t) (backend resolving-backend))
     (store-error  "store-referrer must be specialized for backend ~(~A~)."
                   (name backend))))
 
+
+(defun get-ref (obj)
+  (if (needs-checkp obj)
+      (aif (seen obj)
+           it
+           (update-seen obj))
+      nil))
+
 (defmethod backend-store-object ((obj t) (place t) (backend resolving-backend))
   "Store object if we have not seen this object before, otherwise retrieve
   the referrer object for it and store that using store-referrer."
-  (multiple-value-bind (obj referrerp) (value-or-referrer obj)
-    (if referrerp
-        (store-referrer obj place backend)
-        (internal-store-object obj place backend))))
-
-
-
+  (aif (and *check-for-circs* (get-ref obj))
+       (store-referrer it place backend)
+       (internal-store-object obj place backend)))
+       
 ;; Restoration.
-(declaim (type (or null fixnum) *restore-counter*))
+(declaim (type (or fixnum null) *restore-counter*))
 (defvar *restore-counter*)
 (defvar *need-to-fix*)
 (defvar *restored-values*)
+(defvar *restore-hash-size* 1000)
 
 (defmethod backend-restore ((place stream) (backend resolving-backend))
   "Restore an object from PLACE using BACKEND. Does the setup for 
   various variables used by resolving-object."
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
-        (*restored-values* (make-hash-table)))
+        (*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*)))
     (check-magic-number place backend)
     (multiple-value-prog1
-        (backend-restore-object place backend)
+      (backend-restore-object place backend)
       (dolist (fn *need-to-fix*)
         (funcall (the function fn))))))
 
-(defmethod backend-restore-object ((place t) (backend resolving-backend))
-  "Retrieve a object from PLACE, does housekeeping for circularity fixing."
-  (multiple-value-bind (reader sym) (find-function-for-type place backend)
-    (if (not (int-sym-or-char-p sym backend))
-        (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))))
+(defun update-restored (spot val)
+  (setf (gethash spot *restored-values*) val))
 
+(defun all-vals (reader place)
+  (declare (type function reader))
+  (multiple-value-list (funcall reader place)))
+
+(defun get-vals (reader place)
+  (declare (type function reader))
+  (mapcar #'new-val (all-vals reader place)))
+
+(defun handle-values (reader place)
+  (let ((spot (incf *restore-counter*))
+        (vals (get-vals reader place)))
+    (update-restored spot (car vals))
+    (values-list vals)))
+
+(defun call-it (reader place)
+  (funcall (the function reader) place))
+
+(defun handle-normal (reader place)
+  (let ((spot (incf *restore-counter*))
+        (vals (new-val (call-it reader place))))
+    (update-restored spot vals)
+    vals))
 
+(defun handle-restore (place backend)
+  (multiple-value-bind (reader sym) (find-function-for-type place backend)
+    (declare (type function reader) (type symbol sym))
+    (cond ((eq sym 'values-object)
+           (handle-values reader place))
+          ((eq sym 'referrer)
+           (incf *restore-counter*)
+           (new-val (call-it reader place)))
+          ((not (int-sym-or-char-p sym backend))
+           (handle-normal reader place))
+          (t (new-val (funcall reader place))))))
+
+(defmethod backend-restore-object ((place stream) (backend resolving-backend))
+  "Retrieve a object from PLACE, does housekeeping for circularity fixing."
+  (if *check-for-circs*
+      (handle-restore place backend)
+      (funcall (the function (find-function-for-type place backend)) place)))
 
 (defgeneric int-sym-or-char-p (fn backend)
   (:argument-precedence-order backend fn)
-  (:method ((fn t) (backend t))
+  (:method ((fn symbol) (backend backend))
     "Is function FN registered to restore an integer, character or symbol
   in BACKEND."
     (member fn '(integer character symbol))))
@@ -197,5 +227,6 @@
            it
            val)
       val))
+
 
 ;; EOF


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.13 cl-store/cl-store.asd:1.14
--- cl-store/cl-store.asd:1.13	Wed Nov 10 11:43:16 2004
+++ cl-store/cl-store.asd	Wed Nov 24 14:27:03 2004
@@ -40,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.3.6"
+  :version "0.4"
   :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.12 cl-store/default-backend.lisp:1.13
--- cl-store/default-backend.lisp:1.12	Wed Nov 10 12:14:30 2004
+++ cl-store/default-backend.lisp	Wed Nov 24 14:27:03 2004
@@ -9,11 +9,13 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *cl-store-backend*
-    (defbackend cl-store :magic-number 1349732684
+    (defbackend cl-store :magic-number 1886611820 
                 :stream-type 'binary
-                :old-magic-numbers (1912923 1886611788 1347635532 1347643724)
+                :old-magic-numbers (1912923 1886611788 1347635532 
+                                    1884506444 1347643724 1349732684)
                 :extends resolving-backend
-                :fields ((restorers :accessor restorers :initform (make-hash-table)))))
+                :fields ((restorers :accessor restorers 
+                                    :initform (make-hash-table :size 100)))))
   (defun register-code (code name &optional (errorp t))
     (aif (and (gethash code (restorers *cl-store-backend*)) errorp)
          (error "Code ~A is already defined for ~A." code name)
@@ -57,6 +59,12 @@
 (defconstant +function-code+ (register-code 26 'function nil))
 (defconstant +gf-code+ (register-code 27 'generic-function nil))
 
+;; Used by SBCL.
+(defconstant +structure-class-code+ (register-code 28 'structure-class nil))
+(defconstant +struct-def-code+ (register-code 29 'struct-def nil))
+
+(defconstant +gensym-code+ (register-code 30 'gensym nil))
+
 ;; setups for type code mapping
 (defun output-type-code (code stream)
   (declare (type ub32 code))
@@ -65,13 +73,17 @@
 (defun read-type-code (stream)
   (read-byte stream))
 
-
+(defvar *restorers* (restorers *cl-store-backend*))
 ;; 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. 
+
+(defun lookup-code (code)
+  (gethash code *restorers*))
+
 (defmethod get-next-reader ((stream stream) (backend cl-store-backend))
   (let ((type-code (read-type-code stream)))
-    (or (gethash type-code (restorers backend))
+    (or (lookup-code type-code) ;(gethash type-code *restorers*)
         (values nil (format nil "Type ~A" type-code)))))
 
 
@@ -89,7 +101,7 @@
 ;; so we we have a little optimization for it
 
 ;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((fn t) (backend cl-store-backend))
+(defmethod int-sym-or-char-p ((fn symbol) (backend cl-store-backend))
   (member fn '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
@@ -98,7 +110,6 @@
       (store-arbitrary-integer obj stream)))
 
 (defun dump-int (obj stream)
-  (declare (type ub32 obj))
   (typecase obj 
     ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream))
     (t (write-byte 2 stream) (store-32-bit obj stream))))
@@ -109,7 +120,6 @@
     (2 (read-32-bit stream nil))))
 
 (defun store-32-bit-integer (obj stream)
-  (declare (type sb32 obj))
   (output-type-code +32-bit-integer-code+ stream)
   (write-byte (if (minusp obj) 1 0) stream)
   (dump-int (abs obj) stream))
@@ -132,7 +142,7 @@
                                     counter)
                                 stream)
                   (dolist (num collect)
-                    (store-32-bit num stream)))))
+                    (dump-int num stream)))))
 
 (defrestore-cl-store (integer buff)
   (let ((count (restore-object buff))
@@ -140,7 +150,7 @@
     (declare (type integer result count))
     (loop repeat (abs count) do
           (setf result (the integer (+ (ash result 32) 
-                                       (the ub32 (read-32-bit buff nil))))))
+                                       (the ub32 (undump-int buff))))))
     (if (minusp count)
         (- result)
         result)))
@@ -198,16 +208,22 @@
 
 ;; symbols
 (defstore-cl-store (obj symbol stream)
-  (output-type-code +symbol-code+ stream)    
-  (store-object (symbol-name obj) stream)
-  (store-object (package-name (or (symbol-package obj) 
-                                  *package*))
-                stream))
+  (cond ((symbol-package obj)
+         (output-type-code +symbol-code+ stream)
+         (store-object (symbol-name obj) stream)
+         (store-object (package-name (symbol-package obj))
+                       stream))
+        ;; Symbols with no home package 
+        (t (output-type-code +gensym-code+ stream)
+           (store-object (symbol-name obj) stream))))
 
 (defrestore-cl-store (symbol stream)
   (values (intern (restore-object stream)
                   (restore-object stream))))
 
+(defrestore-cl-store (gensym stream)
+  (make-symbol (restore-object stream)))
+
   
 ;; lists
 (defstore-cl-store (obj cons stream)
@@ -451,10 +467,10 @@
 
 (defun dump-string (dumper obj stream)
   (declare (simple-string obj) (function dumper) (stream stream))
-  ;(store-object (length obj) stream)
-  (dump-int (length obj) stream)
+  (dump-int (the array-size (length obj)) stream)
   (loop for x across obj do (funcall dumper (char-code x) stream)))
 
+
 (defrestore-cl-store (simple-string stream)
   (undump-string #'read-byte stream))
 
@@ -463,15 +479,13 @@
 
 (defun undump-string (reader stream)
   (declare (type function reader) (type stream stream))
-  (let* ((length (undump-int stream)) ;(restore-object stream))
+  (let* ((length (the array-size (undump-int stream)) )
          (res (make-string length 
                            #+lispworks :element-type #+lispworks 'character)))
     (dotimes (x length)
       (setf (schar res x) (code-char (funcall reader stream))))
     res))
 
-
-
 ;; packages
 (defstore-cl-store (obj package stream)
   (output-type-code +package-code+ stream)
@@ -495,22 +509,32 @@
 ;; Function storing hack.
 ;; This just stores the function name if we can find it
 ;; or signal a store-error.
+(defun parse-name (name)
+  (let ((name (subseq name 21)))
+    (if (search name "SB!" :end1 3)
+        (replace name "SB-" :end1 3)
+        name)))
+
 (defstore-cl-store (obj function stream)
   (output-type-code +function-code+ stream)
   (multiple-value-bind (l cp name) (function-lambda-expression obj) 
     (declare (ignore l cp))
-    (cond ((and name (or (symbolp name) (consp name))) (store-object name stream))
+    (cond ((and name (or (symbolp name) (consp name))) 
+           (store-object name stream))
           ;;  Try to deal with sbcl's naming convention
           ;; of built in functions
           #+sbcl
-          ((and name (stringp name) (search "top level local call " name))
-           (let ((new-name (subseq name 21)))
+          ((and name (stringp name) (search "top level local call " 
+                                            (the simple-string name)))
+           (let ((new-name (parse-name name))) 
              (when (not (string= new-name ""))
                (handler-case (store-object (read-from-string new-name) stream)
                  (error (c)
                    (declare (ignore c))
-                   (store-error "Unable to determine function name for ~A." obj))))))
-          (t (store-error "Unable to determine function name for ~A." obj)))))
+                   (store-error "Unable to determine function name for ~A."
+                                obj))))))
+          (t (store-error "Unable to determine function name for ~A."
+                          obj)))))
 
 (defrestore-cl-store (function stream)
   (fdefinition (restore-object stream)))


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.14 cl-store/package.lisp:1.15
--- cl-store/package.lisp:1.14	Wed Nov 10 11:43:16 2004
+++ cl-store/package.lisp	Wed Nov 24 14:27:03 2004
@@ -14,7 +14,7 @@
            #:backend-store-object #:get-class-details #:get-array-values
            #:restore #:backend-restore
            #:check-magic-number #:get-next-reader #:int-sym-or-char-p
-           #:restore-object #:backend-restore-object #:cl-store
+           #:restore-object #:backend-restore-object
            #:defstore-cl-store #:defrestore-cl-store #:register-code
            #:output-type-code #:store-referrer #:resolving-object
            #:internal-store-object #:setting #:simple-standard-string
@@ -25,7 +25,8 @@
            #:class-direct-superclasses #:class-direct-slots
            #:ensure-class #:make-referrer #:setting-hash
            #:multiple-value-store #:*postfix-setters* #:caused-by
-           #:store-32-bit #:read-32-bit)
+           #:store-32-bit #:read-32-bit #:*check-for-circs*
+           #:*store-hash-size* #:*restore-hash-size*)
 
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.6 cl-store/plumbing.lisp:1.7
--- cl-store/plumbing.lisp:1.6	Wed Nov 10 11:43:16 2004
+++ cl-store/plumbing.lisp	Wed Nov 24 14:27:03 2004
@@ -5,7 +5,7 @@
 ;; 
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 0)))
+(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 (defvar *nuke-existing-classes* nil
   "Do we overwrite existing class definitions on restoration.")
@@ -14,7 +14,7 @@
 (defvar *store-class-slots* t
   "Whether or not to serialize slots which are class allocated.")
 
-
+(declaim (type backend *default-backend* *current-backend*))
 (defvar *default-backend*)
 (defvar *current-backend*)
 
@@ -58,6 +58,7 @@
 
 ;; entry points
 (defun store-to-file (obj place backend)
+  (declare (type backend backend))
   (let* ((backend-type (stream-type backend))
          (element-type (ecase backend-type
                          (character 'character)
@@ -78,16 +79,16 @@
 
 (defgeneric backend-store (obj place backend)
   (:argument-precedence-order backend place obj)
-  (:method ((obj t) (place stream) (backend t))
+  (:method ((obj t) (place stream) (backend backend))
     "The default. Checks the streams element-type, stores the backend code
      and calls store-object."
     (store-backend-code place backend)
     (store-object obj place backend)
     obj)
-  (:method ((obj t) (place string) (backend t))
+  (:method ((obj t) (place string) (backend backend))
     "Store OBJ into file designator PLACE."
     (store-to-file obj place backend))
-  (:method ((obj t) (place pathname) (backend t))
+  (:method ((obj t) (place pathname) (backend backend))
     "Store OBJ into file designator PLACE."
     (store-to-file obj place backend))
   (:documentation "Method wrapped by store, override this method for 
@@ -95,12 +96,13 @@
 
 (defgeneric store-backend-code (stream backend)
   (:argument-precedence-order backend stream)
-  (:method ((stream t) (backend t))
-    (let ((code (magic-number backend)))
-      (store-32-bit code stream)))
+  (:method ((stream t) (backend backend))
+    (awhen (magic-number backend)
+      (store-32-bit it stream)))
   (:documentation
    "Store magic-number of BACKEND, when present, into STREAM."))
 
+(declaim (inline store-object))
 (defun store-object (obj stream &optional (backend *current-backend*))
   "Store OBJ into STREAM. Not meant to be overridden, 
    use backend-store-object instead"
@@ -110,14 +112,14 @@
   (:documentation
    "Wrapped by store-object, override this to do custom storing 
    (see circularities.lisp for an example).")
-  (:method ((obj t) (stream t) (backend t))
+  (:method ((obj t) (stream t) (backend backend))
     "The default, just calls internal-store-object."
     (internal-store-object obj stream backend)))
 
 
 (defgeneric internal-store-object (obj place backend)
   (:documentation "Method which is specialized by defstore-? macros.")
-  (:method ((obj t) (place t) (backend t))
+  (:method ((obj t) (place t) (backend backend))
     "If call falls back here then OBJ cannot be serialized with BACKEND."
     (store-error "Cannot store objects of type ~A with backend ~(~A~)."
                  (type-of obj) (name backend))))
@@ -139,15 +141,15 @@
 (defgeneric backend-restore (place backend)
   (:argument-precedence-order backend place)
   (:documentation "Wrapped by restore. Override this to do custom restoration")
-  (:method ((place stream) (backend t))
+  (:method ((place stream) (backend backend))
     "Restore the object found in stream PLACE using backend BACKEND.
      Checks the magic-number and invokes backend-restore-object"
     (check-magic-number place backend)
     (backend-restore-object place backend))
-  (:method ((place string) (backend t))
+  (:method ((place string) (backend backend))
     "Restore the object found in file designator PLACE using backend BACKEND."
     (restore-from-file place backend))
-  (:method ((place pathname) (backend t ))
+  (:method ((place pathname) (backend backend))
     "Restore the object found in file designator PLACE using backend BACKEND."
     (restore-from-file place backend)))
 
@@ -157,7 +159,7 @@
                          (character 'character)
                          (integer '(unsigned-byte 8)))))
     (with-open-file (s place :element-type element-type :direction :input)
-      (restore s backend))))
+      (backend-restore s backend))))
      
 (defclass values-object ()
   ((vals :accessor vals :initarg :vals))
@@ -177,9 +179,9 @@
 
 (defgeneric check-magic-number (stream backend)
   (:argument-precedence-order backend stream)
-  (:method ((stream t) (backend t))
+  (:method ((stream t) (backend backend))
     (let ((magic-number (magic-number backend)))
-      (declare (type ub32 magic-number))
+      (declare (type (or null ub32) magic-number))
       (when magic-number
         (let ((val (read-32-bit stream nil)))
           (declare (type ub32 val))
@@ -202,16 +204,17 @@
    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))
+  (:method ((place t) (backend backend))
     "The default, throw an error."
     (restore-error "get-next-reader must be specialized for backend ~(~A~)."
                    (name backend))))
 
-(defgeneric find-function-for-type (place backend)
-  (:documentation 
-   "Return a function registered with defrestore-? which knows
-   how to retrieve an object from PLACE, uses get-next-reader.")
-  (:method (place backend)
+(defun find-function-for-type (place backend)
+  (declare (type backend backend))
+;;   (:documentation 
+;;    "Return a function registered with defrestore-? which knows
+;;    how to retrieve an object from PLACE, uses get-next-reader.")
+;;   (:method ((place t) (backend backend))
     (multiple-value-bind (val info) (get-next-reader place backend)
       (let ((reader (lookup-reader val (restorer-funs backend))))
         (cond ((and val reader) (values reader val))
@@ -220,23 +223,22 @@
                               (or info "Unknown Type") (name backend)))
               ((not reader)
                (restore-error "No restorer defined for ~A in backend ~(~A~)."
-                              val (name backend))))))))
+                              val (name backend)))))))
 
 ;; Wrapper for backend-restore-object so we don't have to pass
 ;; a backend object around all the time
-(defgeneric restore-object (place &optional backend)
-  (:documentation
-   "Restore the object in PLACE using BACKEND")
-  (:method ((place t) &optional (backend *current-backend*))
-    (backend-restore-object place backend)))
+(declaim (inline restore-object))
+(defun restore-object (place &optional (backend *current-backend*))
+  "Restore the object in PLACE using BACKEND"
+  (backend-restore-object place backend))
+
 
 (defgeneric backend-restore-object (place backend)
   (:documentation
    "Find the next function to call with BACKEND and invoke it with PLACE.")
-  (:method ((place t) (backend t))
+  (:method ((place t) (backend backend))
     "The default"
-    (funcall (the function (find-function-for-type place backend))
-             place)))
+    (funcall (the function (find-function-for-type place backend)) place)))
 
 
 ;; EOF


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.10 cl-store/tests.lisp:1.11
--- cl-store/tests.lisp:1.10	Wed Nov 10 11:43:16 2004
+++ cl-store/tests.lisp	Wed Nov 24 14:27:03 2004
@@ -23,7 +23,6 @@
 (defmacro deftestit (name val)
   `(deftest ,name (restores ,val) t))
 
-
 ;; integers
 (deftestit integer.1 1)
 (deftestit integer.2 0)
@@ -297,7 +296,6 @@
                                       
 
 ;; circular objects
-
 (defvar circ1 (let ((x (list 1 2 3 4)))
                 (setf (cdr (last x)) x)))
 (deftest circ.1 (progn (store circ1 *test-file*)
@@ -489,7 +487,49 @@
 #-(or clisp lispworks openmcl)
 (deftestit gfunction.3 #'(setf cl-store:restore))
 
+(deftest nocirc.1 
+    (let* ((string "FOO")
+           (list `(,string . ,string))
+           (*check-for-circs* nil))
+      (store list *test-file*)
+      (let ((res (restore *test-file*)))
+        (and (not (eq (car res) (cdr res)))
+             (string= (car res) (cdr res)))))
+  t)
+
 
+(defstruct st.bar x)
+(defstruct (st.foo (:conc-name f-)
+                   (:constructor fooo (z y x))
+                   (:copier cp-foo)
+                   (:include st.bar)
+                   (:predicate is-foo)
+                   (:print-function (lambda (obj st dep)
+                                      (declare (ignore dep))
+                                      (print-unreadable-object (obj st :type t) 
+                                        (format st "~A" (f-x obj))))))
+  (y 0 :type integer) (z "" :type simple-string))
+
+
+#+sbcl
+(deftest struct-class.1
+    (let* ((obj (fooo "Z" 2 3))
+           (string (format nil "~A" obj)))
+      (let ((*nuke-existing-classes* t))
+        (store (find-class 'st.foo) *test-file*)
+        (fmakunbound 'cp-foo)
+        (fmakunbound 'is-foo)
+        (fmakunbound 'fooo)
+        (fmakunbound 'f-x)
+        (fmakunbound 'f-y)
+        (fmakunbound 'f-z)
+        (restore *test-file*)
+        (let* ((new-obj (cp-foo (fooo "Z" 2 3)))
+               (new-string (format nil "~A" new-obj)))
+          (list (is-foo new-obj) (equalp obj new-obj)
+                (string= new-string string)
+                (f-x new-obj) (f-y new-obj) (f-z new-obj)))))
+  (t t t 3 2 "Z"))
 
 (defun run-tests (backend)
   (with-backend backend


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.7 cl-store/utils.lisp:1.8
--- cl-store/utils.lisp:1.7	Wed Nov 10 11:43:16 2004
+++ cl-store/utils.lisp	Wed Nov 24 14:27:03 2004
@@ -60,11 +60,11 @@
 
 (defun store-32-bit (obj stream)
   "Write OBJ down STREAM as a 32 bit integer."
-  (declare (ub32 obj))
-  (write-byte (ldb (byte 8 0) obj) stream)
-  (write-byte (ldb (byte 8 8) obj) stream)
-  (write-byte (ldb (byte 8 16) obj) stream)
-  (write-byte (+ 0 (ldb (byte 8 24) obj)) stream))
+  (let ((obj (logand #XFFFFFFFF obj)))
+    (write-byte (ldb (byte 8 0) obj) stream)
+    (write-byte (ldb (byte 8 8) obj) stream)
+    (write-byte (ldb (byte 8 16) obj) stream)
+    (write-byte (+ 0 (ldb (byte 8 24) obj)) stream)))
 
 
 (defmacro make-ub32 (a b c d)
@@ -91,6 +91,9 @@
 (defun retrieve-string-code (stream)
   "Retrieve a String written by store-string-code from STREAM"
   (read stream))
+
+(defun kwd (name)
+  (values (intern (string-upcase name) :keyword)))
 
 
 ;; EOF




From sross at common-lisp.net  Wed Nov 24 13:27:12 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 24 Nov 2004 14:27:12 +0100
Subject: [cl-store-cvs] CVS update: cl-store/acl/custom.lisp 
Message-ID: <E1CWxAu-0004A3-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:10 2004
Author: sross

Index: cl-store/acl/custom.lisp
diff -u cl-store/acl/custom.lisp:1.1 cl-store/acl/custom.lisp:1.2
--- cl-store/acl/custom.lisp:1.1	Mon Nov  1 15:49:00 2004
+++ cl-store/acl/custom.lisp	Wed Nov 24 14:27:10 2004
@@ -29,8 +29,8 @@
 
 (defrestore-cl-store (float stream)
   (let ((byte (read-byte stream)))
-    (aif (cdr (assoc byte *acl-float-restorers*))
-         (funcall it stream)
-         (restore-error "Unknown float type designator ~S." byte))))
+    (ecase byte
+      (0 (acl-restore-single-float stream))
+      (1 (acl-restore-double-float stream)))))
 
 ;; EOF




From sross at common-lisp.net  Wed Nov 24 13:27:20 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 24 Nov 2004 14:27:20 +0100
Subject: [cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp 
Message-ID: <E1CWxB2-0004AG-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:12 2004
Author: sross

Index: cl-store/cmucl/custom.lisp
diff -u cl-store/cmucl/custom.lisp:1.2 cl-store/cmucl/custom.lisp:1.3
--- cl-store/cmucl/custom.lisp:1.2	Wed Oct  6 16:41:07 2004
+++ cl-store/cmucl/custom.lisp	Wed Nov 24 14:27:12 2004
@@ -3,7 +3,6 @@
 
 (in-package :cl-store)
 
-
 (defstore-cl-store (obj float stream)
   (output-type-code +float-code+ stream)    
   (write-byte (float-type obj) stream)
@@ -22,15 +21,11 @@
   (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))))
+    (ecase byte
+      (0 (cmucl-restore-single-float stream))
+      (1 (cmucl-restore-double-float stream)))))
 
 ;; Custom Structures
 (defstore-cl-store (obj structure-object stream)




From sross at common-lisp.net  Wed Nov 24 13:27:22 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 24 Nov 2004 14:27:22 +0100
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <E1CWxB4-0004AS-00@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:20 2004
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.2 cl-store/doc/cl-store.texi:1.3
--- cl-store/doc/cl-store.texi:1.2	Wed Nov 10 11:43:26 2004
+++ cl-store/doc/cl-store.texi	Wed Nov 24 14:27:20 2004
@@ -199,12 +199,46 @@
 not be serialized when storing objects.
 @end deftp
 
+
+ at anchor {Variable *store-hash-size*}
+ at vindex *store-hash-size*
+ at deftp {Variable} *store-hash-size* @emph{Default 1000}
+The default size of the hash-table created to keep track of
+objects which have already been stored. By binding the 
+variable to a suitable value you can avoid the consing
+involved by rehashing hash-tables.
+ at end deftp
+
+ at anchor {Variable *restore-hash-size*}
+ at vindex *restore-hash-size*
+ at deftp {Variable} *restore-hash-size* @emph{Default 1000}
+The default size of the hash-table created to keep track of
+objects which have already been restored. By binding the 
+variable to a suitable value you can avoid the consing
+involved by rehashing hash-tables.
+ at end deftp
+
+
+ at anchor {Variable *check-for-circs*}
+ at vindex *check-for-circs*
+ at deftp {Variable} *check-for-circs* @emph{Default t}
+Binding this variable to nil when storing or restoring
+an object inhibits all checks for circularities which gives a 
+severe boost to performance. The downside of this is that no 
+restored objects will be eq and attempting to store circular objects 
+will hang. The speed improvements are definitely worth it if you 
+know that there will be no circularities or shared references in 
+your data (eg spam-filter hash-tables). 
+ at end deftp
+
+
 @anchor {Variable *default-backend*}
 @vindex *default-backend*
 @deftp {Variable} *default-backend* @emph{Default *cl-store-backend*}
 The backend that will be used by default.
 @end deftp
 
+
 @anchor {Variable *cl-store-backend*}
 @vindex *cl-store-backend*
 @deftp {Variable} *cl-store-backend* 
@@ -705,7 +739,7 @@
 @section Known Issues
 @itemize @bullet
 @item  CLISP, OpenMCL, Allegro CL cannot store structure instances.
- at item  Structure definitions aren't supported.
+ at item  Structure definitions are only supported in SBCL.
 @item  MOP classes aren't supported.
 @item  Due to the fact that function's aren't fully supported CLOS Classes initfunction slot cannot be serialized.
 @end itemize




From sross at common-lisp.net  Wed Nov 24 13:27:24 2004
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 24 Nov 2004 14:27:24 +0100
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <E1CWxB6-0004Ae-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2004-11-24 (0.4 Release)
Date: Wed Nov 24 14:27:23 2004
Author: sross

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.3 cl-store/sbcl/custom.lisp:1.4
--- cl-store/sbcl/custom.lisp:1.3	Wed Nov 10 11:43:33 2004
+++ cl-store/sbcl/custom.lisp	Wed Nov 24 14:27:22 2004
@@ -2,10 +2,11 @@
 ;; See the file LICENCE for licence information.
 
 (in-package :cl-store)
+;; TODO 
+;; real Functions and closures.
 
 
 ;; Custom float storing
-
 (defstore-cl-store (obj float stream)
   (output-type-code +float-code+ stream)
   (write-byte (float-type obj) stream)
@@ -24,17 +25,11 @@
   (sb-kernel:make-double-float (the integer (restore-object stream))
                                (the integer (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)))
-    (declare (type (integer 0 1) byte))
-    (aif (cdr (assoc byte *sbcl-float-restorers* :test #'=))
-         (funcall (the function it) stream)
-         (restore-error "Unknown float type designator ~S." byte))))
-
+    (ecase byte
+      (0 (sbcl-restore-single-float stream))
+      (1 (sbcl-restore-double-float stream)))))
 
 ;; Custom structure storing
 (defstore-cl-store (obj structure-object stream)
@@ -44,5 +39,100 @@
 (defrestore-cl-store (structure-object stream)
   (restore-type-object stream))
 
+
+;; Structure definition storing
+(defun get-layout (obj)
+  (slot-value obj 'sb-pcl::wrapper))
+
+(defun get-info (obj)
+  (declare (type sb-kernel:layout obj))
+  (slot-value obj 'sb-int:info))
+
+(defun dd-name (dd)
+  (slot-value dd 'sb-kernel::name))
+
+(defvar *sbcl-struct-inherits*
+  (list (get-layout (find-class t))
+        (get-layout (find-class 'sb-kernel:instance))
+        (get-layout (find-class 'cl:structure-object))))
+
+(defstruct (struct-def (:conc-name sdef-))
+  (supers (required-arg :supers) :type list)
+  (info (required-arg :info) :type sb-kernel:defstruct-description))
+
+(defun info-or-die (obj)
+  (let ((wrapper (get-layout obj)))
+    (if wrapper
+        (or (get-info wrapper) 
+            (store-error "No defstruct-definition for ~A." obj))
+        (store-error "No wrapper for ~A." obj))))
+
+(defun save-able-supers (obj)
+  (set-difference (coerce (slot-value (get-layout obj) 'sb-kernel::inherits)
+                          'list)
+                  *sbcl-struct-inherits*))
+
+(defun get-supers (obj)
+  (loop for x in (save-able-supers obj) 
+     collect (let ((name (dd-name (get-info x))))
+               (if *store-class-superclasses* 
+                   (find-class name)
+                   name))))
+
+(defstore-cl-store (obj structure-class stream)
+  (output-type-code +structure-class-code+ stream)
+  (store-object (make-struct-def :info (info-or-die obj)
+                                 :supers (get-supers obj))
+                stream))
+
+(defstore-cl-store (obj struct-def stream)
+  (output-type-code +struct-def-code+ stream)
+  (store-object (sdef-supers obj) stream)
+  (store-object (sdef-info obj) stream))
+
+;; Restoring 
+
+(defun sbcl-struct-defs (info)
+  (append (sb-kernel::constructor-definitions info)
+          (sb-kernel::class-method-definitions info)))
+
+(defun create-make-foo (dd)
+  (dolist (x (sbcl-struct-defs dd))
+    (eval x))
+  (find-class (dd-name dd)))
+
+
+(defun sbcl-define-structure (dd supers)
+  (cond ((or *nuke-existing-classes*  
+             (not (find-class (dd-name dd) nil)))
+         ;; create-struct
+         (sb-kernel::%defstruct dd supers)
+         ;; compiler stuff
+         (sb-kernel::%compiler-defstruct dd supers) 
+         ;; create make-?
+         (create-make-foo dd))
+        (t (find-class (dd-name dd)))))
+         
+(defun super-layout (super)
+  (etypecase super
+    (symbol (get-layout (find-class super)))
+    (structure-class 
+     (super-layout (dd-name (info-or-die super))))))
+
+(defun super-layouts (supers)
+  (loop for super in supers 
+     collect (super-layout super)))
+
+(defrestore-cl-store (structure-class stream)
+  (restore-object stream))
+    
+(defrestore-cl-store (struct-def stream)
+  (let* ((supers (super-layouts (restore-object stream)))
+         (dd (restore-object stream)))
+    (sbcl-define-structure dd (if supers 
+                                  (coerce (append  *sbcl-struct-inherits*
+                                                   supers)
+                                          'vector)
+                                  (coerce *sbcl-struct-inherits* 'vector)))))
 
 ;; EOF




From sross at common-lisp.net  Fri Nov 26 14:35:51 2004
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 26 Nov 2004 15:35:51 +0100
Subject: [cl-store-cvs] CVS update: cl-store/README cl-store/backends.lisp
	cl-store/circularities.lisp cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/plumbing.lisp
	cl-store/tests.lisp cl-store/xml-backend.lisp 
Message-ID: <E1CXhCR-0005De-00@common-lisp.net>

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

Modified Files:
	README backends.lisp circularities.lisp cl-store.asd 
	default-backend.lisp plumbing.lisp tests.lisp xml-backend.lisp 
Log Message:
Added structure definition support for CMUCL
Date: Fri Nov 26 15:35:37 2004
Author: sross

Index: cl-store/README
diff -u cl-store/README:1.12 cl-store/README:1.13
--- cl-store/README:1.12	Wed Nov 24 14:27:03 2004
+++ cl-store/README	Fri Nov 26 15:35:36 2004
@@ -1,7 +1,7 @@
 README for Package CL-STORE.
 Author: Sean Ross 
 Homepage: http://www.common-lisp.net/project/cl-store/
-Version: 0.4
+Version: 0.4.1
 
 0. About.
    CL-STORE is an portable serialization package which 


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.5 cl-store/backends.lisp:1.6
--- cl-store/backends.lisp:1.5	Wed Nov 24 14:27:03 2004
+++ cl-store/backends.lisp	Fri Nov 26 15:35:36 2004
@@ -104,8 +104,8 @@
   (assert (symbolp name))
   (let ((class-name (symbolicate name '-backend)))
     `(eval-when (:compile-toplevel :load-toplevel :execute)
-      (prog2 
-          ,(get-class-form class-name fields extends)
+       (prog2 
+        ,(get-class-form class-name fields extends)
           (register-backend ',name ',class-name ,magic-number 
                             ,stream-type ',old-magic-numbers)
         ,(get-store-macro name class-name)


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.12 cl-store/circularities.lisp:1.13
--- cl-store/circularities.lisp:1.12	Wed Nov 24 14:27:03 2004
+++ cl-store/circularities.lisp	Fri Nov 26 15:35:36 2004
@@ -198,9 +198,9 @@
 (defun handle-restore (place backend)
   (multiple-value-bind (reader sym) (find-function-for-type place backend)
     (declare (type function reader) (type symbol sym))
-    (cond ((eq sym 'values-object)
+    (cond ((eql sym 'values-object)
            (handle-values reader place))
-          ((eq sym 'referrer)
+          ((eql sym 'referrer)
            (incf *restore-counter*)
            (new-val (call-it reader place)))
           ((not (int-sym-or-char-p sym backend))


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.14 cl-store/cl-store.asd:1.15
--- cl-store/cl-store.asd:1.14	Wed Nov 24 14:27:03 2004
+++ cl-store/cl-store.asd	Fri Nov 26 15:35:36 2004
@@ -40,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.4"
+  :version "0.4.1"
   :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.13 cl-store/default-backend.lisp:1.14
--- cl-store/default-backend.lisp:1.13	Wed Nov 24 14:27:03 2004
+++ cl-store/default-backend.lisp	Fri Nov 26 15:35:36 2004
@@ -511,10 +511,20 @@
 ;; or signal a store-error.
 (defun parse-name (name)
   (let ((name (subseq name 21)))
+    (declare (type simple-string name))
     (if (search name "SB!" :end1 3)
         (replace name "SB-" :end1 3)
         name)))
 
+#+sbcl
+(defvar *sbcl-readtable* (copy-readtable *readtable*))
+#+sbcl
+(set-macro-character #\# #'(lambda (c s) 
+                             (declare (ignore c s))
+                             (store-error "Invalid character in function name."))
+                     nil
+                     *sbcl-readtable*)
+
 (defstore-cl-store (obj function stream)
   (output-type-code +function-code+ stream)
   (multiple-value-bind (l cp name) (function-lambda-expression obj) 
@@ -524,10 +534,12 @@
           ;;  Try to deal with sbcl's naming convention
           ;; of built in functions
           #+sbcl
-          ((and name (stringp name) (search "top level local call " 
-                                            (the simple-string name)))
-           (let ((new-name (parse-name name))) 
-             (when (not (string= new-name ""))
+          ((and name (stringp name)
+                (search "top level local call "
+                        (the simple-string name)))
+           (let ((new-name (parse-name name))
+                 (*readtable* *sbcl-readtable*))
+             (unless (string= new-name "")
                (handler-case (store-object (read-from-string new-name) stream)
                  (error (c)
                    (declare (ignore c))


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.7 cl-store/plumbing.lisp:1.8
--- cl-store/plumbing.lisp:1.7	Wed Nov 24 14:27:03 2004
+++ cl-store/plumbing.lisp	Fri Nov 26 15:35:36 2004
@@ -71,7 +71,8 @@
   (:documentation "Entry Point for storing objects.")
   (:method ((obj t) (place t) &optional (backend *default-backend*))
     "Store OBJ into Stream PLACE using backend BACKEND."
-    (let ((*current-backend* backend))
+    (let ((*current-backend* backend)
+          (*read-eval* nil))
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'store-error 
                                                       :caused-by c)))))
@@ -131,7 +132,8 @@
    overridden, use backend-restore instead")
   (:method (place &optional (backend *default-backend*))
     "Entry point for restoring objects (setfable)."
-    (let ((*current-backend* backend))
+    (let ((*current-backend* backend)
+          (*read-eval* nil))
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'restore-error
                                                       :caused-by c)))))


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.11 cl-store/tests.lisp:1.12
--- cl-store/tests.lisp:1.11	Wed Nov 24 14:27:03 2004
+++ cl-store/tests.lisp	Fri Nov 26 15:35:36 2004
@@ -508,10 +508,10 @@
                                       (declare (ignore dep))
                                       (print-unreadable-object (obj st :type t) 
                                         (format st "~A" (f-x obj))))))
-  (y 0 :type integer) (z "" :type simple-string))
+  (y 0 :type integer) (z nil :type simple-string))
 
 
-#+sbcl
+#+(or sbcl cmu)
 (deftest struct-class.1
     (let* ((obj (fooo "Z" 2 3))
            (string (format nil "~A" obj)))


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.7 cl-store/xml-backend.lisp:1.8
--- cl-store/xml-backend.lisp:1.7	Wed Nov 10 11:43:16 2004
+++ cl-store/xml-backend.lisp	Fri Nov 26 15:35:36 2004
@@ -163,7 +163,7 @@
   (princ-xml "CHARACTER" (char-code obj) stream))
 
 (defrestore-xml (character place)
-  (code-char (read-from-string (first-child place))))
+  (code-char (parse-integer (first-child place))))
 
 
 




From sross at common-lisp.net  Fri Nov 26 14:35:56 2004
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 26 Nov 2004 15:35:56 +0100
Subject: [cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp 
Message-ID: <E1CXhCW-0005Dq-00@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Added structure definition support for CMUCL
Date: Fri Nov 26 15:35:52 2004
Author: sross

Index: cl-store/cmucl/custom.lisp
diff -u cl-store/cmucl/custom.lisp:1.3 cl-store/cmucl/custom.lisp:1.4
--- cl-store/cmucl/custom.lisp:1.3	Wed Nov 24 14:27:12 2004
+++ cl-store/cmucl/custom.lisp	Fri Nov 26 15:35:51 2004
@@ -36,4 +36,100 @@
   (restore-type-object stream))
 
 
+
+
+;; Structure definitions
+(defun get-layout (obj)
+  (slot-value obj 'pcl::wrapper))
+
+(defun get-info (obj)
+  (declare (type kernel:layout obj))
+  (slot-value obj 'ext:info))
+
+(defun dd-name (dd)
+  (slot-value dd 'kernel::name))
+
+(defvar *cmucl-struct-inherits*
+  (list (get-layout (find-class t))
+        (get-layout (find-class 'kernel:instance))
+        (get-layout (find-class 'cl:structure-object))))
+
+(defstruct (struct-def (:conc-name sdef-))
+  (supers (required-arg :supers) :type list)
+  (info (required-arg :info) :type kernel:defstruct-description))
+
+(defun info-or-die (obj)
+  (let ((wrapper (get-layout obj)))
+    (if wrapper
+        (or (get-info wrapper) 
+            (store-error "No defstruct-definition for ~A." obj))
+        (store-error "No wrapper for ~A." obj))))
+
+(defun save-able-supers (obj)
+  (set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits)
+                          'list)
+                  *cmucl-struct-inherits*))
+
+(defun get-supers (obj)
+  (loop for x in (save-able-supers obj) 
+     collect (let ((name (dd-name (get-info x))))
+               (if *store-class-superclasses* 
+                   (find-class name)
+                   name))))
+
+(defstore-cl-store (obj structure-class stream)
+  (output-type-code +structure-class-code+ stream)
+  (store-object (make-struct-def :info (info-or-die obj)
+                                 :supers (get-supers obj))
+                stream))
+
+(defstore-cl-store (obj struct-def stream)
+  (output-type-code +struct-def-code+ stream)
+  (store-object (sdef-supers obj) stream)
+  (store-object (sdef-info obj) stream))
+
+;; Restoring 
+(defun cmu-struct-defs (dd)
+  (append (kernel::define-constructors dd)
+          (kernel::define-raw-accessors dd)
+          (kernel::define-class-methods dd)))
+
+(defun create-make-foo (dd)
+  (dolist (x (cmu-struct-defs dd))
+    (eval x))
+  (find-class (dd-name dd)))
+
+(defun cmu-define-structure (dd supers)
+  (cond ((or *nuke-existing-classes*  
+             (not (find-class (dd-name dd) nil)))
+         ;; create-struct
+         (kernel::%defstruct dd supers)
+         ;; compiler stuff
+         ;;(kernel::%compiler-defstruct dd) 
+         ;; create make-?
+         (create-make-foo dd))
+        (t (find-class (dd-name dd)))))
+  
+(defun super-layout (super)
+  (etypecase super
+    (symbol (get-layout (find-class super)))
+    (structure-class 
+     (super-layout (dd-name (info-or-die super))))))
+
+(defun super-layouts (supers)
+  (loop for super in supers 
+     collect (super-layout super)))
+
+(defrestore-cl-store (structure-class stream)
+  (restore-object stream))
+    
+(defrestore-cl-store (struct-def stream)
+  (let* ((supers (super-layouts (restore-object stream)))
+         (dd (restore-object stream)))
+    (cmu-define-structure dd (if supers 
+                                 (coerce (append  *cmucl-struct-inherits*
+                                                  supers)
+                                         'vector)
+                                 (coerce *cmucl-struct-inherits* 'vector)))))
+
 ;; EOF




From sross at common-lisp.net  Fri Nov 26 14:36:01 2004
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 26 Nov 2004 15:36:01 +0100
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <E1CXhCb-0005E4-00@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Added structure definition support for CMUCL
Date: Fri Nov 26 15:35:58 2004
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.3 cl-store/doc/cl-store.texi:1.4
--- cl-store/doc/cl-store.texi:1.3	Wed Nov 24 14:27:20 2004
+++ cl-store/doc/cl-store.texi	Fri Nov 26 15:35:54 2004
@@ -107,7 +107,8 @@
 @item Instances of CLOS Classes
 @item CLOS Classes
 @item Structure Instances
- at item Functions (where function-lambda-expression returns a symbol as a function name)
+ at item Structure Definitions (CMUCL and SBCL only)
+ at item Functions (stores the function name)
 @item Generic Functions (stores generic-function-name)
 @end itemize