Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv23936/src/elephant
Modified Files: classindex.lisp controller.lisp Log Message: Fixed test bug; cleaned up get-instances-by-xxx fns to use new map operators
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/28 02:31:15 1.40 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/28 03:07:38 1.41 @@ -389,7 +389,7 @@ ;; USER MAPPING API ;; ======================
-(defun map-class (fn class) +(defun map-class (fn class &key collect) "Perform a map operation over all instances of class. Takes a function of one argument, a class instance" (let* ((class (if (symbolp class) @@ -400,9 +400,9 @@ (declare (ignore k)) (funcall fn v))) (declare (dynamic-extent map-fn)) - (map-btree #'map-fn class-idx)))) + (map-btree #'map-fn class-idx :collect collect))))
-(defun map-inverted-index (fn class index &rest args &key start end value from-end) +(defun map-inverted-index (fn class index &rest args &key start end (value nil value-p) from-end collect) "map-inverted-index maps a function of two variables, taking key and instance, over a subset of class instances in the order defined by the index. Specify the class and index by quoted @@ -431,7 +431,10 @@ (declare (ignore pkey)) (funcall fn key value))) (declare (dynamic-extent wrapper)) - (map-index #'wrapper index :start start :end end :value value :from-end from-end)))) + (if value-p + (map-index #'wrapper index :value value :collect collect) + (map-index #'wrapper index :start start :end end :from-end from-end :collect collect))))) +
;; ================= @@ -454,30 +457,27 @@ nil to start or end indicates, respectively, the lowest or highest value in the index"))
+ +(defun identity2 (k v) + (declare (ignore k)) + v) + +(defun identity3 (k v pk) + (declare (ignore k pk)) + v) + (defmethod get-instances-by-class ((class symbol)) (get-instances-by-class (find-class class)))
(defmethod get-instances-by-class ((class persistent-metaclass)) - (let ((instances nil)) - (flet ((accum (c) - (declare (dynamic-extent c)) - (push c instances))) - (map-class #'accum class) - (nreverse instances)))) + (map-class #'identity class :collect t))
(defmethod get-instances-by-value ((class symbol) slot-name value) (get-instances-by-value (find-class class) slot-name value))
(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) (declare (type (or string symbol) slot-name)) - (let ((instances nil)) - (declare (type list instances)) - (flet ((collector (k v pk) - (declare (ignore k pk)) - (push v instances))) - (declare (dynamic-extent collector)) - (map-index #'collector (find-inverted-index class slot-name) :value value)) - (nreverse instances))) + (map-inverted-index #'identity2 class slot-name :value value :collect t))
(defmethod get-instance-by-value ((class symbol) slot-name value) (let ((list (get-instances-by-value (find-class class) slot-name value))) @@ -495,15 +495,7 @@ (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (declare (type (or fixnum null) start end) (type symbol idx-name)) - (let ((instances nil)) - (declare (type list instances)) - (flet ((collector (k v pk) - (declare (ignore k pk)) - (push v instances))) - (declare (dynamic-extent collector)) - (map-index #'collector (find-inverted-index class idx-name) - :start start :end end)) - (nreverse instances))) + (map-inverted-index #'identity2 class idx-name :start start :end end :collect t))
(defun drop-instances (instances &key (sc *store-controller*)) "Removes a list of persistent objects from all class indices --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/04/28 02:31:15 1.51 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/04/28 03:07:38 1.52 @@ -220,7 +220,7 @@ "Reset the instance cache (flush object lookups). Useful for testing. Does not reclaim existing objects so there will be duplicate instances with identical functionality" - (ele-with-lock ((instance-cache-lock sc)) + (ele-with-fast-lock ((instance-cache-lock sc)) (setf (instance-cache sc) (make-cache-table :test 'eql))))