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