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)