[elephant-cvs] CVS elephant/src

[ieslick]

Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv3181/src

Modified Files:
	classes.lisp metaclasses.lisp 
Log Message:

Tentative fixes for change-class failure to update class index.


--- /project/elephant/cvsroot/elephant/src/classes.lisp	2006/02/10 01:39:13	1.20
+++ /project/elephant/cvsroot/elephant/src/classes.lisp	2006/02/15 04:18:39	1.21
@@ -54,30 +54,34 @@
 metaclass.")
   (:metaclass persistent-metaclass))
 
-;;(defmethod print-object ((obj persistent) stream)
 
 (defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys)
-  (declare (ignore initargs))
-  (if (indexed (class-of instance))
-	(progn
-	  (let ((oid (oid instance)))
-	    (declare (type fixnum oid))
-	    (inhibit-indexing oid)
-	    (unwind-protect
-		 (call-next-method)
-	      (uninhibit-indexing oid))
-	    ;; Inhibit indexing if the object already was defined (ie being created from an oid)
-            ;;   as it should be indexed already.  This hack avoids a deadlock situation where we 
-            ;;   write the class or index page that we are currently reading via a cursor without 
-            ;;   going through the cursor abstraction. There has to be a better way to do this.
-	    (when (not from-oid)
-	      (let ((class-index (find-class-index (class-of instance))))
-		(when class-index
-;;		  (format t "Indexing initial instance: ~A :: ~A~%" oid instance)
-		  (with-transaction ()
-		    (setf (get-value oid class-index) instance)))))))
-	;; else
-	(call-next-method)))
+  (declare (ignorable initargs instance from-oid))
+  (call-next-method))
+
+
+;; (defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys)
+;;   (if (indexed (class-of instance))
+;; 	(progn
+;; 	  (let ((oid (oid instance)))
+;; 	    (declare (type fixnum oid))
+;; 	    (inhibit-indexing oid)
+;; 	    (unwind-protect
+;; 		 (call-next-method)
+;; 	      (uninhibit-indexing oid))
+;; 	  ;; Inhibit indexing altogether if the object already was defined (ie being created 
+;;           ;;   from an oid) as it should be indexed already.  This hack avoids a deadlock 
+;;           ;;   situation where we write the class or index page that we are currently reading 
+;;           ;;   via a cursor without going through the cursor abstraction. There has to be a 
+;;           ;;   better way to do this.
+;; 	    (when (not from-oid)
+;; 	      (let ((class-index (find-class-index (class-of instance))))
+;; 		(when class-index
+;; ;;		  (format t "Indexing initial instance: ~A :: ~A~%" oid instance)
+;; 		  (with-transaction ()
+;; 		    (setf (get-value oid class-index) instance)))))))
+;; 	;; else
+;; 	(call-next-method)))
 
 (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
   "Ensures we inherit from persistent-object."
@@ -160,13 +164,16 @@
 ;; 	(setf (%persistent-slots instance) 
 ;; 	      (cons (persistent-slot-names instance) nil)))))
 
-(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys)
+(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys)
   "Initializes the persistent slots via initargs or forms.
 This seems to be necessary because it is typical for
 implementations to optimize setting the slots via initforms
 and initargs in such a way that slot-value-using-class et al
-aren't used.  Calls the next method for the transient slots."
+aren't used.  We also handle writing any indices after the 
+class is fully initialized.  Calls the next method for the transient 
+slots."
   (let* ((class (class-of instance))
+	 (oid (oid instance))
 	 (persistent-slot-names (persistent-slot-names class)))
     (flet ((persistent-slot-p (item) 
 	     (member item persistent-slot-names :test #'eq)))
@@ -177,6 +184,8 @@
 	    (persistent-slot-inits
 	     (if (eq slot-names t) persistent-slot-names
 		 (remove-if-not #'persistent-slot-p slot-names))))
+	(inhibit-indexing oid)
+	(unwind-protect 
 	;; initialize the persistent slots
 	(flet ((initialize-from-initarg (slot-def)
 		 (loop for initarg in initargs
@@ -187,23 +196,31 @@
 			  (getf initargs initarg))
 		    (return t))))
 	  (loop for slot-def in (class-slots class)
-	     unless 
-	     (initialize-from-initarg slot-def)
-	     when 
-	     (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
-	     unless 
-	     (slot-boundp-using-class class instance slot-def)
+	     unless (initialize-from-initarg slot-def)
+	     when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
+	     unless (slot-boundp-using-class class instance slot-def)
 	     do
 	     (let ((initfun (slot-definition-initfunction slot-def)))
 	       (when initfun
 		 (setf (slot-value-using-class class instance slot-def)
-		       (funcall initfun))))
-	     )
+		       (funcall initfun)))))
 ;; 	  (format t "transient-slot-inits ~A~%" transient-slot-inits)
 ;; 	  (format t "indices boundp ~A~%" (slot-boundp instance 'indices))
 ;; 	  (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache))
 	  ;; let the implementation initialize the transient slots
-	  (apply #'call-next-method instance transient-slot-inits initargs))))))
+	  (apply #'call-next-method instance transient-slot-inits initargs))
+	  (uninhibit-indexing oid))
+	  ;; Inhibit indexing altogether if the object already was defined (ie being created 
+          ;;   from an oid) as it should be indexed already.  This hack avoids a deadlock 
+          ;;   situation where we write the class or index page that we are currently reading 
+          ;;   via a cursor without going through the cursor abstraction. There has to be a 
+          ;;   better way to do this.
+	  (when (and (indexed class) (not from-oid))
+	    (let ((class-index (find-class-index (class-of instance))))
+	      (when class-index
+		(with-transaction ()
+		  (setf (get-value oid class-index) instance)))))
+	  ))))
 
 (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
   ;; NOTE: probably should delete discarded slots, but we'll worry about that later
--- /project/elephant/cvsroot/elephant/src/metaclasses.lisp	2006/02/10 01:39:13	1.14
+++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp	2006/02/15 04:18:39	1.15
@@ -82,9 +82,9 @@
 (defmacro defpclass (cname parents slot-defs &optional class-opts)
   `(defclass ,cname ,parents
      ,slot-defs
-     ,(add-persistent-metaclass class-opts)))
+     ,(add-persistent-metaclass-argument class-opts)))
 
-(defun add-persistent-metaclass (class-opts)
+(defun add-persistent-metaclass-argument (class-opts)
   (when (assoc :metaclass class-opts)
     (error "User metaclass specification not allowed in defpclass"))
   (append (list :metaclass 'persistent-metaclass) class-opts))
@@ -144,7 +144,8 @@
 
 ;; This just encapsulates record keeping a bit
 (defclass indexing-record ()
-  ((slots :accessor indexing-record-slots :initarg :slots :initform nil)
+  ((class :accessor indexing-record-class :initarg :class :initform t)
+   (slots :accessor indexing-record-slots :initarg :slots :initform nil)
    (derived-count :accessor indexing-record-derived :initarg :derived :initform 0)))
 
 (defmethod print-object ((obj indexing-record) stream)