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@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@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@jhb.ucs.co.za" :maintainer "Sean Ross sdr@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