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

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

Quick fix for config.lisp not having a package designator. Also my tweaks to fix a BDB bug, adding transacctions to btree writes for increased safety and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class

--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 20:18:51 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 21:03:47 1.4 @@ -42,6 +42,10 @@ automatically inherited if you use the persistent-metaclass metaclass."))

+;; ================================================ +;; METACLASS INITIALIZATION AND CHANGES +;; ================================================ + (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -54,59 +58,8 @@ direct-superclasses) args) (call-next-method))))

-#+allegro -(defun make-persistent-reader (name slot-definition class class-name) - (eval `(defmethod ,name ((instance ,class-name)) - (slot-value-using-class ,class instance ,slot-definition)))) - -#+allegro -(defun make-persistent-writer (name slot-definition class class-name) - (let ((name (if (and (consp name) - (eq (car name) 'setf)) - name - `(setf ,name)))) - (eval `(defmethod ,name ((instance ,class-name) value) - (setf (slot-value-using-class ,class instance ,slot-definition) - value))))) - -#+allegro -(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) - (let ((readers (slot-definition-readers slot-definition)) - (writers (slot-definition-writers slot-definition)) - (class-name (class-name class))) - (loop for reader in readers - do (make-persistent-reader reader slot-definition class class-name)) - (loop for writer in writers - do (make-persistent-writer writer slot-definition class class-name)))) - -#+allegro -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) - (loop with persistent-slots = (persistent-slots instance) - for slot-def in (class-direct-slots instance) - when (member (slot-definition-name slot-def) persistent-slots) - do (initialize-accessors slot-def instance)) - (make-instances-obsolete instance)))) - -#+(or cmu sbcl openmcl) -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) - (make-instances-obsolete instance)))) - -;; #+allegro (defmethod finalize-inheritance :around ((instance persistent-metaclass)) + "Update the persistent slot records in the metaclass" (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) @@ -115,13 +68,9 @@ (when (not (slot-boundp instance '%indexed-slots)) (update-indexed-record instance (indexed-slot-names-from-defs instance)))))

-;; #+(or cmu sbcl) -;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) -;; (prog1 -;; (call-next-method) -;; (if (not (slot-boundp instance '%persistent-slots)) -;; (setf (%persistent-slots instance) -;; (cons (persistent-slot-names instance) nil))))) +;; ================================================ +;; PERSISTENT OBJECT MAINTENANCE +;; ================================================

(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. @@ -151,9 +100,10 @@ with slot-initargs = (slot-definition-initargs slot-def) when (member initarg slot-initargs :test #'eq) do - (setf (slot-value-using-class class instance slot-def) - (getf initargs initarg)) - (return t)))) + (setf (slot-value-using-class class instance slot-def) + (getf initargs initarg)) + (return t)))) + (with-transaction (:store-controller (get-con instance)) (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) @@ -162,7 +112,7 @@ (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)) @@ -177,12 +127,12 @@ (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index class))) (when class-index - (with-transaction (:store-controller (get-con class-index)) - (setf (get-value oid class-index) instance))))) + (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) +(defmethod update-instance-for-redefined-class ((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 + ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) @@ -210,14 +160,15 @@ ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) - (loop for slot-def in (class-slots new-class) - when (member (slot-definition-name slot-def) retained-persistent-slots) - do (setf (slot-value-using-class new-class - current - slot-def) - (slot-value-using-class old-class - previous - (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + (with-transaction (:store-controller (get-con current)) + (loop for slot-def in (class-slots new-class) + when (member (slot-definition-name slot-def) retained-persistent-slots) + do (setf (slot-value-using-class new-class + current + slot-def) + (slot-value-using-class old-class + previous + (find-slot-def-by-name old-class (slot-definition-name slot-def)))))) ;; Delete this instance from its old class index, if exists (when (indexed old-class) (remove-kv (oid previous) (find-class-index old-class))) @@ -229,14 +180,6 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name)))

-;; ORIGINAL METHOD -;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) -;; "Set the slot value in the database." -;; (declare (optimize (speed 3))) -;; (let ((name (slot-definition-name slot-def))) -;; (persistent-slot-writer new-value instance name))) - -;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) @@ -270,7 +213,15 @@ (unregister-indexed-slot class (slot-definition-name slot-def))) (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def)))

-;; NOTE: Closer to MOP will fix this +;; ====================================================== +;; Handling metaclass overrides of normal slot operation +;; NOTE: Closer to MOP should replace this need... +;; ====================================================== + +;; +;; ALLEGRO +;; + #+allegro (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) (loop for slot in (class-slots class) @@ -278,3 +229,93 @@ finally (return (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method))))) + + +#+allegro +(defun make-persistent-reader (name slot-definition class class-name) + (eval `(defmethod ,name ((instance ,class-name)) + (slot-value-using-class ,class instance ,slot-definition)))) + +#+allegro +(defun make-persistent-writer (name slot-definition class class-name) + (let ((name (if (and (consp name) + (eq (car name) 'setf)) + name + `(setf ,name)))) + (eval `(defmethod ,name ((instance ,class-name) value) + (setf (slot-value-using-class ,class instance ,slot-definition) + value))))) + +#+allegro +(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) + (let ((readers (slot-definition-readers slot-definition)) + (writers (slot-definition-writers slot-definition)) + (class-name (class-name class))) + (loop for reader in readers + do (make-persistent-reader reader slot-definition class class-name)) + (loop for writer in writers + do (make-persistent-writer writer slot-definition class class-name)))) + +#+allegro +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) + (loop with persistent-slots = (persistent-slots instance) + for slot-def in (class-direct-slots instance) + when (member (slot-definition-name slot-def) persistent-slots) + do (initialize-accessors slot-def instance)) + (make-instances-obsolete instance)))) + +;; +;; CMU / SBCL +;; + +#+(or cmu sbcl) +(defun make-persistent-reader (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-reader (get-con instance) instance name))) + +#+(or cmu sbcl) +(defun make-persistent-writer (name) + (lambda (new-value instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-writer (get-con instance) new-value instance name))) + +#+(or cmu sbcl) +(defun make-persistent-slot-boundp (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-boundp (get-con instance) instance name))) + +#+(or cmu sbcl) +(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) + (let ((name (slot-definition-name slot-def))) + (setf (slot-definition-reader-function slot-def) + (make-persistent-reader name)) + (setf (slot-definition-writer-function slot-def) + (make-persistent-writer name)) + (setf (slot-definition-boundp-function slot-def) + (make-persistent-slot-boundp name))) + slot-def) + +#+(or cmu sbcl openmcl) +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) +;; (initialize-internal-slot-functions + (make-instances-obsolete instance)))) + --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/22 21:03:47 1.4 @@ -326,37 +326,6 @@ when (eq (slot-definition-name slot-def) slot-name) do (return slot-def)))

-#+(or cmu sbcl) -(defun make-persistent-reader (name) - (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-reader (get-con instance) instance name))) - -#+(or cmu sbcl) -(defun make-persistent-writer (name) - (lambda (new-value instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-writer (get-con instance) new-value instance name))) - -#+(or cmu sbcl) -(defun make-persistent-slot-boundp (name) - (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-boundp (get-con instance) instance name))) - -#+(or cmu sbcl) -(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) - (let ((name (slot-definition-name slot-def))) - (setf (slot-definition-reader-function slot-def) - (make-persistent-reader name)) - (setf (slot-definition-writer-function slot-def) - (make-persistent-writer name)) - (setf (slot-definition-boundp-function slot-def) - (make-persistent-slot-boundp name))) - slot-def)

(defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) @@ -374,4 +343,7 @@ (mapcar #'slot-definition-name (persistent-slot-defs class)))

(defun transient-slot-names (class) - (mapcar #'slot-definition-name (transient-slot-defs class))) \ No newline at end of file + (mapcar #'slot-definition-name (transient-slot-defs class))) + + +