Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv21689/src
Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp indexing.lisp metaclasses.lisp Log Message:
Latest stable point for everything except change-class and synching classes to pre-existing repositories. Significantly cleaned up indexed-slot handling in the metaclass to be less impactful on existing code.
--- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 00:03:49 1.16.2.2 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 18:52:49 1.16.2.3 @@ -114,10 +114,12 @@
#+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)) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) @@ -126,6 +128,7 @@
#+(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) @@ -140,11 +143,7 @@ (setf (%persistent-slots class) (cons (persistent-slot-names class) nil))) (when (not (slot-boundp class '%indexed-slots)) - (setf (%indexed-slots class) - (cons (indexed-slot-names class) nil))) - (when (not (slot-boundp class '%derived-index-count)) - (setf (%derived-index-count class) 0)))) - + (update-indexed-record class (indexed-slot-names-from-defs class)))))
;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -201,6 +200,7 @@
(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 + (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) ;; (format t "persisent-slots ~A~%" (persistent-slots (class-of instance))) @@ -253,8 +253,7 @@ (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name) - (when (%indexed-p class) - (update-class-index class instance)))) + (update-index-on-write class instance slot-def)))
(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." @@ -275,19 +274,20 @@
(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)) - (if (sql-store-spec-p (:dbcn-spc-pst instance)) - (progn + (declare (optimize (speed 3))) + (when (indexed slot-def) + (unregister-indexed-slot class (slot-definition-name slot-def))) + (if (sql-store-spec-p (:dbcn-spc-pst instance)) + (progn (let* ((sc (check-con (:dbcn-spc-pst instance))) (con (controller-db sc))) - (sql-remove-from-root - (form-slot-key (oid instance) (slot-definition-name slot-def)) - sc - con - ) - )) - (with-buffer-streams (key-buf) + (sql-remove-from-root + (form-slot-key (oid instance) (slot-definition-name slot-def)) + sc + con + ) + )) + (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize (slot-definition-name slot-def) key-buf) (db-delete-buffered @@ -304,3 +304,14 @@ finally (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method)))) + +;; Index update interface (used in functions above) + +(defmethod update-index-on-write ((class persistent-metaclass) (instance persistent-object) (slot persistent-slot-definition)) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-persistent slots. update-class-index is implemented + by the subsystem that maintains the index" + (when (or (slot-value slot 'indexed) + (> (indexing-record-derived-count (indexed-record class)) 0)) + (update-class-index class instance))) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 00:03:49 1.10.2.2 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 18:52:49 1.10.2.3 @@ -46,6 +46,7 @@ (make-hash-table :test 'equal))
(defun connection-is-indeed-open (con) + (declare (ignore con)) t ;; I don't yet know how to implement this )
@@ -89,13 +90,16 @@ (defclass persistent-metaclass (standard-class) ((%persistent-slots :accessor %persistent-slots) (%indexed-slots :accessor %indexed-slots) - (%derived-index-count :accessor %derived-index-count) - (%instance-index :accessor %instance-index)) + (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise. Slots can also -be indexed for by-value retrieval")) +be indexed for by-value retrieval.")) + +;; +;; Persistent slot maintenance +;;
(defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) @@ -117,30 +121,9 @@ nil) )))
-(defmethod %indexed-p ((class persistent-metaclass)) - (or (and (slot-boundp class '%indexed-slots) - (car (%indexed-slots class))) - (and (slot-boundp class '%derived-index-count) - (> (%derived-index-count class) 0)))) - -(defmethod indexed-slots ((class persistent-metaclass)) - (car (%indexed-slots class))) - -(defmethod indexed-slots ((class standard-class)) - nil) - -(defmethod old-indexed-slots ((class persistent-metaclass)) - (cdr (%indexed-slots class))) - -(defmethod update-indexed-slots ((class persistent-metaclass) new-slot-list) - (setf (%indexed-slots class) (cons new-slot-list - (if (slot-boundp class '%indexed-slots) - (car (%indexed-slots class)) - nil)))) -
(defclass persistent-slot-definition (standard-slot-definition) - ()) + ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance)))
(defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -157,16 +140,6 @@ (defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ())
- -(defclass indexed-slot-definition (persistent-slot-definition) - ((indexed :initform t :initarg :indexed :allocation :class))) - -(defclass indexed-direct-slot-definition (persistent-direct-slot-definition indexed-slot-definition) - ()) - -(defclass indexed-effective-slot-definition (persistent-effective-slot-definition indexed-slot-definition) - ()) - (defgeneric transient (slot))
(defmethod transient ((slot standard-direct-slot-definition)) @@ -175,13 +148,101 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil)
-(defgeneric indexed (slot)) +;; +;; Indexed slots maintenance +;; + +;; This just encapsulates record keeping a bit +(defclass indexing-record () + ((slots :accessor indexing-record-slots :initarg :slots :initform nil) + (derived-count :accessor indexing-record-derived-count :initarg :derived-count :initform 0))) + +(defmethod print-object ((obj indexing-record) stream) + (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>" + (length (indexing-record-slots obj)) + (indexing-record-derived-count obj)))
-(defmethod indexed ((slot standard-direct-slot-definition)) +(defmethod indexed-record ((class standard-class)) nil) +(defmethod indexed-record ((class persistent-metaclass)) + (car (%indexed-slots class))) +(defmethod old-indexed-record ((class persistent-metaclass)) + (cdr (%indexed-slots class))) +(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) + (let ((oldrec (if (slot-boundp class '%indexed-slots) + (indexed-record class) + nil))) + (setf (%indexed-slots class) + (cons (make-instance 'indexing-record + :slots new-slot-list + :derived-count (if oldrec (indexing-record-derived-count oldrec) 0)) + (if oldrec oldrec nil)))))
-(defmethod indexed ((slot indexed-direct-slot-definition)) - t) +(defun indexed-slot-names-from-defs (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) + (indexed slot-definition)) + collect (slot-definition-name slot-definition)))) + +(defmethod register-indexed-slot ((class persistent-metaclass) slot) + "This method allows for post-definition update of indexed status of + class slots. It changes the effective method so we can rely on + generic function dispatch for differentated behavior" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (car (%persistent-slots class))) + (error "Tried to index slot ~A which isn't a persistent slot" slot)) + (unless (member slot (indexing-record-slots record)) +;; This is a normal startup case, but during other cases we'd like +;; the duplicate wraning +;; (warn "Tried to index slot ~A which is already indexed" slot)) + (push slot (indexing-record-slots record)))) + ;; change effective slot def + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) t))) + +(defmethod unregister-indexed-slot (class slot) + "Revert an indexed slot to it's original state" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (indexing-record-slots record)) + (error "Tried to unregister slot ~A which is not indexed" slot)) + (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) + ;; change effective slot def status + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) nil))) + +(defmethod register-derived-index (class name) + "Tell the class that it has derived indices defined against it + and keep a reference count" + (declare (ignore name)) + (let ((record (indexed-record class))) + (incf (indexing-record-derived-count record)))) + +(defmethod unregister-derived-index (class name) + (declare (ignore name)) + (let ((record (indexed-record class))) + (decf (indexing-record-derived-count record)) + (assert (>= (indexing-record-derived-count record) 0)))) + +(defmethod indexed ((class persistent-metaclass)) + (and (slot-boundp class '%indexed-slots ) + (or (indexing-record-slots (indexed-record class)) + (not (= (indexing-record-derived-count (indexed-record class)) 0))))) + +(defmethod indexed ((slot standard-slot-definition)) nil) +(defmethod indexed ((class standard-class)) nil) + +;; +;; Original support for persistent slot protocol +;;
#+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) @@ -204,8 +265,6 @@ (error "Persistent class slots are not supported, try :transient t.")) ((and indexed-p transient-p) (error "Cannot declare slots to be both transient and indexed")) - (indexed-p - (find-class 'indexed-direct-slot-definition)) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -239,8 +298,6 @@ (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) (error "Cannot declare a slot to be both indexed and transient")) - (indexed-p - (find-class 'indexed-effective-slot-definition)) (transient-p (find-class 'transient-effective-slot-definition)) (t @@ -293,7 +350,9 @@ (if (ensure-transient-chain slot-definitions initargs) (setf initargs (append initargs '(:transient t))) (setf (getf initargs :allocation) :database)) - (if (some #'indexed slot-definitions) + ;; Effective slots are indexed only if the most recent slot definition + ;; is indexed. NOTE: Need to think more about inherited indexed slots + (if (indexed (first slot-definitions)) (append initargs '(:indexed t)) initargs)))
@@ -387,8 +446,3 @@ (loop for slot-definition in slot-definitions unless (persistent-p slot-definition) collect (slot-definition-name slot-definition)))) - -(defun indexed-slot-names (class) - (loop for slot-definition in (class-slots class) - when (subtypep (type-of slot-definition) 'indexed-effective-slot-definition) - collect (slot-definition-name slot-definition)))