[cl-store-cvs] CVS update: cl-store/ChangeLog cl-store/default-backend.lisp cl-store/package.lisp cl-store/utils.lisp

[Sean Ross]

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)