[elephant-cvs] CVS update: elephant/src/classes.lisp

[blee at common-lisp.net]

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