From sross at common-lisp.net  Tue Feb  1 08:23:27 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:23:27 -0800 (PST)
Subject: [cl-store-cvs] CVS update: Directory change: cl-store/ecl
Message-ID: <20050201082327.22D6E8802D@common-lisp.net>

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

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

Date: Tue Feb  1 00:23:26 2005
Author: sross
New directory cl-store/ecl added


From sross at common-lisp.net  Tue Feb  1 08:27:38 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:27:38 -0800 (PST)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	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: <20050201082738.8013B8802D@common-lisp.net>

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

Modified Files:
	ChangeLog backends.lisp circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp xml-backend.lisp 
Log Message:
Changelog 2005-02-01
Date: Tue Feb  1 00:27:26 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.17 cl-store/ChangeLog:1.18
--- cl-store/ChangeLog:1.17	Thu Dec  2 02:31:54 2004
+++ cl-store/ChangeLog	Tue Feb  1 00:27:26 2005
@@ -1,3 +1,11 @@
+2005-02-01 Sean Ross <sross at common-lisp.net>
+	* various: Large patch which has removed pointless 
+	argument-precedence-order from various gf's, added the 
+	start of support for ecl, renamed fix-clisp.lisp file to 
+	mop.lisp, and changed resolving-object and setting 
+	to use delays allowing get-setf-place and *postfix-setter*
+	to be removed.
+	
 2004-12-02 Sean Ross <sross at common-lisp.net>
 	* sbcl/custom.lisp, cmucl/custom.lisp: Changed the evals when restoring
 	structure definitions to (funcall (compile nil ...))


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.6 cl-store/backends.lisp:1.7
--- cl-store/backends.lisp:1.6	Fri Nov 26 06:35:36 2004
+++ cl-store/backends.lisp	Tue Feb  1 00:27:26 2005
@@ -45,7 +45,6 @@
         ((,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)
@@ -54,7 +53,6 @@
     `(defmacro ,macro-name ((type place) &body body)
       (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
         `(flet ((,fn-name (,place) 
-;                  (declare (optimize (speed 3) (safety 1) (debug 0)))
                   , at body))
           (let* ((backend (find-backend ',',name))
                  (restorers (restorer-funs backend)))


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.13 cl-store/circularities.lisp:1.14
--- cl-store/circularities.lisp:1.13	Fri Nov 26 06:35:36 2004
+++ cl-store/circularities.lisp	Tue Feb  1 00:27:26 2005
@@ -19,22 +19,22 @@
 ;; programs according to the Hyperspec(notes in EQ).
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
+;(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 
 (defvar *check-for-circs* t)
 
+(defstruct delay 
+  value (completed nil))
 
-(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*."
-  (cond ((atom place) `(,place ,obj))
-        ((member (the symbol (car place)) *postfix-setters*)
-         `(, at place ,obj))
-        (t `(,(car place) ,obj ,@(cdr place)))))
+(defmacro delay (&rest body)
+  `(make-delay :value #'(lambda () , at body)))
+
+(defun force (delay)
+  (unless (delay-completed delay)
+    (setf (delay-value delay) (funcall (delay-value delay))
+          (delay-completed delay) t))
+  (delay-value delay))
 
 
 ;; The definitions for setting and setting-hash sits in resolving-object.
@@ -51,37 +51,30 @@
   (declare (ignore getting-key getting-value))
   (error "setting-hash can only be used inside a resolving-object form."))
 
-(defmacro resolving-object (create &body body)
+(defmacro resolving-object ((var create) &body body)
   "Execute body attempting to resolve circularities found in 
    form CREATE."
-  (with-gensyms (obj value key)
+  (with-gensyms (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)))))
+                  `(let ((,',value ,getting))
+                     (if (referrer-p ,',value)
+                         (push (delay (setf ,place (referred-value ,',value *restored-values*)))
+                               *need-to-fix*)
+                         (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)))
+                           (push (delay (setf (gethash (referred-value ,',key *restored-values*)
+                                                       ,',var)
+                                              (if (referrer-p ,',value)
+                                                  (referred-value ,',value *restored-values*)
+                                                  ,',value)))
                                  *need-to-fix*))
-                         (setting (gethash ,',key) ,getting-place)))))
-       (let ((,obj ,create))
+                         (setting (gethash ,',key ,',var) ,getting-place)))))
+       (let ((,var ,create))
          , at body
-         ,obj))))
+         ,var))))
 
 (defstruct referrer 
   val)
@@ -102,11 +95,11 @@
 (defvar *store-hash-size* 1000)
 
 
-(defmethod backend-store ((obj t) (place stream) (backend resolving-backend))
+(defmethod backend-store ((backend resolving-backend) (place stream) (obj t))
   "Store OBJ into PLACE. Does the setup for counters and seen values."
   (let ((*stored-counter* 0) 
         (*stored-values* (make-hash-table :test #'eq :size *store-hash-size*))) 
-    (store-backend-code place backend)
+    (store-backend-code backend place)
     (backend-store-object obj place backend)
     obj))
 
@@ -157,17 +150,17 @@
 (defvar *restored-values*)
 (defvar *restore-hash-size* 1000)
 
-(defmethod backend-restore ((place stream) (backend resolving-backend))
+(defmethod backend-restore ((backend resolving-backend) (place stream))
   "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 :test #'eq :size *restore-hash-size*)))
-    (check-magic-number place backend)
+    (check-magic-number backend place)
     (multiple-value-prog1
       (backend-restore-object place backend)
       (dolist (fn *need-to-fix*)
-        (funcall (the function fn))))))
+        (force fn)))))
 
 (defun update-restored (spot val)
   (setf (gethash spot *restored-values*) val))
@@ -203,7 +196,7 @@
           ((eql sym 'referrer)
            (incf *restore-counter*)
            (new-val (call-it reader place)))
-          ((not (int-sym-or-char-p sym backend))
+          ((not (int-sym-or-char-p backend sym))
            (handle-normal reader place))
           (t (new-val (funcall reader place))))))
 
@@ -213,9 +206,8 @@
       (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 symbol) (backend backend))
+(defgeneric int-sym-or-char-p (backend fn)
+  (:method ((backend backend) (fn symbol))
     "Is function FN registered to restore an integer, character or symbol
   in BACKEND."
     (member fn '(integer character symbol))))


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.16 cl-store/cl-store.asd:1.17
--- cl-store/cl-store.asd:1.16	Thu Dec  2 02:31:54 2004
+++ cl-store/cl-store.asd	Tue Feb  1 00:27:26 2005
@@ -15,7 +15,7 @@
 
 (defun lisp-system-shortname ()
   #+mcl :mcl #+lispworks :lispworks #+cmu :cmucl #+clisp :clisp #+sbcl :sbcl
-  #+allegro :acl)
+  #+allegro :acl #+ecl :ecl)
 
 (defmethod component-pathname ((component non-required-file))
   (let ((pathname (call-next-method))
@@ -40,12 +40,12 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.4.2"
+  :version "0.4.5"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"
   :components ((:file "package")
-               (:non-required-file "fix-clisp" :depends-on ("package"))
+               (:non-required-file "mop" :depends-on ("package"))
                (:file "utils" :depends-on ("package"))
                (:file "backends" :depends-on ("utils"))
                (:file "plumbing" :depends-on ("backends"))


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.15 cl-store/default-backend.lisp:1.16
--- cl-store/default-backend.lisp:1.15	Thu Dec  2 02:31:54 2004
+++ cl-store/default-backend.lisp	Tue Feb  1 00:27:26 2005
@@ -5,8 +5,6 @@
 
 (in-package :cl-store)
 
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
-
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *cl-store-backend*
     (defbackend cl-store :magic-number 1886611820 
@@ -82,6 +80,7 @@
   (gethash code *restorers*))
 
 (defmethod get-next-reader ((stream stream) (backend cl-store-backend))
+  (declare (ignore backend))
   (let ((type-code (read-type-code stream)))
     (or (lookup-code type-code) ;(gethash type-code *restorers*)
         (values nil (format nil "Type ~A" type-code)))))
@@ -89,6 +88,7 @@
 
 ;; referrer, Required for a resolving backend
 (defmethod store-referrer (ref stream (backend cl-store-backend))
+  (declare (ignore backend))
   (output-type-code +referrer-code+ stream)
   (dump-int ref stream))
 
@@ -101,7 +101,8 @@
 ;; so we we have a little optimization for it
 
 ;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((fn symbol) (backend cl-store-backend))
+(defmethod int-sym-or-char-p ((backend cl-store-backend) (fn symbol))
+  (declare (ignore backend))
   (member fn '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
@@ -234,9 +235,9 @@
 ;; this is an examples of a restorer which handles 
 ;; circularities using resolving-object and setting.
 (defrestore-cl-store (cons stream)
-  (resolving-object (cons nil nil)
-    (setting car (restore-object stream))
-    (setting cdr (restore-object stream))))
+  (resolving-object (x (cons nil nil))
+    (setting (car x) (restore-object stream))
+    (setting (cdr x) (restore-object stream))))
 
 ;; pathnames
 (defstore-cl-store (obj pathname stream)
@@ -280,7 +281,7 @@
                                  :rehash-size rehash-size
                                  :rehash-threshold rehash-threshold
                                  :size size)))
-      (resolving-object hash
+      (resolving-object (x hash)
         (loop repeat count do
               ;; Unfortunately we can't use the normal setting here
               ;; since there could be a circularity in the key
@@ -328,8 +329,8 @@
           (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)))))
+            (resolving-object (obj new-instance)
+              (setting (slot-value obj slot-name) (restore-object stream)))))
     new-instance))
 
 #-lispworks
@@ -349,8 +350,7 @@
   (store-object (mapcar (if *store-class-superclasses*
                             #'identity 
                             #'class-name)
-                        (remove (find-class 'standard-object)
-                                (class-direct-superclasses obj)))
+                        (class-direct-superclasses obj))
                 stream)
   (store-object (type-of obj) stream))
 
@@ -364,7 +364,7 @@
          (final (mappend #'list keywords (list slots supers meta))))
     (cond ((find-class class nil)
            (cond (*nuke-existing-classes*
-                  (apply #'ensure-class class final)
+                  (apply #'ensure-class  class final)
                   #+clisp (add-methods-for-class class slots))
                  (t (find-class class))))
           (t (apply #'ensure-class class final)
@@ -385,7 +385,7 @@
 
 
 
-;; Arrays and Vectors and Strings
+;; Arrays, vectors and strings.
 (defstore-cl-store (obj array stream)
   (typecase obj
     (simple-string (store-simple-string obj stream))
@@ -423,11 +423,10 @@
     (when displaced-to 
       (adjust-array res dimensions :displaced-to displaced-to
                     :displaced-index-offset displaced-offset))
-    (resolving-object res
+    (resolving-object (obj res)
       (loop for x from 0 to (1- size) do
             (let ((pos x))
-              (setting (row-major-aref pos) (restore-object stream)))))
-    res))
+              (setting (row-major-aref obj pos) (restore-object stream)))))))
 
 (defun store-simple-vector (obj stream)
   (declare (type simple-vector obj))
@@ -441,12 +440,12 @@
   (let* ((size (restore-object stream))
          (res (make-array size)))
     (declare (type array-size size))
-    (resolving-object res
+    (resolving-object (obj res)
       (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)))))
+              (setting (aref obj x) (restore-object stream)))))
     res))
 
 ;; Dumping (unsigned-byte 32) for each character seems


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.15 cl-store/package.lisp:1.16
--- cl-store/package.lisp:1.15	Wed Nov 24 05:27:03 2004
+++ cl-store/package.lisp	Tue Feb  1 00:27:26 2005
@@ -31,8 +31,6 @@
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name
                        #:slot-definition-name
-                       #:slot-value-using-class
-                       #:slot-boundp-using-class
                        #:slot-definition-allocation
                        #:compute-slots
                        #:slot-definition-initform
@@ -47,11 +45,18 @@
                        #:class-slots
                        #:ensure-class)
 
+  #+ecl (:import-from #:clos
+                      #:generic-function-name
+                      #:compute-slots
+                      #:class-direct-default-initargs
+                      #:class-direct-slots
+                      #: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
                        #:slot-definition-allocation
                        #:compute-slots
                        #:slot-definition-initform
@@ -75,8 +80,6 @@
   #+openmcl (:import-from #:openmcl-mop
                           #:generic-function-name
                           #:slot-definition-name
-                          #:slot-value-using-class
-                          #:slot-boundp-using-class
                           #:slot-definition-allocation
                           #:compute-slots
                           #:slot-definition-initform
@@ -104,8 +107,6 @@
   #+lispworks  (:import-from #:clos
                              #:slot-definition-name
                              #:generic-function-name
-                             #:slot-value-using-class
-                             #:slot-boundp-using-class
                              #:slot-definition-allocation
                              #:compute-slots
                              #:slot-definition-initform
@@ -123,8 +124,6 @@
   #+allegro (:import-from #:mop
                           #:slot-definition-name
                           #:generic-function-name
-                          #:slot-value-using-class
-                          #:slot-boundp-using-class
                           #:slot-definition-allocation
                           #:compute-slots
                           #:slot-definition-initform


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.8 cl-store/plumbing.lisp:1.9
--- cl-store/plumbing.lisp:1.8	Fri Nov 26 06:35:36 2004
+++ cl-store/plumbing.lisp	Tue Feb  1 00:27:26 2005
@@ -5,7 +5,6 @@
 ;; 
 
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 (defvar *nuke-existing-classes* nil
   "Do we overwrite existing class definitions on restoration.")
@@ -65,7 +64,7 @@
                          (integer '(unsigned-byte 8)))))
     (with-open-file (s place :element-type element-type
                        :direction :output :if-exists :supersede)
-      (backend-store obj s backend))))
+      (backend-store backend s obj))))
 
 (defgeneric store (obj place &optional backend) 
   (:documentation "Entry Point for storing objects.")
@@ -76,28 +75,26 @@
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'store-error 
                                                       :caused-by c)))))
-        (backend-store obj place backend)))))
+        (backend-store backend place obj)))))
 
-(defgeneric backend-store (obj place backend)
-  (:argument-precedence-order backend place obj)
-  (:method ((obj t) (place stream) (backend backend))
+(defgeneric backend-store (backend place obj)
+  (:method ((backend backend) (place stream) (obj t))
     "The default. Checks the streams element-type, stores the backend code
      and calls store-object."
-    (store-backend-code place backend)
+    (store-backend-code backend place)
     (store-object obj place backend)
     obj)
-  (:method ((obj t) (place string) (backend backend))
+  (:method ((backend backend) (place string) (obj t))
     "Store OBJ into file designator PLACE."
     (store-to-file obj place backend))
-  (:method ((obj t) (place pathname) (backend backend))
+  (:method ((backend backend) (place pathname) (obj t))
     "Store OBJ into file designator PLACE."
     (store-to-file obj place backend))
   (:documentation "Method wrapped by store, override this method for 
     custom behaviour (see circularities.lisp)."))
 
-(defgeneric store-backend-code (stream backend)
-  (:argument-precedence-order backend stream)
-  (:method ((stream t) (backend backend))
+(defgeneric store-backend-code (backend stream)
+  (:method ((backend backend) (stream t))
     (awhen (magic-number backend)
       (store-32-bit it stream)))
   (:documentation
@@ -137,21 +134,20 @@
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'restore-error
                                                       :caused-by c)))))
-        (backend-restore place backend)))))
+        (backend-restore backend place)))))
 
   
-(defgeneric backend-restore (place backend)
-  (:argument-precedence-order backend place)
+(defgeneric backend-restore (backend place)
   (:documentation "Wrapped by restore. Override this to do custom restoration")
-  (:method ((place stream) (backend backend))
+  (:method ((backend backend) (place stream))
     "Restore the object found in stream PLACE using backend BACKEND.
      Checks the magic-number and invokes backend-restore-object"
-    (check-magic-number place backend)
+    (check-magic-number backend place)
     (backend-restore-object place backend))
-  (:method ((place string) (backend backend))
+  (:method ((backend backend) (place string))
     "Restore the object found in file designator PLACE using backend BACKEND."
     (restore-from-file place backend))
-  (:method ((place pathname) (backend backend))
+  (:method ((backend backend) (place pathname))
     "Restore the object found in file designator PLACE using backend BACKEND."
     (restore-from-file place backend)))
 
@@ -161,7 +157,7 @@
                          (character 'character)
                          (integer '(unsigned-byte 8)))))
     (with-open-file (s place :element-type element-type :direction :input)
-      (backend-restore s backend))))
+      (backend-restore backend s))))
      
 (defclass values-object ()
   ((vals :accessor vals :initarg :vals))
@@ -180,8 +176,7 @@
   (store new-val place))
 
 (defgeneric check-magic-number (stream backend)
-  (:argument-precedence-order backend stream)
-  (:method ((stream t) (backend backend))
+  (:method ((backend backend) (stream t))
     (let ((magic-number (magic-number backend)))
       (declare (type (or null ub32) magic-number))
       (when magic-number


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.12 cl-store/tests.lisp:1.13
--- cl-store/tests.lisp:1.12	Fri Nov 26 06:35:36 2004
+++ cl-store/tests.lisp	Tue Feb  1 00:27:26 2005
@@ -96,8 +96,12 @@
 
 #+(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))
+  (deftestit unicode.1 (map #-lispworks 'string
+                            #+lispworks 'lw:text-string
+                            #'code-char (list #X20AC #X3BB)))
+  (deftestit unicode.2 (intern (map #-lispworks 'string
+                                    #+lispworks 'lw:text-string
+                                    #'code-char (list #X20AC #X3BB))
                                :cl-store-tests)))
 
 ;; vectors
@@ -478,13 +482,12 @@
 
 (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 function.3 #'(setf car))
 
 (deftestit gfunction.1 #'cl-store:restore)
 (deftestit gfunction.2 #'cl-store:store)
-#-(or clisp lispworks openmcl)
+#-(or clisp openmcl)
 (deftestit gfunction.3 #'(setf cl-store:restore))
 
 (deftest nocirc.1 


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.8 cl-store/utils.lisp:1.9
--- cl-store/utils.lisp:1.8	Wed Nov 24 05:27:03 2004
+++ cl-store/utils.lisp	Tue Feb  1 00:27:26 2005
@@ -3,7 +3,7 @@
 
 ;; Miscellaneous utilities used throughout the package.
 (in-package :cl-store)
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
+;(declaim (optimize (speed 3) (safety 1) (debug 1)))
 
 
 (defmacro aif (test then &optional else)


Index: cl-store/xml-backend.lisp
diff -u cl-store/xml-backend.lisp:1.9 cl-store/xml-backend.lisp:1.10
--- cl-store/xml-backend.lisp:1.9	Thu Dec  2 02:31:54 2004
+++ cl-store/xml-backend.lisp	Tue Feb  1 00:27:26 2005
@@ -92,7 +92,7 @@
   
 
 ;; override backend restore to parse the incoming stream
-(defmethod backend-restore ((place stream) (backend xml-backend))
+(defmethod backend-restore ((backend xml-backend) (place stream))
   (let ((*restore-counter* 0)
         (*need-to-fix* nil)
         (*print-circle* nil)



From sross at common-lisp.net  Tue Feb  1 08:27:40 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:27:40 -0800 (PST)
Subject: [cl-store-cvs] CVS update: cl-store/clisp/mop.lisp
	cl-store/clisp/fix-clisp.lisp 
Message-ID: <20050201082740.693498802D@common-lisp.net>

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

Added Files:
	mop.lisp 
Removed Files:
	fix-clisp.lisp 
Log Message:
Changelog 2005-02-01
Date: Tue Feb  1 00:27:38 2005
Author: sross






From sross at common-lisp.net  Tue Feb  1 08:27:42 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:27:42 -0800 (PST)
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <20050201082742.B8C898802D@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Changelog 2005-02-01
Date: Tue Feb  1 00:27:40 2005
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.5 cl-store/doc/cl-store.texi:1.6
--- cl-store/doc/cl-store.texi:1.5	Thu Dec  2 02:32:02 2004
+++ cl-store/doc/cl-store.texi	Tue Feb  1 00:27:40 2005
@@ -468,7 +468,7 @@
 @end deffn 
 
 @anchor {Macro resolving-object}
- at deffn {Macro} resolving-object object &body body 
+ at deffn {Macro} resolving-object (var create) &body body 
 Executes @emph{body} resolving circularities detected in @emph{object}. 
 Resolving-object works by creating a closure, containing code to set a 
 particular place in @emph{object}, which is then pushed onto a list. 
@@ -477,9 +477,9 @@
 Example.
 @lisp
 (defrestore-cl-store (cons stream)
-  (resolving-object (cons nil nil)
-    (setting car (restore-object stream))
-    (setting cdr (restore-object stream))))
+  (resolving-object (object (cons nil nil))
+    (setting (car object) (restore-object stream))
+    (setting (cdr object) (restore-object stream))))
 @end lisp
 @end deffn
 
@@ -489,24 +489,18 @@
 @deffn {Macro} setting place get
 This macro can only be used inside @code{resolving-object}. It sets the value 
 designated by @emph{place} to @emph{get} for the object that is being resolved.
- at emph{Place} should be either a symbol or a list. By default we assume that the
-order of the arguments to (setf @emph{place}) is first the object to set and then
-the rest of the arguments. To work around instances where the order is reversed
-as in gethash, there is a variable called @code{*postfix-setters*}.  
-If the first element of place is in @code{*postfix-setters*} the setting macro 
-will adjust accordingly.
 
 Example.
 @lisp
 (defrestore-cl-store (simple-vector stream)
   (let* ((size (restore-object stream))
         (res (make-array size)))
-    (resolving-object res
+    (resolving-object (object res)
      (loop repeat size for i from 0 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)))))
+         (setting (aref object x) (restore-object stream)))))
     res))
 @end lisp
 @end deffn
@@ -528,7 +522,7 @@
                                  :rehash-size rehash-size
                                  :rehash-threshold rehash-threshold
                                  :size size)))
-      (resolving-object hash
+      (resolving-object (obj hash)
         (loop repeat count do
               (setting-hash (restore-object stream) 
                             (restore-object stream))))



From sross at common-lisp.net  Tue Feb  1 08:27:49 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:27:49 -0800 (PST)
Subject: [cl-store-cvs] CVS update: cl-store/ecl/mop.lisp 
Message-ID: <20050201082749.5CDEA8802D@common-lisp.net>

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

Added Files:
	mop.lisp 
Log Message:
Changelog 2005-02-01
Date: Tue Feb  1 00:27:43 2005
Author: sross




From sross at common-lisp.net  Tue Feb  1 08:27:53 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  1 Feb 2005 00:27:53 -0800 (PST)
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp 
Message-ID: <20050201082753.5939C8802D@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-02-01
Date: Tue Feb  1 00:27:49 2005
Author: sross

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.4 cl-store/lispworks/custom.lisp:1.5
--- cl-store/lispworks/custom.lisp:1.4	Mon Nov  1 06:32:02 2004
+++ cl-store/lispworks/custom.lisp	Tue Feb  1 00:27:49 2005
@@ -80,8 +80,8 @@
           (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)))))
+            (resolving-object (obj new-instance)
+              (setting (slot-value obj slot-name) (restore-object stream)))))
     new-instance))
 
 
@@ -104,8 +104,8 @@
           (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)))))
+            (resolving-object (obj new-instance)
+              (setting (slot-value obj slot-name) (restore-object stream)))))
     new-instance))
 
 



From sross at common-lisp.net  Thu Feb  3 11:55:14 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  3 Feb 2005 12:55:14 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	cl-store/default-backend.lisp cl-store/utils.lisp 
Message-ID: <20050203115514.C66B688666@common-lisp.net>

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

Modified Files:
	ChangeLog default-backend.lisp utils.lisp 
Log Message:
Changelog 2005-02-03
Date: Thu Feb  3 12:55:13 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.18 cl-store/ChangeLog:1.19
--- cl-store/ChangeLog:1.18	Tue Feb  1 09:27:26 2005
+++ cl-store/ChangeLog	Thu Feb  3 12:55:13 2005
@@ -1,3 +1,10 @@
+2005-02-03 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Fixed hash-table restoration,
+	it no longer assumes that the result of hash-table-test
+	is a symbol but treats it as a function designator.
+	* default-backend.lisp: Added various declarations
+	to help improve speed.
+	
 2005-02-01 Sean Ross <sross at common-lisp.net>
 	* various: Large patch which has removed pointless 
 	argument-precedence-order from various gf's, added the 


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.16 cl-store/default-backend.lisp:1.17
--- cl-store/default-backend.lisp:1.16	Tue Feb  1 09:27:26 2005
+++ cl-store/default-backend.lisp	Thu Feb  3 12:55:13 2005
@@ -103,7 +103,7 @@
 ;; We need this for circularity stuff.
 (defmethod int-sym-or-char-p ((backend cl-store-backend) (fn symbol))
   (declare (ignore backend))
-  (member fn '(integer character 32-bit-integer symbol)))
+  (find fn '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
   (if (typep obj 'sb32)
@@ -111,26 +111,31 @@
       (store-arbitrary-integer obj stream)))
 
 (defun dump-int (obj stream)
+  (declare (optimize speed))
   (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)
+  (declare (optimize speed))
   (ecase (read-byte stream)
     (1 (read-byte stream))
     (2 (read-32-bit stream nil))))
 
 (defun store-32-bit-integer (obj stream)
+  (declare (optimize speed) (type sb32 obj))
   (output-type-code +32-bit-integer-code+ stream)
   (write-byte (if (minusp obj) 1 0) stream)
   (dump-int (abs obj) stream))
 
 (defrestore-cl-store (32-bit-integer stream)
+  (declare (optimize speed))
   (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-)
            (undump-int stream)))
 
 (defun store-arbitrary-integer (obj stream)
-  (declare (type integer obj) (stream stream))
+  (declare (type integer obj) (stream stream)
+           (optimize speed))
   (output-type-code +integer-code+ stream)
   (loop for n = (abs obj) then (ash n -32)
         for counter from 0
@@ -146,6 +151,7 @@
                     (dump-int num stream)))))
 
 (defrestore-cl-store (integer buff)
+  (declare (optimize speed))
   (let ((count (restore-object buff))
         (result 0))
     (declare (type integer result count))
@@ -277,7 +283,7 @@
         (test (restore-object stream))
         (count (restore-object stream)))
     (declare (type integer count size))
-    (let ((hash (make-hash-table :test (symbol-function test)
+    (let ((hash (make-hash-table :test test
                                  :rehash-size rehash-size
                                  :rehash-threshold rehash-threshold
                                  :size size)))
@@ -455,7 +461,8 @@
   "Largest character that can be represented in 8 bits")
 
 (defun store-simple-string (obj stream)
-  (declare (type simple-string obj))
+  (declare (type simple-string obj)
+           (optimize speed))
   ;; must be a better test than this.
   (cond ((some #'(lambda (x) (char> x *char-marker*)) obj)
          ;; contains wide characters
@@ -465,19 +472,23 @@
            (dump-string #'write-byte obj stream))))
 
 (defun dump-string (dumper obj stream)
-  (declare (simple-string obj) (function dumper) (stream stream))
+  (declare (simple-string obj) (function dumper) (stream stream)
+           (optimize speed))
   (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)
+  (declare (optimize speed))
   (undump-string #'read-byte stream))
 
 (defrestore-cl-store (unicode-string stream)
+  (declare (optimize speed))
   (undump-string #'undump-int stream))
 
 (defun undump-string (reader stream)
-  (declare (type function reader) (type stream stream))
+  (declare (type function reader) (type stream stream)
+           (optimize speed))
   (let* ((length (the array-size (undump-int stream)) )
          (res (make-string length 
                            #+lispworks :element-type #+lispworks 'character)))


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.9 cl-store/utils.lisp:1.10
--- cl-store/utils.lisp:1.9	Tue Feb  1 09:27:26 2005
+++ cl-store/utils.lisp	Thu Feb  3 12:55:13 2005
@@ -3,8 +3,6 @@
 
 ;; Miscellaneous utilities used throughout the package.
 (in-package :cl-store)
-;(declaim (optimize (speed 3) (safety 1) (debug 1)))
-
 
 (defmacro aif (test then &optional else)
   `(let ((it ,test))
@@ -60,18 +58,19 @@
 
 (defun store-32-bit (obj stream)
   "Write OBJ down STREAM as a 32 bit integer."
+  (declare (optimize speed))
   (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)
   `(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."
+  (declare (optimize speed))
   (let ((byte1 (read-byte buf))
         (byte2 (read-byte buf))
         (byte3 (read-byte buf))
@@ -96,4 +95,4 @@
   (values (intern (string-upcase name) :keyword)))
 
 
-;; EOF
\ No newline at end of file
+;; EOF



From sross at common-lisp.net  Thu Feb  3 11:59:13 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  3 Feb 2005 12:59:13 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/cl-store.asd 
Message-ID: <20050203115913.31BAD88666@common-lisp.net>

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

Modified Files:
	cl-store.asd 
Log Message:
Changelog 2005-02-03
Date: Thu Feb  3 12:59:12 2005
Author: sross

Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.17 cl-store/cl-store.asd:1.18
--- cl-store/cl-store.asd:1.17	Tue Feb  1 09:27:26 2005
+++ cl-store/cl-store.asd	Thu Feb  3 12:59:12 2005
@@ -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.5"
+  :version "0.4.6"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"



From sross at common-lisp.net  Fri Feb 11 12:00:39 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 11 Feb 2005 13:00:39 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/acl/custom.lisp 
Message-ID: <20050211120039.B1A338869A@common-lisp.net>

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

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

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



From sross at common-lisp.net  Fri Feb 11 12:00:42 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 11 Feb 2005 13:00:42 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/cmucl/custom.lisp 
Message-ID: <20050211120042.5B3F488696@common-lisp.net>

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

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

Index: cl-store/cmucl/custom.lisp
diff -u cl-store/cmucl/custom.lisp:1.5 cl-store/cmucl/custom.lisp:1.6
--- cl-store/cmucl/custom.lisp:1.5	Thu Dec  2 11:31:59 2004
+++ cl-store/cmucl/custom.lisp	Fri Feb 11 13:00:39 2005
@@ -3,29 +3,31 @@
 
 (in-package :cl-store)
 
-(defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)    
-  (write-byte (float-type obj) stream)
-  (etypecase obj
-    (single-float (store-object (kernel:single-float-bits obj)
-                                stream))
-    (double-float (store-object (kernel:double-float-high-bits obj)
-                                stream)
-                  (store-object (kernel:double-float-low-bits obj)
-                                stream))))
-
-(defun cmucl-restore-single-float (stream)
-  (kernel:make-single-float (restore-object stream)))
-
-(defun cmucl-restore-double-float (stream)
-  (kernel:make-double-float (restore-object stream)
-                            (restore-object stream)))
-
-(defrestore-cl-store (float stream)
-  (let ((byte (read-byte stream)))
-    (ecase byte
-      (0 (cmucl-restore-single-float stream))
-      (1 (cmucl-restore-double-float stream)))))
+(defvar +single-positive-infinity+ most-positive-single-float)
+(defvar +single-negative-infinity+ most-negative-single-float)
+(defvar +single-nan+)
+
+(defvar +double-positive-infinity+ most-positive-double-float)
+(defvar +double-negative-infinity+ most-negative-double-float)
+(defvar +double-nan+)
+
+(ext:with-float-traps-masked (:overflow :invalid)
+  (setf +single-positive-infinity+ (expt +single-positive-infinity+ 2))
+  (setf +single-negative-infinity+ (expt +single-negative-infinity+ 3))
+  (setf +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))
+  (setf +double-positive-infinity+ (expt +double-positive-infinity+ 2))
+  (setf +double-negative-infinity+ (expt +double-negative-infinity+ 3))
+  (setf +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+)))
+
+(setf *special-floats*
+  (list (cons +double-positive-infinity+ +positive-double-infinity-code+)
+        (cons +single-positive-infinity+ +positive-infinity-code+)
+        (cons +single-negative-infinity+ +negative-infinity-code+)
+        (cons +double-negative-infinity+ +negative-double-infinity-code+)
+        (cons +single-nan+ +float-nan-code+)
+        (cons +double-nan+ +float-double-nan-code+)))
+
+
 
 ;; Custom Structures
 (defstore-cl-store (obj structure-object stream)
@@ -34,9 +36,6 @@
 
 (defrestore-cl-store (structure-object stream)
   (restore-type-object stream))
-
-
-
 
 ;; Structure definitions
 (defun get-layout (obj)



From sross at common-lisp.net  Fri Feb 11 12:00:48 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 11 Feb 2005 13:00:48 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/lispworks/custom.lisp 
Message-ID: <20050211120048.286B288696@common-lisp.net>

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

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

Index: cl-store/lispworks/custom.lisp
diff -u cl-store/lispworks/custom.lisp:1.5 cl-store/lispworks/custom.lisp:1.6
--- cl-store/lispworks/custom.lisp:1.5	Tue Feb  1 09:27:49 2005
+++ cl-store/lispworks/custom.lisp	Fri Feb 11 13:00:41 2005
@@ -3,63 +3,18 @@
 
 (in-package :cl-store)
 
-;; custom support for infinite floats from Alain Picard.
-(defconstant +positive-infinity+ (expt most-positive-double-float 2))
-(defconstant +negative-infinity+ (expt most-negative-double-float 3))
-(defconstant +nan-float+ (/ (expt most-positive-double-float 2)
-                               (expt most-positive-double-float 2)))
-
-(defun positive-infinity-p (number)
-  (> number most-positive-double-float))
-
-(defun negative-infinity-p (number)
-  (< number most-negative-double-float))
-
-(defun float-nan-p (number)
-  (eql number +nan-float+))
-
-;; Attempt at fixing broken storing infinity problem
-(defstore-cl-store (obj float stream)
-  (block body
-    (let (significand exponent sign)
-      (handler-bind ((simple-error
-                      #'(lambda (err)
-                          (declare (ignore err))
-                          (cond
-                            ((positive-infinity-p obj)
-                             (output-type-code +positive-infinity-code+ stream)
-                             (return-from body)) ; success
-                            ((negative-infinity-p obj)
-                             (output-type-code +negative-infinity-code+ stream)
-                             (return-from body)) ; success
-                            ((float-nan-p obj)
-                             (output-type-code +float-nan-code+ stream)
-                             (return-from body))
-                            (t
-                             ;; Unclear what _other_ sort of error we can
-                             ;; get by failing to decode a float, but,
-                             ;; anyway, let the caller handle them...
-                             nil)))))
-        (multiple-value-setq (significand exponent sign)
-          (integer-decode-float obj))
-        (output-type-code +float-code+ stream)
-        (write-byte (float-type obj) stream)
-        (store-object significand stream)
-        (store-object exponent stream)
-        (store-object sign stream)))))
-
- 
-(defrestore-cl-store (negative-infinity stream)
-  (declare (ignore stream))
-  +negative-infinity+)
-
-(defrestore-cl-store (positive-infinity stream)
-  (declare (ignore stream))
-  +positive-infinity+)
-
-(defrestore-cl-store (nan-float stream)
-   (declare (ignore stream))
-   +nan-float+)                     
+;; Setup special floats
+(defvar +positive-infinity+ (expt most-positive-double-float 2))
+(defvar +negative-infinity+ (expt most-negative-double-float 3))
+(defvar +nan-float+ (/ +negative-infinity+ +negative-infinity+))
+
+(setf *special-floats*
+  (list (cons +positive-infinity+ +positive-double-infinity-code+)
+        (cons +positive-infinity+ +positive-infinity-code+)
+        (cons +negative-infinity+ +negative-double-infinity-code+)
+        (cons +negative-infinity+ +negative-infinity-code+)
+        (cons +nan-float+ +float-double-nan-code+)
+        (cons +nan-float+ +float-nan-code+)))
 
 
 ;; Custom structure storing from Alain Picard.
@@ -83,31 +38,5 @@
             (resolving-object (obj new-instance)
               (setting (slot-value obj 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 (obj new-instance)
-              (setting (slot-value obj slot-name) (restore-object stream)))))
-    new-instance))
-
-
 
 ;; EOF



From sross at common-lisp.net  Fri Feb 11 12:00:49 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 11 Feb 2005 13:00:49 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <20050211120049.E585688696@common-lisp.net>

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

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

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.5 cl-store/sbcl/custom.lisp:1.6
--- cl-store/sbcl/custom.lisp:1.5	Thu Dec  2 11:32:04 2004
+++ cl-store/sbcl/custom.lisp	Fri Feb 11 13:00:47 2005
@@ -2,34 +2,33 @@
 ;; See the file LICENCE for licence information.
 
 (in-package :cl-store)
-;; TODO 
-;; real Functions and closures.
+
+; special floats
+(defvar +single-positive-infinity+ most-positive-single-float)
+(defvar +single-negative-infinity+ most-negative-single-float)
+(defvar +single-nan+)
+
+(defvar +double-positive-infinity+ most-positive-double-float)
+(defvar +double-negative-infinity+ most-negative-double-float)
+(defvar +double-nan+)
+
+(sb-int:with-float-traps-masked (:overflow :invalid)
+  (setf +single-positive-infinity+ (expt +single-positive-infinity+ 2))
+  (setf +single-negative-infinity+ (expt +single-negative-infinity+ 3))
+  (setf +single-nan+ (/ +single-negative-infinity+ +single-negative-infinity+))
+  (setf +double-positive-infinity+ (expt +double-positive-infinity+ 2))
+  (setf +double-negative-infinity+ (expt +double-negative-infinity+ 3))
+  (setf +double-nan+ (/ +double-negative-infinity+ +double-negative-infinity+)))
+
+(setf *special-floats*
+  (list (cons +double-positive-infinity+ +positive-double-infinity-code+)
+        (cons +single-positive-infinity+ +positive-infinity-code+)
+        (cons +single-negative-infinity+ +negative-infinity-code+)
+        (cons +double-negative-infinity+ +negative-double-infinity-code+)
+        (cons +single-nan+ +float-nan-code+)
+        (cons +double-nan+ +float-double-nan-code+)))
 
 
-;; Custom float storing
-(defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)
-  (write-byte (float-type obj) stream)
-  (etypecase obj
-    (single-float (store-object (sb-kernel:single-float-bits obj)
-                                stream))
-    (double-float (store-object (sb-kernel:double-float-high-bits obj)
-                                stream)
-                  (store-object (sb-kernel:double-float-low-bits obj)
-                                stream))))
-
-(defun sbcl-restore-single-float (stream)
-  (sb-kernel:make-single-float (the integer (restore-object stream))))
-
-(defun sbcl-restore-double-float (stream)
-  (sb-kernel:make-double-float (the integer (restore-object stream))
-                               (the integer (restore-object stream))))
-
-(defrestore-cl-store (float stream)
-  (let ((byte (read-byte stream)))
-    (ecase byte
-      (0 (sbcl-restore-single-float stream))
-      (1 (sbcl-restore-double-float stream)))))
 
 ;; Custom structure storing
 (defstore-cl-store (obj structure-object stream)



From sross at common-lisp.net  Fri Feb 11 12:00:38 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 11 Feb 2005 13:00:38 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	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: <20050211120038.375ED88696@common-lisp.net>

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

Modified Files:
	ChangeLog backends.lisp circularities.lisp cl-store.asd 
	default-backend.lisp package.lisp plumbing.lisp tests.lisp 
	utils.lisp 
Log Message:
Changelog 2005-02-11
Date: Fri Feb 11 13:00:31 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.19 cl-store/ChangeLog:1.20
--- cl-store/ChangeLog:1.19	Thu Feb  3 12:55:13 2005
+++ cl-store/ChangeLog	Fri Feb 11 13:00:30 2005
@@ -1,3 +1,29 @@
+2005-02-11 Sean Ross <sross at common-lisp.net>
+	New Magic Number for cl-store-backend.
+	* default-backend.lisp, acl/custom.lisp, lispworks/custom.lisp
+	* sbcl/custom.lisp, cmucl/custom.lisp:
+	Changed storing of floats to be compatible between implementations
+	while ensuring that NaN floats and friends are still serializable.
+	* backends.lisp, plumbing.lisp:
+	Added concept of backend designators which can be a 
+	symbol (the backend name) or the backend itself. These are 
+	acceptable replacements for a backend object
+	to store, restore and with-backend.
+	Completely changed argument order for generic functions
+	to ensure that backends are the first argument.
+	* ecl/mop.lisp: Added support for ecl.
+	* plumbing.lisp: Removed multiple-value-store (I don't really
+	see the point of it).
+	* backends.lisp: Changed the working of object restoration
+	from functions in a hash-table (restorer-funs of a backend)
+	to generic functions specialized on backend and a symbol,
+	removed find-function-for-type. 
+	* plumbing.lisp: Changed the handling of the stream-type
+	of backends to be any legal type designator since it's 
+	only used when opening files.
+	* backends.lisp: Both defstore-? and defrestore-?
+	can take an optional qualifer argument.
+	
 2005-02-03 Sean Ross <sross at common-lisp.net>
 	* default-backend.lisp: Fixed hash-table restoration,
 	it no longer assumes that the result of hash-table-test
@@ -10,7 +36,7 @@
 	argument-precedence-order from various gf's, added the 
 	start of support for ecl, renamed fix-clisp.lisp file to 
 	mop.lisp, and changed resolving-object and setting 
-	to use delays allowing get-setf-place and *postfix-setter*
+	to use delays allowing get-setf-place and *postfix-setters*
 	to be removed.
 	
 2004-12-02 Sean Ross <sross at common-lisp.net>
@@ -151,7 +177,7 @@
 
 2004-05-21 Sean Ross <sross at common-lisp.net>
 	* store.lisp, fix-clisp.lisp, circularities.lisp, package.lisp, 
-	tests.lisp, utils.lisp, cl-store.asd:
+	* tests.lisp, utils.lisp, cl-store.asd:
 	   Added ability to specify the type code of an object 
 	   when using defstore. Added code to autogenerate the 
 	   accessor methods for CLISP when restoring classes.


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.7 cl-store/backends.lisp:1.8
--- cl-store/backends.lisp:1.7	Tue Feb  1 09:27:26 2005
+++ cl-store/backends.lisp	Fri Feb 11 13:00:31 2005
@@ -7,8 +7,6 @@
 ;; in default-backend.lisp and xml-backend.lisp
 
 (in-package :cl-store)
-;(declaim (optimize (speed 3) (safety 1) (debug 0)))
-
 
 (defun required-arg (name)
   (error "~A is a required argument" name))
@@ -19,103 +17,93 @@
    (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers
                       :type integer)
    (stream-type :accessor stream-type :initarg :stream-type :type symbol
-                :initform (required-arg "stream-type"))
-   (restorer-funs :accessor restorer-funs :initform (make-hash-table)
-                  :initarg :restorer-funs :type hash-table))
+                :initform (required-arg "stream-type")))
   (:documentation "Core class which custom backends must extend"))
 
+(deftype backend-designator ()
+  `(or symbol backend))
+
 (defparameter *registered-backends* nil 
   "An assoc list mapping backend-names to the backend objects")
 
-(defun mkstr (&rest args)
-  (with-output-to-string (s)
-    (dolist (x args)
-      (princ x s))))
-
-(defun symbolicate (&rest syms)
-  "Concatenate all symbol names into one big symbol"
-  (values (intern (apply #'mkstr syms))))
+(defun find-backend (name)
+  (declare (type symbol name))
+  "Return backup called NAME or NIL if not found."
+  (cdr (assoc name *registered-backends*)))
+
+(defun backend-designator->backend (designator)
+  (check-type designator backend-designator)
+  (etypecase designator
+    (symbol (or (find-backend designator)
+                (error "~A does not designate a backend." designator)))
+    (backend designator)))
 
-(defun get-store-macro (name class-name)
+(defun get-store-macro (name)
   "Return the defstore-? macro which will be used by a custom backend"
   (let ((macro-name (symbolicate 'defstore- name)))
-    `(defmacro ,macro-name ((var type stream &key qualifier) 
+    `(defmacro ,macro-name ((var type stream &optional qualifier) 
                             &body body)
-      `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
-        ((,var ,type) ,stream (backend ,',class-name))
-        ,(format nil "Definition for storing an object of type ~A with ~
-backend ~A" type ',name)
-        , at body))))
+       (with-gensyms (gbackend)
+         `(defmethod internal-store-object ,@(if qualifier (list qualifier) nil)
+            ((,gbackend ,',name) (,var ,type) ,stream)
+            ,(format nil "Definition for storing an object of type ~A with ~
+ backend ~A" type ',name)
+            (declare (ignorable ,gbackend))
+            , at body)))))
 
 (defun get-restore-macro (name)
   "Return the defrestore-? macro which will be used by a custom backend"
   (let ((macro-name (symbolicate 'defrestore- name)))
-    `(defmacro ,macro-name ((type place) &body body)
-      (let ((fn-name (gensym (symbol-name (symbolicate ',name '- type)))))
-        `(flet ((,fn-name (,place) 
-                  , at body))
-          (let* ((backend (find-backend ',',name))
-                 (restorers (restorer-funs backend)))
-            (when (gethash ',type restorers)
-              (warn "Redefining restorer ~A for backend ~(~A~)"
-                    ',type (name backend)))
-            (setf (gethash ',type restorers)
-                  #',fn-name)))))))
-
-(defun real-stream-type (value)
-  (ecase value
-    (char 'character)
-    (binary 'integer)))
+    `(defmacro ,macro-name ((type place &optional qualifier) &body body)
+       (with-gensyms (gbackend gtype)
+         `(defmethod internal-restore-object ,@(if qualifier (list qualifier) nil)
+            ((,gbackend ,',name) (,gtype (eql ',type)) (,place t))
+            (declare (ignorable ,gbackend ,gtype))
+            , at body)))))
 
 (defun register-backend (name class magic-number stream-type old-magic-numbers)
   (declare (type symbol name))
-  (assert (member stream-type '(char binary)))
   (let ((instance (make-instance class
                                  :name name
                                  :magic-number magic-number
                                  :old-magic-numbers old-magic-numbers
-                                 :stream-type (real-stream-type stream-type))))
+                                 :stream-type  stream-type)))
     (if (assoc name *registered-backends*)
-        (cerror "Redefine backend" "Backend is already defined ~A" name)
+        (cerror "Redefine backend" "Backend ~A is already defined." name)
         (push (cons name instance) *registered-backends*))
     instance))
 
-(defun find-backend (name)
-  (declare (type symbol name))
-  "Return backup called NAME or NIL if not found."
-  (cdr (assoc name *registered-backends*)))
 
 (defun get-class-form (name fields extends)
-  `(defclass ,name (,extends)
+  `(defclass ,name ,extends
     ,fields
     (:documentation ,(format nil "Autogenerated cl-store class for backend ~(~A~)."
                              name))))
 
-(defmacro defbackend (name &key (stream-type (required-arg "stream-type"))
-                      (magic-number nil) fields (extends 'backend) 
-                      (old-magic-numbers nil))
+(defmacro defbackend (name &key (stream-type ''(unsigned-byte 8))
+                           (magic-number nil) fields (extends '(backend))
+                           (old-magic-numbers nil))
   "Defines a new backend called NAME. Stream type must be either 'char or 'binary. 
 FIELDS is a list of legal slots for defclass. MAGIC-NUMBER, when supplied, will
 be written down stream as verification and checked on restoration.
 EXTENDS is a class to extend, which must be backend or a class which extends
 backend"
   (assert (symbolp name))
-  (let ((class-name (symbolicate name '-backend)))
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (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)
-        ,(get-restore-macro name)))))
-
+  `(eval-when (:load-toplevel :execute)
+     (eval-when (:compile-toplevel :load-toplevel :execute)
+       ,(get-class-form name fields extends)
+       ,(get-store-macro name)
+       ,(get-restore-macro name))
+     (register-backend ',name ',name ,magic-number 
+                       ,stream-type ',old-magic-numbers)))
 
 (defmacro with-backend (backend &body body)
   "Run BODY with *default-backend* bound to BACKEND"
-  `(let ((*default-backend* (or (and (typep ,backend 'backend) 
-                                     ,backend)
-                                (error "~A is not a legal backend" 
-                                       ,backend))))
-    , at body))
+  (with-gensyms (gbackend)
+    `(let* ((,gbackend ,backend)
+            (*default-backend* (or (backend-designator->backend ,gbackend)
+                                   (error "~A is not a legal backend" 
+                                          ,gbackend))))
+       , at body)))
 
-;; EOF
\ No newline at end of file
+;; EOF


Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.14 cl-store/circularities.lisp:1.15
--- cl-store/circularities.lisp:1.14	Tue Feb  1 09:27:26 2005
+++ cl-store/circularities.lisp	Fri Feb 11 13:00:31 2005
@@ -19,8 +19,6 @@
 ;; programs according to the Hyperspec(notes in EQ).
 
 (in-package :cl-store)
-;(declaim (optimize (speed 3) (safety 1) (debug 1)))
-
 
 (defvar *check-for-circs* t)
 
@@ -42,14 +40,16 @@
   "Resolve the possible referring object retrieved by GET and 
   set it into PLACE. Only usable within a resolving-object form."
   (declare (ignore place get))
-  (error "setting can only be used inside a resolving-object form."))
+  #+ecl nil
+  #-ecl (error "setting can only be used inside a resolving-object form."))
 
 (defmacro setting-hash (getting-key getting-value)
   "Insert the value retrieved by GETTING-VALUE with the key 
   retrieved by GETTING-KEY, resolving possible circularities.
   Only usable within a resolving-object form."
   (declare (ignore getting-key getting-value))
-  (error "setting-hash can only be used inside a resolving-object form."))
+  #+ecl nil
+  #-ecl (error "setting-hash can only be used inside a resolving-object form."))
 
 (defmacro resolving-object ((var create) &body body)
   "Execute body attempting to resolve circularities found in 
@@ -76,8 +76,7 @@
          , at body
          ,var))))
 
-(defstruct referrer 
-  val)
+(defstruct referrer val)
 
 (defun referred-value (referrer hash)
   "Return the value REFERRER is meant to be by looking in HASH."
@@ -100,7 +99,7 @@
   (let ((*stored-counter* 0) 
         (*stored-values* (make-hash-table :test #'eq :size *store-hash-size*))) 
     (store-backend-code backend place)
-    (backend-store-object obj place backend)
+    (backend-store-object backend obj place)
     obj))
 
 (defun seen (obj)
@@ -122,9 +121,9 @@
   "Do we need to check if this object has been stored before?"
   (not (typep obj 'not-circ)))
 
-(defgeneric store-referrer (obj place backend)
+(defgeneric store-referrer (backend obj place)
   (:documentation "Store the number OBJ into PLACE as a referrer for BACKEND.")
-  (:method ((obj t) (place t) (backend resolving-backend))
+  (:method ((backend resolving-backend) (obj t) (place t))
     (store-error  "store-referrer must be specialized for backend ~(~A~)."
                   (name backend))))
 
@@ -136,12 +135,12 @@
            (update-seen obj))
       nil))
 
-(defmethod backend-store-object ((obj t) (place t) (backend resolving-backend))
+(defmethod backend-store-object ((backend resolving-backend) (obj t) (place t))
   "Store object if we have not seen this object before, otherwise retrieve
   the referrer object for it and store that using store-referrer."
   (aif (and *check-for-circs* (get-ref obj))
-       (store-referrer it place backend)
-       (internal-store-object obj place backend)))
+       (store-referrer backend it place)
+       (internal-store-object backend obj place)))
        
 ;; Restoration.
 (declaim (type (or fixnum null) *restore-counter*))
@@ -158,53 +157,36 @@
         (*restored-values* (make-hash-table :test #'eq :size *restore-hash-size*)))
     (check-magic-number backend place)
     (multiple-value-prog1
-      (backend-restore-object place backend)
+      (backend-restore-object backend place)
       (dolist (fn *need-to-fix*)
         (force fn)))))
 
 (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)
+(defun handle-normal (backend 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))))
+        (vals (new-val (internal-restore-object backend reader place))))
     (update-restored spot vals)
     vals))
 
+(defgeneric referrerp (backend reader))
+
 (defun handle-restore (place backend)
-  (multiple-value-bind (reader sym) (find-function-for-type place backend)
-    (declare (type function reader) (type symbol sym))
-    (cond ((eql sym 'values-object)
-           (handle-values reader place))
-          ((eql sym 'referrer)
+  (multiple-value-bind (reader) (get-next-reader backend place)
+    (declare (type symbol reader))
+    (cond ((referrerp backend reader) 
            (incf *restore-counter*)
-           (new-val (call-it reader place)))
-          ((not (int-sym-or-char-p backend sym))
-           (handle-normal reader place))
-          (t (new-val (funcall reader place))))))
+           (new-val (internal-restore-object backend reader place)))
+          ((not (int-sym-or-char-p backend reader))
+           (handle-normal backend reader place))
+          (t (new-val (internal-restore-object backend reader place))))))
 
-(defmethod backend-restore-object ((place stream) (backend resolving-backend))
+(defmethod backend-restore-object ((backend resolving-backend) (place stream))
   "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)))
+      (call-next-method)))
 
 (defgeneric int-sym-or-char-p (backend fn)
   (:method ((backend backend) (fn symbol))
@@ -220,5 +202,4 @@
            val)
       val))
 
-
-;; EOF
\ No newline at end of file
+;; EOF


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.18 cl-store/cl-store.asd:1.19
--- cl-store/cl-store.asd:1.18	Thu Feb  3 12:59:12 2005
+++ cl-store/cl-store.asd	Fri Feb 11 13:00:31 2005
@@ -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.6"
+  :version "0.4.13"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"
@@ -65,9 +65,7 @@
   :components ((:file "tests")))
 
 (defmethod perform ((op test-op) (sys (eql (find-system :cl-store-tests))))
-  (or (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
-               (symbol-value (find-symbol "*CL-STORE-BACKEND*" "CL-STORE")))
-      (error "Test-op Failed.")))
-
+  (funcall (find-symbol "RUN-TESTS" "CL-STORE-TESTS")
+           (find-symbol "CL-STORE" "CL-STORE")))
 
 ;; EOF


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.17 cl-store/default-backend.lisp:1.18
--- cl-store/default-backend.lisp:1.17	Thu Feb  3 12:55:13 2005
+++ cl-store/default-backend.lisp	Fri Feb 11 13:00:31 2005
@@ -2,66 +2,68 @@
 ;; See the file LICENCE for licence information.
 
 ;; The cl-store backend. 
-
 (in-package :cl-store)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defvar *cl-store-backend*
-    (defbackend cl-store :magic-number 1886611820 
-                :stream-type 'binary
-                :old-magic-numbers (1912923 1886611788 1347635532 
-                                    1884506444 1347643724 1349732684)
-                :extends resolving-backend
-                :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)
-         (setf (gethash code (restorers *cl-store-backend*))
-               name))
-    code))
+(defbackend cl-store :magic-number 1349740876
+            :stream-type '(unsigned-byte 8)
+            :old-magic-numbers (1912923 1886611788 1347635532 1886611820 
+                                        1884506444 1347643724 1349732684)
+            :extends (resolving-backend)
+            :fields ((restorers :accessor restorers 
+                                :initform (make-hash-table :size 100))))
+
+(defun register-code (code name &optional (errorp t))
+  (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp)
+       (error "Code ~A is already defined for ~A." code name)
+       (setf (gethash code (restorers (find-backend 'cl-store)))
+             name))
+  code)
 
 ;;  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))
-(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))
+(defvar +referrer-code+ (register-code 1 'referrer nil))
+;(defvar +values-code+ (register-code 2 'values-object nil))
+(defvar +unicode-string-code+ (register-code 3 'unicode-string nil))
+(defvar +integer-code+ (register-code 4 'integer nil))
+(defvar +simple-string-code+ (register-code 5 'simple-string nil))
+(defvar +float-code+ (register-code 6 'float nil))
+(defvar +ratio-code+ (register-code 7 'ratio nil))
+(defvar +character-code+ (register-code 8 'character nil))
+(defvar +complex-code+ (register-code 9 'complex nil))
+(defvar +symbol-code+ (register-code 10 'symbol nil))
+(defvar +cons-code+ (register-code 11 'cons nil))
+(defvar +pathname-code+ (register-code 12 'pathname nil))
+(defvar +hash-table-code+ (register-code 13 'hash-table nil))
+(defvar +standard-object-code+ (register-code 14 'standard-object nil))
+(defvar +condition-code+ (register-code 15 'condition nil))
+(defvar +structure-object-code+ (register-code 16 'structure-object nil))
+(defvar +standard-class-code+ (register-code 17 'standard-class nil))
+(defvar +built-in-class-code+ (register-code 18 'built-in-class nil))
+(defvar +array-code+ (register-code 19 'array nil))
+(defvar +simple-vector-code+ (register-code 20 'simple-vector nil))
+(defvar +package-code+ (register-code 21 'package nil))
 
 ;; Used by lispworks
-(defconstant +positive-infinity-code+ (register-code 22 'positive-infinity nil))
-(defconstant +negative-infinity-code+ (register-code 23 'negative-infinity nil))
+(defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil))
+(defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil))
 
 ;; new storing for 32 bit ints
-(defconstant +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
+(defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
 
 ;; More for lispworks
-(defconstant +float-nan-code+ (register-code 25 'nan-float nil))
+(defvar +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))
+(defvar +function-code+ (register-code 26 'function nil))
+(defvar +gf-code+ (register-code 27 'generic-function nil))
 
 ;; Used by SBCL and CMUCL.
-(defconstant +structure-class-code+ (register-code 28 'structure-class nil))
-(defconstant +struct-def-code+ (register-code 29 'struct-def nil))
+(defvar +structure-class-code+ (register-code 28 'structure-class nil))
+(defvar +struct-def-code+ (register-code 29 'struct-def nil))
+
+(defvar +gensym-code+ (register-code 30 'gensym nil))
 
-(defconstant +gensym-code+ (register-code 30 'gensym nil))
+(defvar +positive-double-infinity-code+ (register-code 31 'positive-double-infinity nil))
+(defvar +negative-double-infinity-code+ (register-code 32 'negative-double-infinity nil))
+(defvar +float-double-nan-code+ (register-code 33 'float-double-nan nil))
 
 ;; setups for type code mapping
 (defun output-type-code (code stream)
@@ -71,24 +73,25 @@
 (defun read-type-code (stream)
   (read-byte stream))
 
-(defvar *restorers* (restorers *cl-store-backend*))
+(defmethod referrerp ((backend cl-store) (reader t))
+  (eql reader 'referrer))
+
+(defvar *restorers* (restorers (find-backend 'cl-store)))
+
 ;; 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))
-  (declare (ignore backend))
+(defmethod get-next-reader ((backend cl-store) (stream stream))
   (let ((type-code (read-type-code stream)))
-    (or (lookup-code type-code) ;(gethash type-code *restorers*)
-        (values nil (format nil "Type ~A" type-code)))))
+    (or (lookup-code type-code)
+        (error "Type code ~A is not registered." type-code))))
 
 
 ;; referrer, Required for a resolving backend
-(defmethod store-referrer (ref stream (backend cl-store-backend))
-  (declare (ignore backend))
+(defmethod store-referrer ((backend cl-store) (ref t) (stream t))
   (output-type-code +referrer-code+ stream)
   (dump-int ref stream))
 
@@ -101,8 +104,7 @@
 ;; so we we have a little optimization for it
 
 ;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((backend cl-store-backend) (fn symbol))
-  (declare (ignore backend))
+(defmethod int-sym-or-char-p ((backend cl-store) (fn symbol))
   (find fn '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
@@ -162,29 +164,63 @@
         (- result)
         result)))
 
-;; Floats
-;; SBCL and CMUCL use a different mechanism for dealing
-;; with floats which supports infinities.
-;; Lispworks uses a slightly different version as well
-;; manually handling negative and positive infinity
-;; Allegro uses excl:double-float-to-shorts and friends
-#-(or lispworks cmu sbcl allegro)
+;; Floats (*special-floats* are setup in the custom.lisp files)
+(defvar *special-floats* nil)
+
 (defstore-cl-store (obj float stream)
-  (output-type-code +float-code+ stream)    
-  (multiple-value-bind (significand exponent sign)
-      (integer-decode-float obj)
-    (write-byte (float-type obj) stream)
-    (store-object significand stream)
-    (store-object exponent stream)
-    (store-object sign stream)))
+  (block body
+    (let (significand exponent sign)
+      (handler-bind ((simple-error
+                      #'(lambda (err)
+                          (declare (ignore err))
+                          (awhen (cdr (assoc obj *special-floats*))
+                            (output-type-code it stream)
+                            (return-from body)))))
+        (multiple-value-setq (significand exponent sign)
+          (integer-decode-float obj))
+        (output-type-code +float-code+ stream)
+        (write-byte (float-type obj) stream)
+        (store-object significand stream)
+        (store-object (float-radix obj) stream)
+        (store-object exponent stream)
+        (store-object sign stream)))))
 
-#-(or cmu sbcl allegro)
 (defrestore-cl-store (float stream)
   (float (* (get-float-type (read-byte stream))
             (* (restore-object stream)
-               (expt 2 (restore-object stream)))
+               (expt (restore-object stream)
+                     (restore-object stream)))
             (restore-object stream))))
 
+(defun handle-special-float (code name)
+  (aif (rassoc code *special-floats*)
+       (car it)
+       (store-error "~A Cannot be represented." name)))
+
+(defrestore-cl-store (negative-infinity stream)
+  (handle-special-float +negative-infinity-code+
+                        "Single Float Negative Infinity"))
+
+(defrestore-cl-store (positive-infinity stream)
+  (handle-special-float +positive-infinity-code+
+                        "Single Float Positive Infinity"))
+
+(defrestore-cl-store (nan-float stream)
+   (handle-special-float +float-nan-code+ "Single Float NaN"))
+
+(defrestore-cl-store (negative-double-infinity stream)
+  (handle-special-float +negative-double-infinity-code+
+                        "Double Float Negative Infinity"))
+
+(defrestore-cl-store (positive-double-infinity stream)
+  (handle-special-float +positive-double-infinity-code+
+                        "Double Float Positive Infinity"))
+
+(defrestore-cl-store (float-double-nan stream)
+  (handle-special-float +float-double-nan-code+
+                        "Double Float NaN"))
+
+
 ;; ratio
 (defstore-cl-store (obj ratio stream)
   (output-type-code +ratio-code+ stream)
@@ -231,7 +267,7 @@
 (defrestore-cl-store (gensym stream)
   (make-symbol (restore-object stream)))
 
-  
+
 ;; lists
 (defstore-cl-store (obj cons stream)
   (output-type-code +cons-code+ stream)    
@@ -245,6 +281,7 @@
     (setting (car x) (restore-object stream))
     (setting (cdr x) (restore-object stream))))
 
+
 ;; pathnames
 (defstore-cl-store (obj pathname stream)
   (output-type-code +pathname-code+ stream)
@@ -297,7 +334,6 @@
                             (restore-object stream))))
       hash)))
 
-
 ;; Object and Conditions
 (defun store-type-object (obj stream)
   (let* ((all-slots (remove-if-not (lambda (x)
@@ -321,7 +357,6 @@
   (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))
@@ -339,11 +374,10 @@
               (setting (slot-value obj slot-name) (restore-object stream)))))
     new-instance))
 
-#-lispworks
-(defrestore-cl-store (condition stream)
+(defrestore-cl-store (standard-object stream)
   (restore-type-object stream))
 
-(defrestore-cl-store (standard-object stream)
+(defrestore-cl-store (condition stream)
   (restore-type-object stream))
 
 
@@ -377,12 +411,14 @@
              #+clisp (add-methods-for-class class slots)))))
 
 ;; built in classes
+
 (defstore-cl-store (obj built-in-class stream)
   (output-type-code +built-in-class-code+ stream)
   (store-object (class-name obj) stream))
 
+#-ecl ;; for some reason this doesn't work with ecl
 (defmethod internal-store-object ((obj (eql (find-class 'hash-table))) stream
-                                  (backend cl-store-backend))
+                                  (backend cl-store))
   (output-type-code +built-in-class-code+ stream)
   (store-object 'cl:hash-table stream))
 
@@ -505,17 +541,6 @@
   (find-package (restore-object stream)))
 
 
-;; multiple values
-
-(defstore-cl-store (obj values-object stream)
-  (output-type-code +values-code+ stream)
-  (store-object (vals obj) stream))
-
-(defrestore-cl-store (values-object stream)
-  (apply #'values (restore-object stream)))
-
-
-
 ;; Function storing hack.
 ;; This just stores the function name if we can find it
 ;; or signal a store-error.
@@ -570,6 +595,7 @@
 
 (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.16 cl-store/package.lisp:1.17
--- cl-store/package.lisp:1.16	Tue Feb  1 09:27:26 2005
+++ cl-store/package.lisp	Fri Feb 11 13:00:31 2005
@@ -1,33 +1,28 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;; See the file LICENCE for licence information.
-
+(in-package :cl-store.system)
 (defpackage #:cl-store
   (:use #:cl) 
-  (:export #:backend #:magic-number #:stream-type #:restorer-funs
+  (:export #:backend #:magic-number #:stream-type
            #:restorers #:resolving-backend #:find-backend #:defbackend
            #:*restore-counter* #:*need-to-fix* #:*restored-values*
            #:with-backend #:fix-circularities #:*default-backend*
-           #:*cl-store-backend* #:*current-backend* #:*store-class-slots*
+           #:*current-backend* #:*store-class-slots*
            #:*nuke-existing-classes* #:*store-class-superclasses*
            #:cl-store-error #:store-error #:restore-error #:store
            #:restore #:backend-store #:store-backend-code #:store-object
            #:backend-store-object #:get-class-details #:get-array-values
-           #:restore #:backend-restore
+           #:restore #:backend-restore #:cl-store #:referrerp
            #:check-magic-number #:get-next-reader #:int-sym-or-char-p
            #: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
-           #:float-type #:get-float-type #:compute-slots
-           #:slot-definition-allocation #:slot-definition-name
-           #:slot-definition-type #:slot-definition-initargs
-           #:slot-definition-readers #:slot-definition-writers
-           #:class-direct-superclasses #:class-direct-slots
-           #:ensure-class #:make-referrer #:setting-hash
+           #:float-type #:get-float-type #:make-referrer #:setting-hash
            #:multiple-value-store #:*postfix-setters* #:caused-by
            #:store-32-bit #:read-32-bit #:*check-for-circs*
            #:*store-hash-size* #:*restore-hash-size*)
-
+  
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name
                        #:slot-definition-name


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.9 cl-store/plumbing.lisp:1.10
--- cl-store/plumbing.lisp:1.9	Tue Feb  1 09:27:26 2005
+++ cl-store/plumbing.lisp	Fri Feb 11 13:00:31 2005
@@ -53,25 +53,21 @@
   (error 'restore-error :format-string format-string :format-args args))
 
 
-
-
 ;; 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)
-                         (integer '(unsigned-byte 8)))))
+  (let* ((element-type (stream-type backend)))
     (with-open-file (s place :element-type element-type
                        :direction :output :if-exists :supersede)
       (backend-store backend s obj))))
 
-(defgeneric store (obj place &optional backend) 
+(defgeneric store (obj place &optional designator) 
   (:documentation "Entry Point for storing objects.")
-  (:method ((obj t) (place t) &optional (backend *default-backend*))
+  (:method ((obj t) (place t) &optional (designator *default-backend*))
     "Store OBJ into Stream PLACE using backend BACKEND."
-    (let ((*current-backend* backend)
-          (*read-eval* nil))
+    (let* ((backend (backend-designator->backend designator))
+           (*current-backend* backend)
+           (*read-eval* nil))
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'store-error 
                                                       :caused-by c)))))
@@ -104,20 +100,20 @@
 (defun store-object (obj stream &optional (backend *current-backend*))
   "Store OBJ into STREAM. Not meant to be overridden, 
    use backend-store-object instead"
-  (backend-store-object obj stream backend))
+  (backend-store-object backend obj stream))
 
-(defgeneric backend-store-object (obj stream backend)
+(defgeneric backend-store-object (backend obj stream)
   (:documentation
    "Wrapped by store-object, override this to do custom storing 
    (see circularities.lisp for an example).")
-  (:method ((obj t) (stream t) (backend backend))
+  (:method ((backend backend) (obj t) (stream t))
     "The default, just calls internal-store-object."
-    (internal-store-object obj stream backend)))
+    (internal-store-object backend obj stream)))
 
 
-(defgeneric internal-store-object (obj place backend)
+(defgeneric internal-store-object (backend obj place)
   (:documentation "Method which is specialized by defstore-? macros.")
-  (:method ((obj t) (place t) (backend backend))
+  (:method ((backend backend) (obj t) (place t))
     "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))))
@@ -127,10 +123,11 @@
   (:documentation 
    "Restore and object FROM PLACE using BACKEND. Not meant to be 
    overridden, use backend-restore instead")
-  (:method (place &optional (backend *default-backend*))
+  (:method (place &optional (designator *default-backend*))
     "Entry point for restoring objects (setfable)."
-    (let ((*current-backend* backend)
-          (*read-eval* nil))
+    (let* ((backend (backend-designator->backend designator))
+           (*current-backend* backend)
+           (*read-eval* nil))
       (handler-bind ((error (lambda (c)
                               (signal (make-condition 'restore-error
                                                       :caused-by c)))))
@@ -143,7 +140,7 @@
     "Restore the object found in stream PLACE using backend BACKEND.
      Checks the magic-number and invokes backend-restore-object"
     (check-magic-number backend place)
-    (backend-restore-object place backend))
+    (backend-restore-object backend place))
   (:method ((backend backend) (place string))
     "Restore the object found in file designator PLACE using backend BACKEND."
     (restore-from-file place backend))
@@ -152,10 +149,7 @@
     (restore-from-file place backend)))
 
 (defun restore-from-file (place backend)
-  (let* ((backend-type (stream-type backend))
-         (element-type (ecase backend-type
-                         (character 'character)
-                         (integer '(unsigned-byte 8)))))
+  (let* ((element-type (stream-type backend)))
     (with-open-file (s place :element-type element-type :direction :input)
       (backend-restore backend s))))
      
@@ -164,18 +158,10 @@
   (:documentation "Backends supporting multiple return values
 should define a custom storer and restorer for this class"));
 
-(defmacro multiple-value-store (values-form place 
-                                &optional (backend '*default-backend*))
-  "Store all values returned from VALUES-FORM into PLACE"
-  `(let ((vals (multiple-value-list ,values-form)))
-    (store (make-instance 'values-object :vals vals)
-     ,place ,backend)
-    (apply #'values vals)))
-
 (defun (setf restore) (new-val place)
   (store new-val place))
 
-(defgeneric check-magic-number (stream backend)
+(defgeneric check-magic-number (backend stream)
   (:method ((backend backend) (stream t))
     (let ((magic-number (magic-number backend)))
       (declare (type (or null ub32) magic-number))
@@ -195,47 +181,33 @@
 (defun lookup-reader (val readers)
   (gethash val readers))
 
-(defgeneric get-next-reader (place backend)
+(defgeneric get-next-reader (backend place)
   (:documentation 
    "Method which must be specialized for BACKEND to return 
    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 backend))
+  (:method ((backend backend) (place t))
+   (declare (ignore place))
     "The default, throw an error."
     (restore-error "get-next-reader must be specialized for backend ~(~A~)."
                    (name 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))
-              ((not val) 
-               (restore-error "~A is not registered with backend ~(~A~)."
-                              (or info "Unknown Type") (name backend)))
-              ((not reader)
-               (restore-error "No restorer defined for ~A in backend ~(~A~)."
-                              val (name backend)))))))
-
 ;; Wrapper for backend-restore-object so we don't have to pass
 ;; a backend object around all the time
 (declaim (inline restore-object))
 (defun restore-object (place &optional (backend *current-backend*))
   "Restore the object in PLACE using BACKEND"
-  (backend-restore-object place backend))
-
+  (backend-restore-object backend place))
 
-(defgeneric backend-restore-object (place backend)
+(defgeneric backend-restore-object (backend place)
   (:documentation
    "Find the next function to call with BACKEND and invoke it with PLACE.")
-  (:method ((place t) (backend backend))
+  (:method ((backend backend) (place t))
     "The default"
-    (funcall (the function (find-function-for-type place backend)) place)))
+    (internal-restore-object backend (get-next-reader backend place) place)))
+
+(defgeneric internal-restore-object (backend type place))
 
 
 ;; EOF


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.13 cl-store/tests.lisp:1.14
--- cl-store/tests.lisp:1.13	Tue Feb  1 09:27:26 2005
+++ cl-store/tests.lisp	Fri Feb 11 13:00:31 2005
@@ -172,15 +172,20 @@
 
 
 ;; hash tables
+; for some reason (make-hash-table) is not equalp 
+; to (make-hash-table) with ecl.
+
+#-ecl
 (deftestit hash.1 (make-hash-table))
 
-(deftestit hash.2
-  (let ((val #.(let ((in (make-hash-table :test #'equal 
+#-ecl
+(defvar *hash* (let ((in (make-hash-table :test #'equal 
                                           :rehash-threshold 0.4 :size 20
                                           :rehash-size 40)))
                  (dotimes (x 1000) (setf (gethash (format nil "~R" x) in) x))
-                 in)))
-    val))
+                 in))
+#-ecl
+(deftestit hash.2 *hash*)
 
 
 ;; packages
@@ -211,7 +216,7 @@
 (deftest standard-object.2
   (let ((val (store (make-instance 'bar
                                    :x (list 1 "foo" 1.0)
-                                   :y (make-hash-table :test #'equal))
+                                   :y #(1 2 3 4))
                     *test-file*)))
     (let ((ret (restore *test-file*)))
       (and (equalp (get-x val) (get-x ret))
@@ -467,22 +472,10 @@
   t)
 
 
-(deftest values.1 
-  (progn (multiple-value-store (values 1 2 3) *test-file*)
-         (multiple-value-list (restore *test-file*)))
-  (1 2 3))
-
-(deftest values.2 
-  (let ((string "foo"))
-    (multiple-value-store (values string string) *test-file*)
-    (let ((val (multiple-value-list (restore *test-file*))))
-      (eq (car val) (cadr val))))
-  t)
-
 
 (deftestit function.1 #'restores)
 (deftestit function.2 #'car)
-#-(or clisp lispworks allegro openmcl)
+#-(or clisp lispworks allegro openmcl ecl)
 (deftestit function.3 #'(setf car))
 
 (deftestit gfunction.1 #'cl-store:restore)


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.10 cl-store/utils.lisp:1.11
--- cl-store/utils.lisp:1.10	Thu Feb  3 12:55:13 2005
+++ cl-store/utils.lisp	Fri Feb 11 13:00:31 2005
@@ -94,5 +94,13 @@
 (defun kwd (name)
   (values (intern (string-upcase name) :keyword)))
 
+(defun mkstr (&rest args)
+  (with-output-to-string (s)
+    (dolist (x args)
+      (princ x s))))
+
+(defun symbolicate (&rest syms)
+  "Concatenate all symbol names into one big symbol"
+  (values (intern (apply #'mkstr syms))))
 
 ;; EOF



From sross at common-lisp.net  Mon Feb 14 09:02:35 2005
From: sross at common-lisp.net (Sean Ross)
Date: Mon, 14 Feb 2005 10:02:35 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd
	cl-store/default-backend.lisp 
Message-ID: <20050214090235.8DCAA884E3@common-lisp.net>

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

Modified Files:
	ChangeLog cl-store.asd default-backend.lisp 
Log Message:
Changelog 2005-02-14
Date: Mon Feb 14 10:02:34 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.20 cl-store/ChangeLog:1.21
--- cl-store/ChangeLog:1.20	Fri Feb 11 13:00:30 2005
+++ cl-store/ChangeLog	Mon Feb 14 10:02:33 2005
@@ -1,3 +1,8 @@
+2005-02-14 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp: Applied patch from Thomas Stenhaug
+	to default null superclasses of a restored class to 
+	standard-object as this caused errors in Lispworks.
+	
 2005-02-11 Sean Ross <sross at common-lisp.net>
 	New Magic Number for cl-store-backend.
 	* default-backend.lisp, acl/custom.lisp, lispworks/custom.lisp


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.19 cl-store/cl-store.asd:1.20
--- cl-store/cl-store.asd:1.19	Fri Feb 11 13:00:31 2005
+++ cl-store/cl-store.asd	Mon Feb 14 10:02:34 2005
@@ -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.13"
+  :version "0.4.14"
   :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.18 cl-store/default-backend.lisp:1.19
--- cl-store/default-backend.lisp:1.18	Fri Feb 11 13:00:31 2005
+++ cl-store/default-backend.lisp	Mon Feb 14 10:02:34 2005
@@ -401,10 +401,12 @@
          (meta (restore-object stream))
          (keywords '(:direct-slots :direct-superclasses
                      :metaclass))
-         (final (mappend #'list keywords (list slots supers meta))))
+         (final (mappend #'list keywords (list slots 
+                                               (or supers (list 'standard-object))
+                                               meta))))
     (cond ((find-class class nil)
            (cond (*nuke-existing-classes*
-                  (apply #'ensure-class  class final)
+                  (apply #'ensure-class class final)
                   #+clisp (add-methods-for-class class slots))
                  (t (find-class class))))
           (t (apply #'ensure-class class final)



From sross at common-lisp.net  Wed Feb 16 12:40:27 2005
From: sross at common-lisp.net (Sean Ross)
Date: Wed, 16 Feb 2005 13:40:27 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/package.lisp
	cl-store/plumbing.lisp cl-store/tests.lisp 
Message-ID: <20050216124027.3A7CA884E2@common-lisp.net>

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

Modified Files:
	ChangeLog cl-store.asd default-backend.lisp package.lisp 
	plumbing.lisp tests.lisp 
Log Message:
Changelog 2005-02-16
Date: Wed Feb 16 13:40:24 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.21 cl-store/ChangeLog:1.22
--- cl-store/ChangeLog:1.21	Mon Feb 14 10:02:33 2005
+++ cl-store/ChangeLog	Wed Feb 16 13:40:24 2005
@@ -1,3 +1,8 @@
+2005-02-16 Sean Ross <sross at common-lisp.net>
+	* default-backend.lisp, package.lisp, plumbing.lisp: Patch
+	from Thomas Stenhaug which adds more comprehensive package
+	storing.
+	
 2005-02-14 Sean Ross <sross at common-lisp.net>
 	* default-backend.lisp: Applied patch from Thomas Stenhaug
 	to default null superclasses of a restored class to 


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.20 cl-store/cl-store.asd:1.21
--- cl-store/cl-store.asd:1.20	Mon Feb 14 10:02:34 2005
+++ cl-store/cl-store.asd	Wed Feb 16 13:40:24 2005
@@ -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.14"
+  :version "0.4.15"
   :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.19 cl-store/default-backend.lisp:1.20
--- cl-store/default-backend.lisp:1.19	Mon Feb 14 10:02:34 2005
+++ cl-store/default-backend.lisp	Wed Feb 16 13:40:24 2005
@@ -21,7 +21,6 @@
 
 ;;  Type code constants
 (defvar +referrer-code+ (register-code 1 'referrer nil))
-;(defvar +values-code+ (register-code 2 'values-object nil))
 (defvar +unicode-string-code+ (register-code 3 'unicode-string nil))
 (defvar +integer-code+ (register-code 4 'integer nil))
 (defvar +simple-string-code+ (register-code 5 'simple-string nil))
@@ -42,14 +41,12 @@
 (defvar +simple-vector-code+ (register-code 20 'simple-vector nil))
 (defvar +package-code+ (register-code 21 'package nil))
 
-;; Used by lispworks
 (defvar +positive-infinity-code+ (register-code 22 'positive-infinity nil))
 (defvar +negative-infinity-code+ (register-code 23 'negative-infinity nil))
 
 ;; new storing for 32 bit ints
 (defvar +32-bit-integer-code+ (register-code 24 '32-bit-integer nil))
 
-;; More for lispworks
 (defvar +float-nan-code+ (register-code 25 'nan-float nil))
 
 (defvar +function-code+ (register-code 26 'function nil))
@@ -187,10 +184,10 @@
 
 (defrestore-cl-store (float stream)
   (float (* (get-float-type (read-byte stream))
-            (* (restore-object stream)
-               (expt (restore-object stream)
-                     (restore-object stream)))
-            (restore-object stream))))
+            (* (the integer (restore-object stream))
+               (expt (the integer (restore-object stream))
+                     (the integer (restore-object stream))))
+            (the integer (restore-object stream)))))
 
 (defun handle-special-float (code name)
   (aif (rassoc code *special-floats*)
@@ -534,15 +531,55 @@
       (setf (schar res x) (code-char (funcall reader stream))))
     res))
 
-;; packages
+;; packages (from Thomas Stenhaug)
 (defstore-cl-store (obj package stream)
-  (output-type-code +package-code+ stream)
-  (store-object (package-name obj) stream))
+  (output-type-code +package-code+ stream)  
+  (store-object (package-name obj) stream)
+  (store-object (package-nicknames obj) stream)
+  (store-object (mapcar (if *store-used-packages* #'identity #'package-name)
+                        (package-use-list obj))
+                stream)
+  (store-object (package-shadowing-symbols obj) stream)
+  (store-object (internal-symbols obj) stream)
+  (store-object (external-symbols obj) stream))
 
 (defrestore-cl-store (package stream)
-  (find-package (restore-object stream)))
-
-
+  (let* ((package-name (restore-object stream))
+         (existing-package (find-package package-name)))
+    (cond ((or (not existing-package)
+               (and existing-package *nuke-existing-packages*))
+           (restore-package package-name stream :force *nuke-existing-packages*))
+          (t (dotimes (x 5)  ; remove remaining objects from the stream
+               (restore-object stream)) 
+             existing-package))))
+
+(defun internal-symbols (package)
+  (let ((acc (make-array 100 :adjustable t :fill-pointer 0))
+        (used (package-use-list package)))
+    (do-symbols (symbol package)
+      (unless (find (symbol-package symbol) used)
+        (vector-push-extend symbol acc)))
+    acc))
+
+(defun external-symbols (package)
+  (let ((acc (make-array 100 :adjustable t :fill-pointer 0)))
+    (do-external-symbols (symbol package)
+      (vector-push-extend symbol acc))
+    acc))
+
+(defun restore-package (package-name stream &key force)
+  (when force
+    (delete-package package-name))
+  (let ((package (make-package package-name
+			       :nicknames (restore-object stream)
+			       :use (restore-object stream))))
+    (shadow (restore-object stream) package)
+    (loop for symbol across (restore-object stream) do
+      (import symbol package))
+    (loop for symbol across (restore-object stream) do
+      (export symbol package))
+    package))
+ 
 ;; Function storing hack.
 ;; This just stores the function name if we can find it
 ;; or signal a store-error.


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.17 cl-store/package.lisp:1.18
--- cl-store/package.lisp:1.17	Fri Feb 11 13:00:31 2005
+++ cl-store/package.lisp	Wed Feb 16 13:40:24 2005
@@ -21,7 +21,8 @@
            #:float-type #:get-float-type #:make-referrer #:setting-hash
            #:multiple-value-store #:*postfix-setters* #:caused-by
            #:store-32-bit #:read-32-bit #:*check-for-circs*
-           #:*store-hash-size* #:*restore-hash-size*)
+           #:*store-hash-size* #:*restore-hash-size*
+           #:*store-used-packages* #:*nuke-existing-packages*)
   
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.10 cl-store/plumbing.lisp:1.11
--- cl-store/plumbing.lisp:1.10	Fri Feb 11 13:00:31 2005
+++ cl-store/plumbing.lisp	Wed Feb 16 13:40:24 2005
@@ -6,6 +6,11 @@
 
 (in-package :cl-store)
 
+(defvar *store-used-packages* nil
+  "If non-nil will serialize each used package otherwise will
+only store the package name")
+(defvar *nuke-existing-packages* nil
+  "Whether or not to overwrite existing packages on restoration.")
 (defvar *nuke-existing-classes* nil
   "Do we overwrite existing class definitions on restoration.")
 (defvar *store-class-superclasses* nil


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.14 cl-store/tests.lisp:1.15
--- cl-store/tests.lisp:1.14	Fri Feb 11 13:00:31 2005
+++ cl-store/tests.lisp	Wed Feb 16 13:40:24 2005
@@ -191,7 +191,29 @@
 ;; packages
 (deftestit package.1 (find-package :cl-store))
 
+(defpackage foo 
+  (:nicknames foobar)
+  (:use :cl)
+  (:shadow cl:format)
+  (:export bar))
 
+(defun package-restores ()
+  (store (find-package :foo) *test-file*)
+  (delete-package :foo)
+  (restore *test-file*)
+  (list (package-name (find-package :foo))
+        (mapcar #'package-name (package-use-list :foo))
+        (package-nicknames :foo)
+        (equalp (remove-duplicates (package-shadowing-symbols :foo))
+                (list (find-symbol "FORMAT" "FOO")))
+        (equalp (cl-store::external-symbols (find-package :foo))
+                (make-array 1 :initial-element (find-symbol "BAR" "FOO")))))
+
+; unfortunately it's difficult to portably test the internal symbols
+; in a package so we just have to assume that it's OK.
+(deftest package.2 
+         (package-restores)
+         ("FOO" ("COMMON-LISP") ("FOOBAR") t t))
 
 ;; objects 
 (defclass foo ()



From sross at common-lisp.net  Thu Feb 17 08:23:54 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu, 17 Feb 2005 09:23:54 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/package.lisp
	cl-store/utils.lisp 
Message-ID: <20050217082354.472BB884E1@common-lisp.net>

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

Modified Files:
	ChangeLog cl-store.asd default-backend.lisp package.lisp 
	utils.lisp 
Log Message:
Changelog 2005-02-17
Date: Thu Feb 17 09:23:49 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.22 cl-store/ChangeLog:1.23
--- cl-store/ChangeLog:1.22	Wed Feb 16 13:40:24 2005
+++ cl-store/ChangeLog	Thu Feb 17 09:23:48 2005
@@ -1,3 +1,11 @@
+2005-02-17 Sean Ross <sross at common-lisp.net>
+	* package.lisp, utils.lisp, default-backend.lisp: Patch 
+	from Thomas Stenhaug which changed get-slot-details to 
+	a generic-function so that it can be customized.
+	Added serializable-slots (returns a list of slot-definitions)
+	which can be overridden to customize which slots are
+	serialized when storing clos instances.
+	
 2005-02-16 Sean Ross <sross at common-lisp.net>
 	* default-backend.lisp, package.lisp, plumbing.lisp: Patch
 	from Thomas Stenhaug which adds more comprehensive package


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.21 cl-store/cl-store.asd:1.22
--- cl-store/cl-store.asd:1.21	Wed Feb 16 13:40:24 2005
+++ cl-store/cl-store.asd	Thu Feb 17 09:23:48 2005
@@ -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.15"
+  :version "0.4.17"
   :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.20 cl-store/default-backend.lisp:1.21
--- cl-store/default-backend.lisp:1.20	Wed Feb 16 13:40:24 2005
+++ cl-store/default-backend.lisp	Thu Feb 17 09:23:48 2005
@@ -101,8 +101,8 @@
 ;; so we we have a little optimization for it
 
 ;; We need this for circularity stuff.
-(defmethod int-sym-or-char-p ((backend cl-store) (fn symbol))
-  (find fn '(integer character 32-bit-integer symbol)))
+(defmethod int-sym-or-char-p ((backend cl-store) (type symbol))
+  (find type '(integer character 32-bit-integer symbol)))
 
 (defstore-cl-store (obj integer stream)
   (if (typep obj 'sb32)
@@ -335,7 +335,7 @@
 (defun store-type-object (obj stream)
   (let* ((all-slots (remove-if-not (lambda (x)
                                      (slot-boundp obj (slot-definition-name x)))
-                                   (compute-slots (class-of obj))))
+                                   (serializable-slots obj)))
          (slots (if *store-class-slots*
                     all-slots
                     (remove-if #'(lambda (x) (eql (slot-definition-allocation x)


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.18 cl-store/package.lisp:1.19
--- cl-store/package.lisp:1.18	Wed Feb 16 13:40:24 2005
+++ cl-store/package.lisp	Thu Feb 17 09:23:48 2005
@@ -14,20 +14,21 @@
            #:backend-store-object #:get-class-details #:get-array-values
            #:restore #:backend-restore #:cl-store #:referrerp
            #:check-magic-number #:get-next-reader #:int-sym-or-char-p
-           #:restore-object #:backend-restore-object
+           #:restore-object #:backend-restore-object #:serializable-slots
            #:defstore-cl-store #:defrestore-cl-store #:register-code
            #:output-type-code #:store-referrer #:resolving-object
            #:internal-store-object #:setting #:simple-standard-string
            #:float-type #:get-float-type #:make-referrer #:setting-hash
            #:multiple-value-store #:*postfix-setters* #:caused-by
            #:store-32-bit #:read-32-bit #:*check-for-circs*
-           #:*store-hash-size* #:*restore-hash-size*
+           #:*store-hash-size* #:*restore-hash-size* #:get-slot-details
            #:*store-used-packages* #:*nuke-existing-packages*)
   
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name
                        #:slot-definition-name
                        #:slot-definition-allocation
+                       #:slot-definition
                        #:compute-slots
                        #:slot-definition-initform
                        #:slot-definition-initargs
@@ -55,6 +56,7 @@
                        #:slot-definition-name
                        #:slot-definition-allocation
                        #:compute-slots
+                       #:slot-definition
                        #:slot-definition-initform
                        #:slot-definition-initargs
                        #:slot-definition-name
@@ -78,6 +80,7 @@
                           #:slot-definition-name
                           #:slot-definition-allocation
                           #:compute-slots
+                          #:slot-definition
                           #:slot-definition-initform
                           #:slot-definition-initargs
                           #:slot-definition-name
@@ -105,6 +108,7 @@
                              #:generic-function-name
                              #:slot-definition-allocation
                              #:compute-slots
+                             #:slot-definition
                              #:slot-definition-initform
                              #:slot-definition-initargs
                              #:slot-definition-name
@@ -121,6 +125,7 @@
                           #:slot-definition-name
                           #:generic-function-name
                           #:slot-definition-allocation
+                          #:slot-definition
                           #:compute-slots
                           #:slot-definition-initform
                           #:slot-definition-initargs


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.11 cl-store/utils.lisp:1.12
--- cl-store/utils.lisp:1.11	Fri Feb 11 13:00:31 2005
+++ cl-store/utils.lisp	Thu Feb 17 09:23:48 2005
@@ -15,18 +15,33 @@
 (defun mappend (fn &rest lsts)
   (apply #'append (apply #'mapcar fn lsts)))
 
+(defgeneric serializable-slots (object)
+  (:documentation 
+   "Return a list of slot-definitions to serialize. The default
+    is to call compute-slots on the objects class")
+  (:method ((object standard-object))
+   (compute-slots (class-of object)))
+#+(or sbcl cmu)
+  (:method ((object structure-object))
+   (compute-slots (class-of object)))
+  (:method ((object condition))
+   (compute-slots (class-of object))))
 
-(defun get-slot-details (slot-definition)
-  "Return a list of slot details which can be
-   used as an argument to ensure-class"
-  (list :name (slot-definition-name slot-definition)
-        :allocation (slot-definition-allocation slot-definition)
-        :initargs (slot-definition-initargs slot-definition)
-        ;; :initform. dont use initform until we can
-        ;; serialize functions
-        :readers (slot-definition-readers slot-definition)
-        :type (slot-definition-type slot-definition)
-        :writers (slot-definition-writers slot-definition)))
+; Generify get-slot-details for customization (from Thomas Stenhaug)
+(defgeneric get-slot-details (slot-definition)
+  (:documentation 
+   "Return a list of slot details which can be used 
+    as an argument to ensure-class")
+  (:method ((slot-definition #+(or ecl clisp) t 
+                             #-(or ecl clisp) slot-definition))
+   (list :name (slot-definition-name slot-definition)
+         :allocation (slot-definition-allocation slot-definition)
+         :initargs (slot-definition-initargs slot-definition)
+         ;; :initform. dont use initform until we can
+         ;; serialize functions
+         :readers (slot-definition-readers slot-definition)
+         :type (slot-definition-type slot-definition)
+         :writers (slot-definition-writers slot-definition))))
 
 (defmacro awhen (test &body body)
   `(aif ,test



From sross at common-lisp.net  Thu Feb 17 08:23:56 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu, 17 Feb 2005 09:23:56 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <20050217082356.B521F884E1@common-lisp.net>

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

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-02-17
Date: Thu Feb 17 09:23:54 2005
Author: sross

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.6 cl-store/sbcl/custom.lisp:1.7
--- cl-store/sbcl/custom.lisp:1.6	Fri Feb 11 13:00:47 2005
+++ cl-store/sbcl/custom.lisp	Thu Feb 17 09:23:54 2005
@@ -31,6 +31,7 @@
 
 
 ;; Custom structure storing
+
 (defstore-cl-store (obj structure-object stream)
   (output-type-code +structure-object-code+ stream)
   (store-type-object obj stream))



From sross at common-lisp.net  Fri Feb 18 08:15:51 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 09:15:51 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	cl-store/default-backend.lisp cl-store/package.lisp
	cl-store/utils.lisp 
Message-ID: <20050218081551.DE765884E2@common-lisp.net>

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

Modified Files:
	ChangeLog default-backend.lisp package.lisp utils.lisp 
Log Message:
Changelog 2005-02-18
Date: Fri Feb 18 09:15:50 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.23 cl-store/ChangeLog:1.24
--- cl-store/ChangeLog:1.23	Thu Feb 17 09:23:48 2005
+++ cl-store/ChangeLog	Fri Feb 18 09:15:49 2005
@@ -1,3 +1,8 @@
+2005-02-18 Sean Ross <sross at common-lisp.net>
+	* utils.lisp, package.lisp: Took a lesson from the MOP
+	and changed serializable-slots to call the new GF 
+	serializable-slots-using-class.
+	
 2005-02-17 Sean Ross <sross at common-lisp.net>
 	* package.lisp, utils.lisp, default-backend.lisp: Patch 
 	from Thomas Stenhaug which changed get-slot-details to 


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.21 cl-store/default-backend.lisp:1.22
--- cl-store/default-backend.lisp:1.21	Thu Feb 17 09:23:48 2005
+++ cl-store/default-backend.lisp	Fri Feb 18 09:15:49 2005
@@ -531,6 +531,7 @@
       (setf (schar res x) (code-char (funcall reader stream))))
     res))
 
+
 ;; packages (from Thomas Stenhaug)
 (defstore-cl-store (obj package stream)
   (output-type-code +package-code+ stream)  
@@ -543,14 +544,17 @@
   (store-object (internal-symbols obj) stream)
   (store-object (external-symbols obj) stream))
 
+(defun remove-remaining (times stream)
+  (dotimes (x times)
+    (restore-object stream)))
+
 (defrestore-cl-store (package stream)
   (let* ((package-name (restore-object stream))
          (existing-package (find-package package-name)))
     (cond ((or (not existing-package)
                (and existing-package *nuke-existing-packages*))
            (restore-package package-name stream :force *nuke-existing-packages*))
-          (t (dotimes (x 5)  ; remove remaining objects from the stream
-               (restore-object stream)) 
+          (t (remove-remaining 5 stream)
              existing-package))))
 
 (defun internal-symbols (package)
@@ -579,7 +583,7 @@
     (loop for symbol across (restore-object stream) do
       (export symbol package))
     package))
- 
+
 ;; Function storing hack.
 ;; This just stores the function name if we can find it
 ;; or signal a store-error.


Index: cl-store/package.lisp
diff -u cl-store/package.lisp:1.19 cl-store/package.lisp:1.20
--- cl-store/package.lisp:1.19	Thu Feb 17 09:23:48 2005
+++ cl-store/package.lisp	Fri Feb 18 09:15:49 2005
@@ -22,7 +22,8 @@
            #:multiple-value-store #:*postfix-setters* #:caused-by
            #:store-32-bit #:read-32-bit #:*check-for-circs*
            #:*store-hash-size* #:*restore-hash-size* #:get-slot-details
-           #:*store-used-packages* #:*nuke-existing-packages*)
+           #:*store-used-packages* #:*nuke-existing-packages*
+           #:serializable-slots-using-class)
   
   #+sbcl (:import-from #:sb-mop
                        #:generic-function-name


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.12 cl-store/utils.lisp:1.13
--- cl-store/utils.lisp:1.12	Thu Feb 17 09:23:48 2005
+++ cl-store/utils.lisp	Fri Feb 18 09:15:49 2005
@@ -18,14 +18,33 @@
 (defgeneric serializable-slots (object)
   (:documentation 
    "Return a list of slot-definitions to serialize. The default
-    is to call compute-slots on the objects class")
+    is to call serializable-slots-using-class with the object 
+    and the objects class")
   (:method ((object standard-object))
-   (compute-slots (class-of object)))
+   (serializable-slots-using-class object (class-of object)))
 #+(or sbcl cmu)
   (:method ((object structure-object))
-   (compute-slots (class-of object)))
+   (serializable-slots-using-class object (class-of object)))
   (:method ((object condition))
-   (compute-slots (class-of object))))
+   (serializable-slots-using-class object (class-of object))))
+
+; unfortunately the metaclass of conditions in sbcl and cmu 
+; are not standard-class
+(defgeneric serializable-slots-using-class (object class)
+  (:documentation "Return a list of slot-definitions to serialize.
+   The default calls compute slots with class")
+  (:method ((object t) (class standard-class))
+   (compute-slots class))
+#+(or sbcl cmu) 
+  (:method ((object t) (class structure-class))
+   (compute-slots class))
+#+sbcl
+  (:method ((object t) (class sb-pcl::condition-class))
+   (compute-slots class))
+#+cmu
+  (:method ((object t) (class pcl::condition-class))
+   (compute-slots class)))
+
 
 ; Generify get-slot-details for customization (from Thomas Stenhaug)
 (defgeneric get-slot-details (slot-definition)



From sross at common-lisp.net  Fri Feb 18 08:20:11 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 09:20:11 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/cl-store.asd 
Message-ID: <20050218082011.D4834884E2@common-lisp.net>

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

Modified Files:
	cl-store.asd 
Log Message:
Changelog 2005-02-18
Date: Fri Feb 18 09:20:10 2005
Author: sross

Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.22 cl-store/cl-store.asd:1.23
--- cl-store/cl-store.asd:1.22	Thu Feb 17 09:23:48 2005
+++ cl-store/cl-store.asd	Fri Feb 18 09:20:10 2005
@@ -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.17"
+  :version "0.4.18"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"



From sross at common-lisp.net  Fri Feb 18 08:20:13 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 09:20:13 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ecl/.cvsignore 
Message-ID: <20050218082013.3ADC788669@common-lisp.net>

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

Added Files:
	.cvsignore 
Log Message:
Changelog 2005-02-18
Date: Fri Feb 18 09:20:11 2005
Author: sross




From sross at common-lisp.net  Fri Feb 18 08:50:10 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 09:50:10 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <20050218085010.A5CC1884E2@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Updated Manual
Date: Fri Feb 18 09:50:09 2005
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.6 cl-store/doc/cl-store.texi:1.7
--- cl-store/doc/cl-store.texi:1.6	Tue Feb  1 09:27:40 2005
+++ cl-store/doc/cl-store.texi	Fri Feb 18 09:50:09 2005
@@ -79,9 +79,10 @@
 the same purpose as Java's ObjectOutput and ObjectInputStream, although
 it's somewhat more extensible.
 
-The CL-STORE Home Page is at @uref{http://www.common-lisp.net/project/cl-store}
-where one can find details about mailing lists, cvs repositories (I hope i spelled that
-right) and various releases.
+The CL-STORE Home Page is at @uref{http://common-lisp.net/project/cl-store}
+where one can find details about mailing lists, cvs repositories and various releases.
+
+This documentation is for CL-STORE version 0.5 .
 
 Enjoy
  Sean.
@@ -120,6 +121,7 @@
 @item Lispworks
 @item Allegro CL
 @item OpenMCL
+ at item ECL
 @end itemize
 
 
@@ -146,7 +148,7 @@
 
 @item DOWNLOAD
 
-The latest cl-store release will always be available from @uref{http://www.common-lisp.net,,cl.net}.
+The latest cl-store release will always be available from @uref{http://common-lisp.net,,cl.net}.
 Download and untar in an appropriate directory then symlink @file{cl-store.asd}
 to a directory on @code{asdf:*central-registry*} 
 (see the documentation for asdf for details about setting up asdf).
@@ -154,8 +156,8 @@
 @item CVS
 
 If you feel the need to be on the bleeding edge you can use
-anonymous CVS access, see the @uref{http://www.common-lisp.net/project/cl-store,,Home Page}
- for more details for accessing the archive. Once downloaded follow the symlink instructions above.
+anonymous CVS access, see the @uref{http://common-lisp.net/project/cl-store,,Home Page}
+for more details for accessing the archive. Once downloaded follow the symlink instructions above.
 
 @end itemize
 
@@ -201,6 +203,21 @@
 @end deftp
 
 
+ at anchor {Variable *nuke-existing-packages*}
+ at vindex *nuke-existing-packages*
+ at deftp {Variable} *nuke-existing-packages* @emph{Default NIL}
+If @code{*nuke-existing-packages*} is non-nil then packages which
+already exist will be deleted when restoring packages.
+ at end deftp
+
+ at anchor {Variable *store-used-packages*}
+ at vindex *store-used-packages*
+ at deftp {Variable} *store-used-packages* @emph{Default NIL}
+The variable determines the how packages on a package use
+list will be serialized. If non-nil the the package will
+be fully serialized, otherwise only the name will be stored.
+ at end deftp
+
 @anchor {Variable *store-hash-size*}
 @vindex *store-hash-size*
 @deftp {Variable} *store-hash-size* @emph{Default 1000}
@@ -232,21 +249,13 @@
 your data (eg spam-filter hash-tables). 
 @end deftp
 
-
 @anchor {Variable *default-backend*}
 @vindex *default-backend*
- at deftp {Variable} *default-backend* @emph{Default *cl-store-backend*}
+ at deftp {Variable} *default-backend*
 The backend that will be used by default.
 @end deftp
 
 
- at anchor {Variable *cl-store-backend*}
- at vindex *cl-store-backend*
- at deftp {Variable} *cl-store-backend* 
-The CL-STORE Backend.
- at end deftp
-
-
 @section Functions
 @anchor {Generic store}
 @deffn {Generic} store object place &optional (backend *default-backend*)
@@ -282,22 +291,10 @@
 
 
 @section Macros
- at anchor {Macro multiple-value-store}
- at deffn {Macro} multiple-value-store form place &optional (backend *default-backend*)
-Stores all values returned by @emph{form} into @emph{place} using @emph{backend}.
-As usual @emph{place} must be @code{stream} or a @code{pathname-designator}.
-Restoring values stored using @code{multiple-value-store} will return all values.
-eg.
- at lisp
-(multiple-value-store (values 1 2 3) "/tmp/values.out")
-(restore "/tmp/values.out")
-=> 1, 2, 3
- at end lisp
- at end deffn
-
 @anchor {Macro with-backend}
 @deffn {Macro} with-backend backend &body body
-Execute @emph{body} with @code{*default-backend*} bound to @emph{backend}.
+Execute @emph{body} with @code{*default-backend*} bound to the 
+backend designated by @emph{backend}.
 @end deffn
 
 
@@ -345,7 +342,7 @@
 
 (use-package :cl-store)
 
-(setf *default-backend* *cl-store-backend*)
+(setf *default-backend* (find-backend 'cl-store))
 
 ;; Create the custom class
 (defclass random-obj () ((a :accessor a :initarg :a)))
@@ -381,11 +378,11 @@
 
 @subsection Functions
 @anchor {Function register-code}
- at deffn {Function} register-code name &optional (errorp t)
+ at deffn {Function} register-code code name &optional (errorp t)
 Registers @emph{name} under the code @emph{code} into the cl-store-backend. 
 The backend will use this mapping when restoring values. 
 Will signal an error if code is already registered and @emph{errorp} is not NIL.
-Currently codes 1 through 25 are in use.
+Currently codes 1 through 33 are in use.
 @end deffn
 
 @anchor {Function output-type-code}
@@ -406,7 +403,7 @@
 @end deffn
 
 @anchor {Generic store-object} 
- at deffn {Generic} store-object object place 
+ at deffn {Generic} store-object object place
 Stores @emph{object} into @emph{place}. This should be used inside 
 @code{defstore-cl-store} to output parts of objects. @code{store} 
 should not be used.
@@ -427,19 +424,13 @@
 is stored using @code{store-object} with @emph{var} bound to the object to
 be stored and @emph{stream} bound to the stream to output to. If @emph{qualifier}
 is given it must be a legal qualifier to @code{defmethod}. 
-Example Expansion.
+Example.
 @lisp
 (defstore-cl-store (obj ratio stream)
    (output-type-code +ratio-code+ stream)
    (store-object (numerator obj) stream)
    (store-object (denominator obj) stream))
 
-==
-
-(defmethod internal-store-object ((obj ratio) stream (backend cl-store-backend))
-  (output-type-code +ratio-code+ stream)
-  (store-object (numerator obj) stream)
-  (store-object (denominator obj) stream))
 @end lisp
 @end deffn
 
@@ -449,21 +440,11 @@
 registered using @code{register-code}. at emph{Body} will be executed with 
 @emph{stream} being the input stream to restore an object from. 
 
-Example Expansion.
+Example.
 @lisp
 (defrestore-cl-store (ratio stream)
   (/ (restore-object stream)
      (restore-object stream)))
-
-== 
-
-(flet ((#:cl-store-ratio4109 (stream) 
-         (/ (restore-object stream) (restore-object stream))))
-   (let* ((backend (find-backend 'cl-store)) 
-          (restorers (restorer-funs backend))) 
-     (when (gethash 'ratio restorers) 
-        (warn "redefining restorer ~a for backend ~(~a~)" 'ratio (name backend)))
-     (setf (gethash 'ratio restorers) #'#:cl-store-ratio4109)))
 @end lisp
 @end deffn 
 
@@ -530,11 +511,6 @@
 @end lisp
 @end deffn
 
- at subsection Variables
- at anchor {Variable *postfix-setters*}
- at deftp {Variable} *postfix-setters* @emph{Default (gethash)}
-Setfable places which take the object to set after all other arguments.
- at end deftp
 
 @node New Backends
 @chapter New Backends
@@ -557,7 +533,7 @@
 eg. (from the cl-store-backend)
 @lisp 
 (defbackend cl-store :magic-number 1347643724
-                :stream-type 'binary 
+                :stream-type '(unsigned-byte 8)
                 :old-magic-numbers (1912923 1886611788 1347635532)
                 :extends resolving-backend
                 :fields ((restorers :accessor restorers :initform (make-hash-table))))
@@ -575,6 +551,7 @@
 
 eg. (from the cl-store-backend)
 @lisp
+(defvar *cl-store-backend* (find-backend 'cl-store))
 ;; This is a util method to register the code with a symbol
 (defun register-code (code name &optional (errorp t))
   (aif (and (gethash code (restorers *cl-store-backend*)) errorp)
@@ -586,7 +563,7 @@
 (defconstant +ratio-code+ (register-code 7 'ratio))
 
 ;; Extending the get-next-reader method
-(defmethod get-next-reader ((stream stream) (backend cl-store-backend))
+(defmethod get-next-reader ((backend cl-store) (stream stream))
   (let ((type-code (read-type-code stream)))
     (or (gethash type-code (restorers backend))
         (values nil (format nil "Type ~A" type-code)))))
@@ -609,10 +586,10 @@
 done you can use @code{resolving-object} and @code{setting} to resolve
 circularities in objects.
 
-eg (from the cl-store-backend)
+eg (from the cl-store backend)
 @lisp
 (defconstant +referrer-code+ (register-code 1 'referrer nil))
-(defmethod store-referrer (ref stream (backend cl-store-backend))
+(defmethod store-referrer (ref stream (backend cl-store))
   (output-type-code +referrer-code+ stream)
   (store-32-bit ref stream))
 
@@ -629,7 +606,7 @@
 (in-package :cl-user)
 (use-package :cl-store)
 
-(defbackend pickle :stream-type 'char)
+(defbackend pickle :stream-type 'character)
 @end lisp
 @vskip 0pt plus 2filll
 
@@ -641,7 +618,7 @@
 (defvar *pickle-mapping*
   '((#\S . string)))
 
-(defmethod get-next-reader ((stream stream) (backend pickle-backend))
+(defmethod get-next-reader ((backend pickle) (stream stream))
   (let ((type-code (read-char stream)))
     (or (cdr (assoc type-code *pickle-mapping*))
         (values nil (format nil "Type ~A" type-code)))))
@@ -666,12 +643,12 @@
 >>> pickle.dump('Foobar', open('/tmp/foo.p', 'w'))
 
 Lisp
-* (cl-store:restore "/tmp/foo.p" (find-backend 'pickle))
+* (cl-store:restore "/tmp/foo.p" 'pickle)
 => "Foobar"
 And 
 
 Lisp 
-* (cl-store:store "BarFoo" "/tmp/foo.p" (find-backend 'pickle))
+* (cl-store:store "BarFoo" "/tmp/foo.p" 'pickle)
 
 Python
 >>> pickle.load(open('/tmp/foo.p'))
@@ -684,33 +661,33 @@
 
 @subsection Functions
 @anchor {Generic backend-restore}
- at deffn {Generic} backend-restore place backend
+ at deffn {Generic} backend-restore backend place
 Restore the object found in stream @emph{place} using backend @emph{backend}.
 Checks the magic-number and invokes @code{backend-restore-object}. Called by @code{restore}, override
 for custom restoring.
 @end deffn
 
 @anchor {Generic backend-restore-object}
- at deffn {Generic} backend-restore place backend
+ at deffn {Generic} backend-restore backend place
 Find the next function to call to restore the next object with  @emph{backend} and invoke it with @emph{place}.
 Called by @code{restore-object}, override this method to do custom restoring (see @file{circularities.lisp}
 for an example).
 @end deffn
 
 @anchor {Generic backend-store}
- at deffn {Generic} backend-store obj place backend
+ at deffn {Generic} backend-store backend place obj
 Stores the backend code and calls @code{store-object}. This is called by @code{store}. Override for 
 custom storing.
 @end deffn
 
 @anchor {Generic backend-store-object}
- at deffn {Generic} backend-store-object obj place backend
+ at deffn {Generic} backend-store-object backend obj place
 Called by @code{store-object}, override this to do custom storing 
 (see @file{circularities.lisp} for an example). 
 @end deffn
 
 @anchor {Generic get-next-reader}
- at deffn {Generic} get-next-reader place backend
+ at deffn {Generic} get-next-reader backend place
 Method which must be specialized for @emph{backend} to return the next symbol
 designating a @code{defrestore} instance to restore an object from @emph{place}.
 If no reader is found return a second value which will be included in the error.
@@ -720,9 +697,9 @@
 @subsection Macros
 @anchor {Macro defbackend}
 @deffn {Macro} defbackend name &key (stream-type (required-arg "stream-type")) magic-number fields (extends 'backend) old-magic-numbers 
-eg. @lisp (defbackend pickle :stream-type 'char) @end lisp
+eg. @lisp (defbackend pickle :stream-type 'character) @end lisp
 This creates a new backend called @emph{name}, @emph{stream-type} describes the type of stream that the
-backend will serialize to, currently one of 'binary or 'char. @emph{Magic-number}, when present, must be of type
+backend will serialize to which must be suitable as an argument to open. @emph{Magic-number}, when present, must be of type
 (unsigned-byte 32) which will be written as a verifier for the backend. @emph{Fields} are extra fields to be 
 added to the new class which will be created. By default the @emph{extends} keyword is @emph{backend},the root backend, but
 this can be any legal backend. @emph{Old-magic-numbers} holds previous magic-numbers that have been used by the backend
@@ -732,11 +709,18 @@
 @node Notes
 @chapter Notes
 
+ at section Backend Designators
+The @emph{backend} argument to store, restore and with-backend 
+is a backend designator which can be one of.
+ at itemize @bullet
+ at item A backend returned by @code{(find-backend name)}
+ at item A symbol designating a backend (the first argument to defbackend).
+ at end itemize
+
 @section Known Issues
 @itemize @bullet
 @item  CLISP, OpenMCL, Allegro CL cannot store structure instances.
 @item  Structure definitions are only supported in SBCL and CMUCL.
- at 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
 
@@ -747,6 +731,7 @@
 @item Common-Lisp.net: For project hosting.
 @item Alain Picard : Structure Storing and support for Infinite Floats for Lispworks.
 @item Robert Sedgewick: Package Imports for OpenMCL and suggesting Multiple Backends.
+ at item Thomas Stenhaug: Comprehensive package storing and miscellaneous improvements.
 @end itemize
 
 @node Index



From sross at common-lisp.net  Fri Feb 18 11:11:03 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 12:11:03 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/circularities.lisp
	cl-store/cl-store.asd cl-store/default-backend.lisp
	cl-store/plumbing.lisp cl-store/tests.lisp cl-store/utils.lisp 
Message-ID: <20050218111103.57D1F884E1@common-lisp.net>

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

Modified Files:
	circularities.lisp cl-store.asd default-backend.lisp 
	plumbing.lisp tests.lisp utils.lisp 
Log Message:
Changelog 2005-02-18
Date: Fri Feb 18 12:11:00 2005
Author: sross

Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.15 cl-store/circularities.lisp:1.16
--- cl-store/circularities.lisp:1.15	Fri Feb 11 13:00:31 2005
+++ cl-store/circularities.lisp	Fri Feb 18 12:10:59 2005
@@ -19,6 +19,7 @@
 ;; programs according to the Hyperspec(notes in EQ).
 
 (in-package :cl-store)
+(declaim (optimize speed (debug 0) (safety 1)))
 
 (defvar *check-for-circs* t)
 
@@ -30,7 +31,7 @@
 
 (defun force (delay)
   (unless (delay-completed delay)
-    (setf (delay-value delay) (funcall (delay-value delay))
+    (setf (delay-value delay) (funcall (the function (delay-value delay)))
           (delay-completed delay) t))
   (delay-value delay))
 


Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.23 cl-store/cl-store.asd:1.24
--- cl-store/cl-store.asd:1.23	Fri Feb 18 09:20:10 2005
+++ cl-store/cl-store.asd	Fri Feb 18 12:11:00 2005
@@ -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.18"
+  :version "0.5"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data types"
   :licence "MIT"


Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.22 cl-store/default-backend.lisp:1.23
--- cl-store/default-backend.lisp:1.22	Fri Feb 18 09:15:49 2005
+++ cl-store/default-backend.lisp	Fri Feb 18 12:11:00 2005
@@ -4,6 +4,8 @@
 ;; The cl-store backend. 
 (in-package :cl-store)
 
+(declaim (optimize speed (debug 0) (safety 1)))
+
 (defbackend cl-store :magic-number 1349740876
             :stream-type '(unsigned-byte 8)
             :old-magic-numbers (1912923 1886611788 1347635532 1886611820 
@@ -183,7 +185,7 @@
         (store-object sign stream)))))
 
 (defrestore-cl-store (float stream)
-  (float (* (get-float-type (read-byte stream))
+  (float (* (the float (get-float-type (read-byte stream)))
             (* (the integer (restore-object stream))
                (expt (the integer (restore-object stream))
                      (the integer (restore-object stream))))
@@ -545,6 +547,7 @@
   (store-object (external-symbols obj) stream))
 
 (defun remove-remaining (times stream)
+  (declare (type fixnum times))
   (dotimes (x times)
     (restore-object stream)))
 


Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.11 cl-store/plumbing.lisp:1.12
--- cl-store/plumbing.lisp:1.11	Wed Feb 16 13:40:24 2005
+++ cl-store/plumbing.lisp	Fri Feb 18 12:11:00 2005
@@ -6,6 +6,8 @@
 
 (in-package :cl-store)
 
+(declaim (optimize speed (debug 0) (safety 1)))
+
 (defvar *store-used-packages* nil
   "If non-nil will serialize each used package otherwise will
 only store the package name")


Index: cl-store/tests.lisp
diff -u cl-store/tests.lisp:1.15 cl-store/tests.lisp:1.16
--- cl-store/tests.lisp:1.15	Wed Feb 16 13:40:24 2005
+++ cl-store/tests.lisp	Fri Feb 18 12:11:00 2005
@@ -502,8 +502,7 @@
 
 (deftestit gfunction.1 #'cl-store:restore)
 (deftestit gfunction.2 #'cl-store:store)
-#-(or clisp openmcl)
-(deftestit gfunction.3 #'(setf cl-store:restore))
+
 
 (deftest nocirc.1 
     (let* ((string "FOO")


Index: cl-store/utils.lisp
diff -u cl-store/utils.lisp:1.13 cl-store/utils.lisp:1.14
--- cl-store/utils.lisp:1.13	Fri Feb 18 09:15:49 2005
+++ cl-store/utils.lisp	Fri Feb 18 12:11:00 2005
@@ -92,7 +92,8 @@
 
 (defun store-32-bit (obj stream)
   "Write OBJ down STREAM as a 32 bit integer."
-  (declare (optimize speed))
+  (declare (optimize speed (debug 0) (safety 1))
+           (type sb32 obj))
   (let ((obj (logand #XFFFFFFFF obj)))
     (write-byte (ldb (byte 8 0) obj) stream)
     (write-byte (ldb (byte 8 8) obj) stream)
@@ -104,7 +105,7 @@
 
 (defun read-32-bit (buf &optional (signed t))
   "Read a signed or unsigned byte off STREAM."
-  (declare (optimize speed))
+  (declare (optimize speed (debug 0) (safety 1)))
   (let ((byte1 (read-byte buf))
         (byte2 (read-byte buf))
         (byte3 (read-byte buf))



From sross at common-lisp.net  Fri Feb 18 11:11:06 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 12:11:06 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/doc/cl-store.texi 
Message-ID: <20050218111106.93F4D88669@common-lisp.net>

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

Modified Files:
	cl-store.texi 
Log Message:
Changelog 2005-02-18
Date: Fri Feb 18 12:11:03 2005
Author: sross

Index: cl-store/doc/cl-store.texi
diff -u cl-store/doc/cl-store.texi:1.7 cl-store/doc/cl-store.texi:1.8
--- cl-store/doc/cl-store.texi:1.7	Fri Feb 18 09:50:09 2005
+++ cl-store/doc/cl-store.texi	Fri Feb 18 12:11:03 2005
@@ -407,12 +407,44 @@
 Stores @emph{object} into @emph{place}. This should be used inside 
 @code{defstore-cl-store} to output parts of objects. @code{store} 
 should not be used.
-
 @end deffn
+
 @anchor {Generic restore-object}
 @deffn {Generic} restore-object place 
 Restore an object, written out using @code{store-object} from @emph{place}. 
 @end deffn
+
+ at anchor {Generic get-slot-details}
+ at deffn {Generic} get-slot-details slot-definition
+Generic function which returns a list of slots details
+which can be used as an argument to @code{ensure-class}. 
+Currently it is only specialized on slot-definition
+ at end deffn
+
+ at anchor {Generic serializable-slots}
+ at deffn {Generic} serializable-slots object
+Method which returns a list of slot-definition objects
+which will be serialized for @emph{object}. The default 
+is to call @code{serializable-slots-using-class}.
+ at end deffn
+
+ at anchor {Generic serializable-slots-using-class}
+ at deffn {Generic} serializable-slots-using-class object class
+Returns a list of slot-definition objects which will 
+be serialized for object and class. 
+Example.
+When serializing cl-sql objects to disk or to another 
+lisp session the view-database slot should not be serialized.
+Instead of specializing serializable-slots for each view-class
+created you can do this.
+ at lisp
+(defmethod serializable-slots-using-class 
+     ((object t) (class clsql-sys::standard-db-class))
+  (delete 'clsql-sys::view-database (call-next-method)
+          :key 'slot-definition-name))
+ at end lisp
+ at end deffn
+
 
 @vskip 0pt plus 1filll
 



From sross at common-lisp.net  Fri Feb 18 13:51:16 2005
From: sross at common-lisp.net (Sean Ross)
Date: Fri, 18 Feb 2005 14:51:16 +0100 (CET)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog 
Message-ID: <20050218135116.35BD9884FA@common-lisp.net>

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

Modified Files:
	ChangeLog 
Log Message:

Date: Fri Feb 18 14:51:15 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.24 cl-store/ChangeLog:1.25
--- cl-store/ChangeLog:1.24	Fri Feb 18 09:15:49 2005
+++ cl-store/ChangeLog	Fri Feb 18 14:51:14 2005
@@ -1,4 +1,5 @@
 2005-02-18 Sean Ross <sross at common-lisp.net>
+   Version 0.5 Release.
 	* utils.lisp, package.lisp: Took a lesson from the MOP
 	and changed serializable-slots to call the new GF 
 	serializable-slots-using-class.