[elephant-cvs] CVS elephant/src
ieslick
ieslick at common-lisp.net
Wed Feb 8 03:23:12 UTC 2006
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv713/src
Modified Files:
indexing.lisp
Log Message:
Minor cleanup of indexing tests, declarations and rule-based code.
100% of tests pass under allegro 7.0 and Mac OS X.
--- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2
+++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3
@@ -1,7 +1,7 @@
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
-;;; slot-index.lisp -- use btree collections to track objects by slot values
-;;; via metaclass options or accessor :after methods
+;;; indexing.lisp -- use btree collections to track objects by slot values
+;;; via metaclass options or accessor :after methods
;;;
;;; Initial version 1/24/2006 Ian Eslick
;;; eslick at alum mit edu
@@ -100,6 +100,7 @@
(defun no-indexing-needed? (class instance slot-def oid)
+ (declare (ignore instance))
(or (and (not (indexed slot-def)) ;; not indexed
(not (indexing-record-derived (indexed-record class)))) ;; no derived indexes
(member oid *inhibit-indexing-list*))) ;; currently inhibited
@@ -199,7 +200,7 @@
(when class
(disable-class-indexing class :sc sc))))
-(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t))
+(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*))
(let ((class-idx (find-class-index class :sc sc)))
(unless class-idx (return-from disable-class-indexing nil))
;; Remove all instance key/value data from the class index (& secondary indices)
@@ -354,6 +355,8 @@
(get-instances-by-value (find-class class) slot-name value))
(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value)
+ (declare (optimize (speed 3) (safety 1) (space 1))
+ (type (or string symbol) slot-name))
(let ((instances nil))
(with-btree-cursor (cur (find-inverted-index class slot-name))
(multiple-value-bind (exists? skey val pkey) (cursor-pset cur value)
@@ -371,6 +374,9 @@
(get-instances-by-range (find-class class) slot-name start end))
(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end)
+ (declare (optimize speed (safety 1) (space 1))
+ (type fixnum start end)
+ (type string idx-name))
(with-inverted-cursor (cur class idx-name)
(labels ((next-range (instances)
(multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur)
@@ -406,16 +412,21 @@
;; TO READER: I got really tired of trying to figure out all
;; the messy conditionals and I figure default behaviors are something
-;; others might want to modify, so here's what determines the
-;; rule behavior.
-
-;; Rules match on the following state of the metaclass and
-;; the current class-index in the database for a given slotname:
+;; others might want to modify, so here's what determines the rule
+;; behavior.
+;;
+;; Rules match on the following states of the metaclass and current
+;; database class-index for each slotname currently in either of
+;; those sources. Actions are taken, typically when a slot exists
+;; in one but not the other or features like indexed/persistent
+;; differ between the slots
+;;
;; class state:
;; class-indexed - the slot is marked as indexed
;; class-persistent - the slot is marked as persistent (not indexed)
;; class-transient - the slot is marked transient
;; class-derived - the slot is in the derived list of the class
+;;
;; database
;; db-slot - the database has a slot index
;; db-derived - the database has a derived index
@@ -424,10 +435,12 @@
;; (not indexed-slot) for example, to cover more than one feature
;; combination
;;
-;; Each rule should apply uniquely to a given feature set
-;; Actions taken include:
-;; add-slot-index - add a new index to the db
-;; remove-slot-index - remove a slot from the db
+;; Each rule should apply uniquely to a given feature set.
+;;
+;; Actions taken when rules match can include:
+;;
+;; add-slot-index - add a new index with the slotname to the db
+;; remove-slot-index - remove a slot with the slotname from the db
;; add-derived-index - xxx this makes no sense! xxx
;; remove-derived-index - remove a derived index from the db
;; unregister-indexed-slot - remove an indexed slot from the class metaobject
@@ -436,6 +449,8 @@
;; register-derived-index - register a derived index with the class metaobject
;;
+;; DEFINE THE SYNCHRONIZATION RULES
+
(eval-when (:compile-toplevel)
(defclass synch-rule ()
((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil)
@@ -461,10 +476,8 @@
(db-derived class-persistent => remove-derived-index warn))
;; NOTE: What about cases where we need to remove things as below?
(:db ;; db changes class
- ((not db-slot) class-indexed =>
- unregister-indexed-slot)
- ((not db-derived) class-derived =>
- unregister-derived-index)
+ ((not db-slot) class-indexed => unregister-indexed-slot)
+ ((not db-derived) class-derived => unregister-derived-index)
(db-slot class-persistent => register-indexed-slot)
(db-slot class-transient => remove-indexed-slot)
(db-derived class-transient => remove-derived-index warn)
@@ -474,22 +487,34 @@
(not class-persistent) (not class-transient) =>
register-derived-slot)))))
)
-
+
+;; TOP LEVEL METHOD
+
+(defun synchronize-class-to-store (class &key (sc *store-controller*)
+ (method *default-indexed-class-synch-policy*))
+ (let ((slot-records (compute-class-and-ele-status class sc))
+ (rule-set (cdr (assoc method *synchronize-rules*))))
+ (apply-synch-rules class slot-records rule-set)))
+
+;; COMPUTING RULE APPLICABILITY AND FIRING
(defun synch-rule-applicable? (rule features)
(simple-match-set (synch-rule-lhs rule) features))
(defun simple-match-set (a b)
+ (declare (optimize (speed 3) (safety 1)))
(cond ((null a) t)
((and (not (null a)) (null b)) nil)
((member (first a) b :test #'equal)
(simple-match-set (cdr a) (remove (first a) b :test #'equal)))
(t nil)))
+(defparameter *print-synch-messages* nil)
+
(defun apply-synch-rule (rule class name)
- (format t "Class/DB Synch: converting state ~A using ~A for ~A~%"
- (synch-rule-lhs rule) (synch-rule-rhs rule) name)
-;; (return-from apply-synch-rule nil)
+ (when *print-synch-messages*
+ (format t "Class/DB Synch: converting state ~A using ~A for ~A~%"
+ (synch-rule-lhs rule) (synch-rule-rhs rule) name))
(loop for action in (synch-rule-rhs rule) do
(case action
(add-slot-index (add-class-slot-index class name :update-class nil))
@@ -502,9 +527,20 @@
(register-derived-index (register-derived-index class name))
(warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule))))))
-(defun synchronize-class-to-store (class &key (sc *store-controller*)
- (method *default-indexed-class-synch-policy*))
- (let* ((*store-controller* sc)
+(defun apply-synch-rules (class records rule-set)
+ (declare (optimize (speed 3) (safety 1)))
+ (labels ((slotname (rec) (car rec))
+ (feature-set (rec) (cdr rec)))
+ (loop for record in records do
+ (loop for rule in rule-set
+ when (synch-rule-applicable? rule (feature-set record))
+ do
+ (apply-synch-rule rule class (slotname record))))))
+
+;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES
+
+(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*))
+ (let* ((*store-controller* store-controller)
;; db info
(db-indices (find-inverted-index-names class))
(db-derived (mapcar #'get-derived-name-root
@@ -525,24 +561,16 @@
(class-transient . ,other-slots)
(db-slot . ,db-slot)
(db-derived . ,db-derived))))
- (labels ((compute-feature (name set label)
- (if (member name set)
- label
- `(not ,label)))
- (compute-features (slotname)
+ (labels ((compute-features (slotname)
(let ((features nil))
(loop for set in all-sets do
(push (compute-feature slotname (cdr set) (car set))
features))
(cons slotname features)))
- (slotname (rec) (car rec))
- (feature-set (rec) (cdr rec)))
- (let ((rule-set (cdr (assoc method *synchronize-rules*)))
- (slot-records (mapcar #'compute-features all-names)))
- (loop for record in slot-records do
- (loop
- for rule in rule-set
- when (synch-rule-applicable? rule (feature-set record))
- do
- (apply-synch-rule rule class (slotname record))))))))
+ (compute-feature (name set label)
+ (if (member name set)
+ label
+ `(not ,label))))
+ (mapcar #'compute-features all-names))))
+
More information about the Elephant-cvs
mailing list