Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv12530/src

Modified Files: classes.lisp Log Message: initialize-instance obj : forgot to cache instances initialize-instance class => shared-initialize : reinitialize instance fixes shared-initialize obj : transients before persistents

Date: Sat Sep 4 10:16:12 2004 Author: blee

Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.8 elephant/src/classes.lisp:1.9 --- elephant/src/classes.lisp:1.8 Thu Sep 2 16:41:25 2004 +++ elephant/src/classes.lisp Sat Sep 4 10:16:11 2004 @@ -50,7 +50,8 @@ "Sets the OID." (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) - (setf (oid instance) from-oid))) + (setf (oid instance) from-oid)) + (cache-instance *store-controller* instance))

(defclass persistent-object (persistent) ((%persistent-slots :transient t)) @@ -58,12 +59,32 @@ classes") (:metaclass persistent-metaclass))

-(defmethod initialize-instance :around ((class persistent-metaclass) &rest args &key direct-superclasses) +#| +(defmethod compute-class-precedence-list :around ((class persistent-metaclass)) + (let ((cpl (call-next-method)) + (persistent-object (find-class 'persistent-object))) + (if (member persistent-object cpl :test #'eq) + cpl + (let ((std-obj (find-class 'standard-object)) + (ccpl (copy-list cpl))) + (loop for c on ccpl + when (eq (cadr c) std-obj) + do + (setf (cdr c) (cons persistent-object + (cons (find-class 'persistent) (cdr c)))) + (return nil)) + ccpl)))) +|# + +(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) (let* ((persistent-metaclass (find-class 'persistent-metaclass)) + (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) - (if not-already-persistent - (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) + (if (and (not (eq class persistent-object)) not-already-persistent) + (apply #'call-next-method class slot-names + :direct-superclasses (cons persistent-object + direct-superclasses) args) (call-next-method))))

(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) @@ -79,6 +100,8 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs) ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -96,9 +119,7 @@ (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) - (funcall initfun)))))) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs))))) + (funcall initfun))))))))))

(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class))