[elephant-cvs] CVS elephant/src

[ieslick]

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

Modified Files:
      Tag: ELEPHANT-0-4-1-rc1-IAN
	IAN-TODO classes.lisp indexing.lisp metaclasses.lisp 
	sql-collections.lisp 
Log Message:

Significant rework of portions of the indexing.  Still chasing an odd test interaction
but all tests pass under (do-indexing-tests) but not under (do-all-tests).  Very odd.
This should constitute a first feature set release.  I will add tests incrementally
as I work with the system.


--- /project/elephant/cvsroot/elephant/src/classes.lisp	2006/01/29 04:57:20	1.16.2.4
+++ /project/elephant/cvsroot/elephant/src/classes.lisp	2006/01/30 04:55:00	1.16.2.5
@@ -79,6 +79,21 @@
 metaclass.")
   (:metaclass persistent-metaclass))
 
+(defmethod initialize-instance ((instance persistent-object) &rest initargs)
+  (declare (ignore initargs))
+  (if (indexed (class-of instance))
+      (progn
+	(inhibit-indexing (oid instance))
+	(unwind-protect
+	     (progn
+	       (call-next-method)
+	       (uninhibit-indexing (oid instance))
+	       (let ((class-index (find-class-index (class-of instance))))
+		 (with-transaction ()
+		   (setf (get-value (oid instance) class-index) instance))))
+	  (uninhibit-indexing (oid instance))))
+      (call-next-method)))
+
 (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))
@@ -139,14 +154,14 @@
       (make-instances-obsolete instance))))
 
 ;; #+allegro
-(defmethod finalize-inheritance :around ((class persistent-metaclass))
+(defmethod finalize-inheritance :around ((instance persistent-metaclass))
   (prog1
       (call-next-method)
-    (when (not (slot-boundp class '%persistent-slots))
-	(setf (%persistent-slots class) 
-	      (cons (persistent-slot-names class) nil)))
-    (when (not (slot-boundp class '%indexed-slots))
-      (update-indexed-record class (indexed-slot-names-from-defs class)))))
+    (when (not (slot-boundp instance '%persistent-slots))
+	(setf (%persistent-slots instance) 
+	      (cons (persistent-slot-names instance) nil)))
+    (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))
@@ -156,8 +171,6 @@
 ;; 	(setf (%persistent-slots instance) 
 ;; 	      (cons (persistent-slot-names instance) nil)))))
 
-;; ISE: Not necessary for allegro 7.0?  Initial values are written twice when I traced (setf slot-value-using-class)
-#-allegro
 (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
--- /project/elephant/cvsroot/elephant/src/metaclasses.lisp	2006/01/29 04:57:20	1.10.2.4
+++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp	2006/01/30 04:55:00	1.10.2.5
@@ -154,12 +154,12 @@
 ;; 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)))
+   (derived-count :accessor indexing-record-derived :initarg :derived :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)))
+	  (length (indexing-record-derived obj))))
 
 (defmethod indexed-record ((class standard-class)) 
   nil)
@@ -176,7 +176,7 @@
     (setf (%indexed-slots class) 
 	  (cons (make-instance 'indexing-record 
 			       :slots new-slot-list
-			       :derived-count (if oldrec (indexing-record-derived-count oldrec) 0))
+			       :derived (when oldrec (indexing-record-derived oldrec)))
 		(if oldrec oldrec nil)))))
 
 (defun indexed-slot-names-from-defs (class)
@@ -193,10 +193,10 @@
   ;; 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))
+      (error "Tried to register slot ~A as index 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
+;;      the duplicate warning
 ;;      (warn "Tried to index slot ~A which is already indexed" slot))
       (push slot (indexing-record-slots record))))
   ;; change effective slot def
@@ -223,24 +223,35 @@
 (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))))
+    (push name (indexing-record-derived 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))))
+    (setf (indexing-record-derived record) (remove name (indexing-record-derived record)))))
 
 (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)))))
+	   (indexing-record-derived (indexed-record class)))))
 
 (defmethod indexed ((slot standard-slot-definition)) nil)
 (defmethod indexed ((class standard-class)) nil)
 
+(defvar *inhibit-indexing-list* nil
+  "Use this to avoid updating an index inside
+   low-level functions that update groups of
+   slots at once.  We may need to rethink this
+   if we go to a cheaper form of update that
+   doesn't batch update all indices")
+
+(defun inhibit-indexing (uid)
+  (pushnew uid *inhibit-indexing-list*))
+
+(defun uninhibit-indexing (uid)
+  (setf *inhibit-indexing-list*
+	(delete uid *inhibit-indexing-list*)))
+
 ;;
 ;; Original support for persistent slot protocol
 ;;
--- /project/elephant/cvsroot/elephant/src/sql-collections.lisp	2005/11/23 17:51:37	1.2
+++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp	2006/01/30 04:55:00	1.2.2.1
@@ -47,7 +47,6 @@
   (:metaclass persistent-metaclass)
   (:documentation "A SQL-based BTree supports secondary indices."))
 
-
 (defmethod get-value (key (bt sql-btree-index))
   "Get the value in the primary DB from a secondary key."
   (declare (optimize (speed 3)))