Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4404/src Modified Files: metaclasses.lisp elephant.lisp classes.lisp Log Message: mop updates : update-class, change-class, new slot allocation type... Date: Thu Feb 24 02:07:53 2005 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.6 elephant/src/metaclasses.lisp:1.7 --- elephant/src/metaclasses.lisp:1.6 Sun Sep 19 19:50:38 2004 +++ elephant/src/metaclasses.lisp Thu Feb 24 02:07:52 2005 @@ -49,12 +49,24 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - () + ((%persistent-slots :accessor %persistent-slots)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise.")) +(defmethod persistent-slots ((class persistent-metaclass)) + (car (%persistent-slots class))) + +(defmethod persistent-slots ((class standard-class)) + nil) + +(defmethod old-persistent-slots ((class persistent-metaclass)) + (cdr (%persistent-slots class))) + +(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list) + (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) + (defclass persistent-slot-definition (standard-slot-definition) ()) @@ -81,8 +93,12 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil) +#+allegro +(defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) + '(:instance :class :database)) + (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) - :class) + :database) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) @@ -128,29 +144,6 @@ (t (find-class 'persistent-effective-slot-definition))))) -#+(or cmu sbcl) -(defgeneric ensure-storage-exists (class slot-definition slot-name)) - -#+(or cmu sbcl) -(defmethod ensure-storage-exists (class slot-definition slot-name) - nil) - -#+(or cmu sbcl) -(defmethod ensure-storage-exists (class (slot-definition persistent-slot-definition) slot-name) - (let ((use-class (or (slot-definition-allocation-class slot-definition) - class))) - (when (not (assoc slot-name (class-slot-cells use-class))) - (setf (plist-value use-class 'class-slot-cells) - (append - (plist-value use-class 'class-slot-cells) - (list (cons slot-name +slot-unbound+))))))) - -#+(or cmu sbcl) -(defmethod compute-effective-slot-definition :around ((class persistent-metaclass) slot-name direct-slot-definitions) - (let ((slot-definition (call-next-method))) - (ensure-storage-exists class slot-definition slot-name) - slot-definition)) - #+openmcl (defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions) (declare (ignore slot-name)) @@ -198,7 +191,7 @@ (if (ensure-transient-chain slot-definitions initargs) (append initargs '(:transient t)) (progn - (setf (getf initargs :allocation) :class) + (setf (getf initargs :allocation) :database) initargs)))) (defmacro persistent-slot-reader (instance name) Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.13 elephant/src/elephant.lisp:1.14 --- elephant/src/elephant.lisp:1.13 Tue Sep 21 03:35:11 2004 +++ elephant/src/elephant.lisp Thu Feb 24 02:07:52 2005 @@ -104,6 +104,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots initialize-internal-slot-functions @@ -142,6 +144,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots) #+sbcl (:import-from :sb-pcl @@ -181,6 +185,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots) #+allegro (:import-from :excl Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.12 elephant/src/classes.lisp:1.13 --- elephant/src/classes.lisp:1.12 Tue Sep 21 21:35:29 2004 +++ elephant/src/classes.lisp Thu Feb 24 02:07:52 2005 @@ -54,9 +54,9 @@ (cache-instance *store-controller* instance)) (defclass persistent-object (persistent) - ((%persistent-slots :transient t)) + () (:documentation -"Superclass of all user-defined persistent classes. This is + "Superclass of all user-defined persistent classes. This is automatically inherited if you use the persistent-metaclass metaclass.") (:metaclass persistent-metaclass)) @@ -73,6 +73,63 @@ 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) + (eval `(defmethod (setf ,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) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (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) +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (make-instances-obsolete instance)))) + +#+allegro +(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))))) + +#+(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))))) + (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for @@ -111,45 +168,76 @@ ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs))))) +(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) + ;; probably should delete discarded slots, but we'll worry about that later + (prog1 + (call-next-method) + (let* ((class (class-of instance)) + (new-persistent-slots (set-difference (persistent-slots class) + (old-persistent-slots class)))) + + (apply #'shared-initialize instance new-persistent-slots initargs)))) + +(defun find-slot-def-by-name (class slot-name) + (loop for slot-def in (class-slots class) + when (eq (slot-definition-name slot-def) slot-name) + do (return slot-def))) + (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) - "Need to also update the persistent-slots, which have -:class allocation." - (let ((new-persistent-slots - (loop for slotd in (class-slots (class-of current)) - for slot-name = (slot-definition-name slotd) - with old-slot-names = (mapcar #'slot-definition-name - (class-slots (class-of previous))) - when (and (not (member slot-name old-slot-names :test #'eq)) - (persistent-p slotd)) - collect slot-name))) - (apply #'shared-initialize current new-persistent-slots initargs) + (let* ((old-class (class-of previous)) + (new-class (class-of current)) + (new-persistent-slots (set-difference + (persistent-slots new-class) + (persistent-slots old-class))) + (raw-retained-persistent-slots (intersection (persistent-slots new-class) + (persistent-slots old-class))) + (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots + when (not (persistent-slot-boundp previous slot-name)) + collect slot-name)) + (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + (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))))) (call-next-method))) -(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) -(defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) +(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)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) -(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp instance name))) -(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) + "Checks if the slot exists in the database." + (declare (optimize (speed 3))) + (loop for slot in (class-slots class) + for matches-p = (eq (slot-definition-name slot) slot-name) + until matches-p + finally (if (and matches-p + (typep slot 'persistent-slot-definition)) + (persistent-slot-boundp instance slot-name) + (call-next-method)))) + +(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize (slot-definition-name slot-def) key-buf) @@ -158,4 +246,11 @@ :transaction *current-transaction* :auto-commit *auto-commit*)) instance) - \ No newline at end of file + +#+allegro +(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) + (loop for slot in (class-slots class) + until (eq (slot-definition-name slot) slot-name) + finally (if (typep slot 'persistent-slot-definition) + (slot-makunbound-using-class class instance slot) + (call-next-method)))) \ No newline at end of file