[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Mon Feb 11 12:47:53 UTC 2008
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv22665
Modified Files:
cache.lisp done.txt objects.lisp p-btrees.lisp package.lisp
rucksack.asd rucksack.lisp
Log Message:
Version 0.1.16: improved performance by decreasing persistent consing for btrees
and using a lazy-cache. Fixed some small bugs. Added a few handy functions and
macros.
In detail:
Added P-PUSH and P-POP.
Improved btree efficiency by switching to a different data structure
for the bindings. Instead of using a persistent cons for each key/
value pair, we now put the keys and values directly into the bnode
vector. This speeds up most btree operations because it reduces
persistent consing when adding new values and it reduces indirections
when searching for keys.
Renamed BTREE-NODE to BNODE, BTREE-NODE-INDEX to BNODE-BINDINGS,
BTREE-NODE-INDEX-COUNT to BNODE-NR-BINDINGS, FIND-BINDING-IN-NODE to
FIND-KEY-IN-NODE.
Fix a missing argument bug in REMOVE-CLASS-INDEX.
Added a LAZY-CACHE which just clears the entire hash table whenever
the cache gets full. This improves memory usage, because the normal
cache queue kept track of a lot of objects that for some reason
couldn't be cleaned up by the implementation's garbage collector.
Added the convenience macros RUCKSACK-DO-CLASS and RUCKSACK-DO-SLOT.
Made RUCKSACK-DELETE-OBJECT an exported symbol of the RUCKSACK
package.
Fix a bug in TEST-NON-UNIQUE-BTREE: it should call
CHECK-NON-UNIQUE-CONTENTS instead of CHECK-CONTENTS.
--- /project/rucksack/cvsroot/rucksack/cache.lisp 2008/02/03 12:32:15 1.14
+++ /project/rucksack/cvsroot/rucksack/cache.lisp 2008/02/11 12:47:52 1.15
@@ -1,4 +1,4 @@
-;; $Id: cache.lisp,v 1.14 2008/02/03 12:32:15 alemmens Exp $
+;; $Id: cache.lisp,v 1.15 2008/02/11 12:47:52 alemmens Exp $
(in-package :rucksack)
@@ -120,6 +120,16 @@
objects.")))
+(defclass lazy-cache (standard-cache)
+ ()
+ (:documentation "A lazy cache doesn't bother with fancy mechanisms
+for deciding which objects to remove from the cache. It just fills
+the cache until maximum capacity (i.e. CACHE-SIZE) and then clears
+the entire cache at once. Advantages of this could be that it uses
+less time and less memory to do its work. Disadvantage is that it's
+very stupid about the objects it should try to keep in memory."))
+
+
(defmethod print-object ((cache standard-cache) stream)
(print-unreadable-object (cache stream :type t :identity nil)
(format stream "of size ~D, heap ~S and ~D objects in memory."
@@ -147,8 +157,8 @@
(defun sans (plist &rest keys)
"Returns PLIST with keyword arguments from KEYS removed."
- ;; stolen from Usenet posting <3247672165664225 at naggum.no> by Erik
- ;; Naggum
+ ;; From Usenet posting <3247672165664225 at naggum.no> by Erik
+ ;; Naggum.
(let ((sans ()))
(loop
(let ((tail (nth-value 2 (get-properties plist keys))))
@@ -369,7 +379,7 @@
(incf nr-objects-removed))))))
-(defun add-to-queue (object-id cache)
+(defmethod add-to-queue (object-id (cache standard-cache))
;; Add an object to the end of the queue.
(let ((queue (queue cache)))
(when (cache-full-p cache)
@@ -377,6 +387,18 @@
(queue-add queue object-id)))
;;
+;; Queue operations for lazy caches
+;;
+
+(defmethod make-room-in-cache ((cache lazy-cache))
+ (clrhash (objects cache)))
+
+(defmethod add-to-queue (object-id (cache lazy-cache))
+ ;; We're not adding anything to the queue, because we're too lazy.
+ object-id)
+
+
+;;
;; Open/close/map transactions
;;
--- /project/rucksack/cvsroot/rucksack/done.txt 2008/02/03 12:32:16 1.16
+++ /project/rucksack/cvsroot/rucksack/done.txt 2008/02/11 12:47:52 1.17
@@ -1,3 +1,34 @@
+* 2008-02-11 - version 0.1.16
+
+Added P-PUSH and P-POP.
+
+Improved btree efficiency by switching to a different data structure
+for the bindings. Instead of using a persistent cons for each key/
+value pair, we now put the keys and values directly into the bnode
+vector. This speeds up most btree operations because it reduces
+persistent consing when adding new values and it reduces indirections
+when searching for keys.
+
+Renamed BTREE-NODE to BNODE, BTREE-NODE-INDEX to BNODE-BINDINGS,
+BTREE-NODE-INDEX-COUNT to BNODE-NR-BINDINGS, FIND-BINDING-IN-NODE to
+FIND-KEY-IN-NODE.
+
+Fix a missing argument bug in REMOVE-CLASS-INDEX.
+
+Added a LAZY-CACHE which just clears the entire hash table whenever
+the cache gets full. This improves memory usage, because the normal
+cache queue kept track of a lot of objects that for some reason
+couldn't be cleaned up by the implementation's garbage collector.
+
+Added the convenience macros RUCKSACK-DO-CLASS and RUCKSACK-DO-SLOT.
+
+Made RUCKSACK-DELETE-OBJECT an exported symbol of the RUCKSACK
+package.
+
+Fix a bug in TEST-NON-UNIQUE-BTREE: it should call
+CHECK-NON-UNIQUE-CONTENTS instead of CHECK-CONTENTS.
+
+
* 2008-02-02 - version 0.1.15
Fixed a garbage collector bug reported by Sean Ross. When the garbage
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2008/02/03 12:32:16 1.20
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2008/02/11 12:47:52 1.21
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.20 2008/02/03 12:32:16 alemmens Exp $
+;; $Id: objects.lisp,v 1.21 2008/02/11 12:47:52 alemmens Exp $
(in-package :rucksack)
@@ -269,6 +269,29 @@
nil)
+(defmacro p-pop (place &environment env)
+ "Pop an item from the persistent list specified by PLACE."
+ (multiple-value-bind (dummies vals new setter getter)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
+ (prog1 (p-car ,(car new))
+ (setq ,(car new) (p-cdr ,(car new)))
+ ,setter))))
+
+
+(defmacro p-push (item place &environment env)
+ "Push ITEM onto the persistent list specified by PLACE. Return the
+modified persistent list. ITEM is evaluated before place."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-expansion place env)
+ (let ((item-var (gensym "ITEM")))
+ `(let* ((,item-var ,item)
+ ,@(mapcar #'list dummies vals)
+ (,(car newval) (p-cons ,item-var ,getter)))
+ ,setter))))
+
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Persistent sequence functions
;; (Just a start...)
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2008/01/22 15:59:24 1.17
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2008/02/11 12:47:52 1.18
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.17 2008/01/22 15:59:24 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.18 2008/02/11 12:47:52 alemmens Exp $
(in-package :rucksack)
@@ -21,7 +21,7 @@
#:btree-nr-keys #:btree-nr-values
;; Nodes
- #:btree-node
+ #:bnode
;; Functions
#:btree-search #:btree-insert #:btree-delete #:btree-delete-key
@@ -138,9 +138,10 @@
Basically, a B-tree is a balanced multi-way tree.
-The reason for using multi-way trees instead of binary trees is that the nodes
-are expected to be on disk; it would be inefficient to have to execute
-a disk operation for each tree node if it contains only 2 keys.
+The reason for using multi-way trees instead of binary trees is that
+the nodes are expected to be on disk; it would be inefficient to have
+to execute a disk operation for each tree node if it contains only 2
+keys.
The key property of B-trees is that each possible search path has the same
length, measured in terms of nodes.
@@ -202,10 +203,10 @@
;;
(node-class :initarg :node-class
:reader btree-node-class
- :initform 'btree-node)
+ :initform 'bnode)
(max-node-size :initarg :max-node-size
:reader btree-max-node-size
- :initform 32
+ :initform 64
:documentation "An integer specifying the preferred
maximum number of keys per btree node.")
(unique-keys-p :initarg :unique-keys-p
@@ -251,20 +252,22 @@
(let ((key< (slot-value btree 'key<))
(key-key (btree-key-key btree)))
(lambda (key1 key2)
- (funcall key<
- (funcall key-key key1)
- (funcall key-key key2)))))
+ (and (not (eql key1 'key-irrelevant))
+ (not (eql key2 'key-irrelevant))
+ (funcall key<
+ (funcall key-key key1)
+ (funcall key-key key2))))))
(defmethod btree-key= ((btree btree))
(let ((key< (slot-value btree 'key<))
(key-key (btree-key-key btree)))
(lambda (key1 key2)
- (let ((key1 (funcall key-key key1))
- (key2 (funcall key-key key2)))
- (and (not (eql key1 'key-irrelevant))
- (not (eql key2 'key-irrelevant))
- (not (funcall key< key1 key2))
- (not (funcall key< key2 key1)))))))
+ (and (not (eql key1 'key-irrelevant))
+ (not (eql key2 'key-irrelevant))
+ (let ((key1 (funcall key-key key1))
+ (key2 (funcall key-key key2)))
+ (and (not (funcall key< key1 key2))
+ (not (funcall key< key2 key1))))))))
(defmethod btree-key>= ((btree btree))
(lambda (key1 key2)
@@ -299,39 +302,41 @@
;;
-;; The next two classes are for internal use only, so we don't bother
-;; with fancy long names.
+;; Btree nodes (= 'bnodes').
;;
-(defclass btree-node ()
- ((index :initarg :index
- :initform '()
- :accessor btree-node-index
- :documentation "A vector of key/value pairs. The keys are
-sorted by KEY<. No two keys can be the same. For leaf nodes of btrees
-with non-unique-keys, the value part is actually a list of values.
-For intermediate nodes, the value is a child node. All keys in the
-child node will be KEY<= the child node's key in the parent node.")
- (index-count :initform 0
- :accessor btree-node-index-count
- :documentation "The number of key/value pairs in the index vector.")
- (leaf-p :initarg :leaf-p :initform nil :reader btree-node-leaf-p))
+(defclass bnode ()
+ ((bindings :initarg :bindings
+ :initform '()
+ :accessor bnode-bindings
+ :documentation "A vector of with alternating keys and
+values. The keys are sorted by KEY<. No two keys can be the same.
+For leaf nodes of btrees with non-unique-keys, the value part is
+actually a list of values. For intermediate nodes, the value is a
+child node. All keys in the child node will be KEY<= the child node's
+key in the parent node.")
+ (nr-bindings :initform 0
+ :accessor bnode-nr-bindings
+ :documentation "The number of key/value bindings in
+the index vector.")
+ (leaf-p :initarg :leaf-p :initform nil :reader bnode-leaf-p))
(:metaclass persistent-class))
+
;;
;; Info functions
;;
(defmethod btree-nr-keys ((btree btree))
(if (slot-boundp btree 'root)
- (btree-node-nr-keys (btree-root btree))
+ (bnode-nr-keys (btree-root btree))
0))
-(defmethod btree-node-nr-keys ((node btree-node))
- (if (btree-node-leaf-p node)
- (btree-node-index-count node)
- (loop for i below (btree-node-index-count node)
- sum (btree-node-nr-keys (binding-value (node-binding node i))))))
+(defmethod bnode-nr-keys ((node bnode))
+ (if (bnode-leaf-p node)
+ (bnode-nr-bindings node)
+ (loop for i below (bnode-nr-bindings node)
+ sum (bnode-nr-keys (binding-value (node-binding node i))))))
(defmethod btree-nr-values ((btree btree))
@@ -348,30 +353,43 @@
;; Bindings
;;
-(defun node-binding (node i)
- (let ((index (btree-node-index node)))
- (p-aref index i)))
-
-(defun (setf node-binding) (binding node i)
- (setf (p-aref (btree-node-index node) i)
- binding))
-
-
-(defun make-binding (key value)
- (p-cons key value))
-
-(defun binding-key (binding)
- (p-car binding))
+(defstruct binding
+ key
+ value)
-(defun (setf binding-key) (key binding)
- (setf (p-car binding) key))
+(defun node-binding (node i)
+ ;; A binding used to be a persistent cons, but we want to reduce
+ ;; persistent consing so now we use a small struct and try to
+ ;; make sure that we persist the relevant info when necessary.
+ (let ((vector (bnode-bindings node)))
+ (make-binding :key (p-aref vector (* 2 i))
+ :value (p-aref vector (1+ (* 2 i))))))
+
+(defun node-binding-key (node i)
+ (p-aref (bnode-bindings node) (* 2 i)))
-(defun (setf binding-value) (value binding)
- (setf (p-cdr binding) value))
+(defun node-binding-value (node i)
+ (p-aref (bnode-bindings node) (1+ (* 2 i))))
-(defun binding-value (binding)
- (p-cdr binding))
+(defun (setf node-binding) (binding node i)
+ (update-node-binding node i
+ (binding-key binding)
+ (binding-value binding))
+ binding)
+
+(defun update-node-binding (node i key value)
+ (setf (node-binding-key node i) key
+ (node-binding-value node i) value))
+
+(defun (setf node-binding-key) (key node i)
+ (setf (p-aref (bnode-bindings node) (* 2 i))
+ key))
+
+(defun (setf node-binding-value) (value node i)
+ (setf (p-aref (bnode-bindings node) (1+ (* 2 i)))
+ value))
+;;
(defun make-leaf-value (btree value)
(if (btree-unique-keys-p btree)
@@ -381,16 +399,16 @@
;;
;;
-(defmethod initialize-instance :after ((node btree-node)
+(defmethod initialize-instance :after ((node bnode)
&key btree &allow-other-keys)
- (setf (btree-node-index node) (p-make-array (btree-max-node-size btree)
- :initial-element nil)
- (btree-node-index-count node) 0))
+ (setf (bnode-bindings node) (p-make-array (* 2 (btree-max-node-size btree))
+ :initial-element nil)
+ (bnode-nr-bindings node) 0))
-(defmethod print-object ((node btree-node) stream)
+(defmethod print-object ((node bnode) stream)
(print-unreadable-object (node stream :type t :identity t)
- (format stream "with ~D bindings" (btree-node-index-count node))))
+ (format stream "with ~D bindings" (bnode-nr-bindings node))))
;;
;; Debugging
@@ -400,16 +418,15 @@
(pprint (node-as-cons node)))
(defun node-as-cons (node &optional (unique-keys t))
- (loop with index = (btree-node-index node)
- with leaf-p = (btree-node-leaf-p node)
- for i below (btree-node-index-count node)
- for binding = (p-aref index i)
- collect (list (binding-key binding)
+ (loop with leaf-p = (bnode-leaf-p node)
+ for i below (bnode-nr-bindings node)
+ for value = (node-binding-value node i)
+ collect (list (node-binding-key node i)
(if leaf-p
(if unique-keys
- (binding-value binding)
- (unwrap-persistent-list (binding-value binding)))
- (node-as-cons (binding-value binding))))))
+ value
+ (unwrap-persistent-list value))
+ (node-as-cons value)))))
(defun btree-as-cons (btree)
(and (slot-value btree 'root)
@@ -420,17 +437,17 @@
;; Depth and balance
;;
-(defmethod node-max-depth ((node btree-node))
- (if (btree-node-leaf-p node)
+(defmethod node-max-depth ((node bnode))
+ (if (bnode-leaf-p node)
0
- (loop for i below (btree-node-index-count node)
+ (loop for i below (bnode-nr-bindings node)
for binding = (node-binding node i)
maximize (1+ (node-max-depth (binding-value binding))))))
-(defmethod node-min-depth ((node btree-node))
- (if (btree-node-leaf-p node)
+(defmethod node-min-depth ((node bnode))
+ (if (bnode-leaf-p node)
0
- (loop for i below (btree-node-index-count node)
+ (loop for i below (bnode-nr-bindings node)
for binding = (node-binding node i)
minimize (1+ (node-min-depth (binding-value binding))))))
@@ -445,6 +462,7 @@
(btree-depths btree)
(<= (- max min) 1)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Search
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -482,16 +500,23 @@
;;
(defgeneric node-search (btree node key errorp default-value)
- (:method ((btree btree) (node btree-node) key errorp default-value)
+ (:method ((btree btree) (node bnode) key errorp default-value)
(let ((binding (node-search-binding btree node key)))
(if binding
(binding-value binding)
(not-found btree key errorp default-value)))))
(defgeneric node-search-binding (btree node key)
- (:method ((btree btree) (node btree-node) key)
- (if (btree-node-leaf-p node)
- (find-binding-in-node key node btree)
+ (:documentation "Tries to find KEY in NODE or one of its subnodes.
+Returns three values if the key was found: the binding, the node
+containing the binding and the position of the binding in that node.
+Returns nil otherwise.")
+ (:method ((btree btree) (node bnode) key)
+ (if (bnode-leaf-p node)
+ (multiple-value-bind (binding position)
+ (find-key-in-node btree node key)
+ (and binding
+ (values binding node position)))
(let ((subnode (find-subnode btree node key)))
(node-search-binding btree subnode key)))))
@@ -500,44 +525,64 @@
;; Find the first binding with a key >= the given key and return
;; the corresponding subnode.
(let ((btree-key< (btree-key< btree))
- (last (1- (btree-node-index-count node))))
+ (last (1- (bnode-nr-bindings node))))
(labels ((binary-search (start end)
- (let* ((mid (+ start (ash (- end start) -1))))
- (cond ((= start mid)
- (let ((start-binding (node-binding node start)))
- (if (funcall btree-key< (binding-key start-binding) key)
- (binding-value (node-binding node end))
- (binding-value start-binding))))
- (t
- (let ((mid-binding (node-binding node mid)))
- (if (funcall btree-key< (binding-key mid-binding) key)
- (binary-search mid end)
- (binary-search start mid))))))))
- (if (funcall btree-key< (binding-key (node-binding node (1- last))) key)
- (binding-value (node-binding node last))
+ (let ((mid (+ start (ash (- end start) -1))))
+ (if (= start mid)
+ (if (funcall btree-key< (node-binding-key node start) key)
+ (node-binding-value node end)
+ (node-binding-value node start))
+ (if (funcall btree-key< (node-binding-key node mid) key)
+ (binary-search mid end)
+ (binary-search start mid))))))
+ (if (funcall btree-key< (node-binding-key node (1- last)) key)
+ (node-binding-value node last)
(binary-search 0 last)))))
-(defun find-binding-in-node (key node btree)
+(defun find-key-in-node (btree node key)
+ "Tries to find a binding with the given key in a bnode. If it
+succeeds, it returns the binding (and, as a second value, the position
+of that binding). Otherwise it returns NIL."
(let ((btree-key< (btree-key< btree))
- (array (btree-node-index node))
- (index-count (btree-node-index-count node)))
+ (index-count (bnode-nr-bindings node)))
(labels ((binary-search (start end)
- (let* ((mid (+ start (ash (- end start) -1))))
- (cond ((= start mid)
- (let ((start-binding (p-aref array start)))
- (if (funcall btree-key< (binding-key start-binding) key)
- (when (< end index-count)
- (p-aref array end))
- start-binding)))
- (t (let ((mid-binding (p-aref array mid)))
- (if (funcall btree-key< (binding-key mid-binding) key)
- (binary-search mid end)
- (binary-search start mid))))))))
+ (let ((mid (+ start (ash (- end start) -1))))
+ (if (= start mid)
+ (let ((start-binding (node-binding node start)))
+ (if (funcall btree-key< (node-binding-key node start) key)
+ (when (< end index-count)
+ (values (node-binding node end) end))
+ (values start-binding start)))
+ (if (funcall btree-key< (node-binding-key node mid) key)
+ (binary-search mid end)
+ (binary-search start mid))))))
(when (plusp index-count)
- (let ((candidate (binary-search 0 index-count)))
+ (multiple-value-bind (candidate position)
+ (binary-search 0 index-count)
(when (and candidate
(funcall (btree-key= btree) (binding-key candidate) key))
- candidate))))))
+ (values candidate position)))))))
+
+(defun key-position (btree node key)
+ "Tries to find a binding with the given key in a bnode. If it
+succeeds, it returns the position of that binding. Otherwise, it
+returns NIL."
+ (nth-value 1 (find-key-in-node btree node key)))
+
+
+(defun find-value-in-node (btree node value &key (test (btree-value= btree)))
+ "Tries to find a binding with the given value in a bnode. If it
+succeeds, it returns the binding (and, as a second value, the position
+of that binding). Otherwise it returns NIL."
+ ;; The bindings aren't sorted by value, so we have to do
+ ;; a plain linear search.
+ (loop for i below (bnode-nr-bindings node)
+ when (funcall test (node-binding-value node i) value)
+ do (return-from find-value-in-node
+ (values (node-binding node i) i)))
+ ;; Not found: return nil.
[635 lines skipped]
--- /project/rucksack/cvsroot/rucksack/package.lisp 2008/01/23 15:43:42 1.12
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2008/02/11 12:47:52 1.13
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.12 2008/01/23 15:43:42 alemmens Exp $
+;; $Id: package.lisp,v 1.13 2008/02/11 12:47:52 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -35,7 +35,8 @@
#:p-car #:p-cdr #:p-list
#:unwrap-persistent-list
#:p-mapcar #:p-mapc #:p-maplist #:p-mapl
- #:p-member-if
+ #:p-member-if
+ #:p-pop #:p-push
#:p-make-array #:p-aref #:p-array-dimensions
#:p-length #:p-find #:p-replace #:p-delete-if #:p-position
@@ -65,9 +66,12 @@
#:rucksack-map-class-indexes #:rucksack-map-slot-indexes
#:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object
#:rucksack-map-class #:rucksack-map-slot
+ #:rucksack-do-class #:rucksack-do-slot
+ #:rucksack-delete-object
;; Transactions
#:current-transaction
+
#:transaction-start #:transaction-commit #:transaction-rollback
#:with-transaction #:*transaction*
#:transaction #:standard-transaction
--- /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/02/03 12:32:16 1.17
+++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2008/02/11 12:47:52 1.18
@@ -1,9 +1,9 @@
-;;; $Id: rucksack.asd,v 1.17 2008/02/03 12:32:16 alemmens Exp $
+;;; $Id: rucksack.asd,v 1.18 2008/02/11 12:47:52 alemmens Exp $
(in-package :cl-user)
(asdf:defsystem :rucksack
- :version "0.1.15"
+ :version "0.1.16"
:serial t
:components ((:file "queue")
(:file "package")
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2008/01/31 20:26:08 1.23
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2008/02/11 12:47:52 1.24
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.23 2008/01/31 20:26:08 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.24 2008/02/11 12:47:52 alemmens Exp $
(in-package :rucksack)
@@ -154,6 +154,22 @@
do more filtering before actually loading objects from disk.
INCLUDE-SUBCLASSES defaults to T."))
+(defmacro rucksack-do-class ((instance-var class
+ &key
+ (rucksack '*rucksack*)
+ id-only
+ (include-subclasses t))
+ &body body)
+ "Evaluate BODY for each instance of CLASS, with INSTANCE-VAR
+successively bound to each instance. See the documentation of
+RUCKSACK-MAP-CLASS for more details."
+ (check-type instance-var symbol)
+ `(rucksack-map-class ,rucksack ,class
+ (lambda (,instance-var) , at body)
+ :id-only ,id-only
+ :include-subclasses ,include-subclasses))
+
+
(defgeneric rucksack-map-slot (rucksack class slot function
&key equal min max include-min include-max order
include-subclasses)
@@ -170,6 +186,27 @@
do more filtering before actually loading objects from disk.
INCLUDE-SUBCLASSES defaults to T."))
+(defmacro rucksack-do-slot ((instance-var class slot
+ &key (rucksack '*rucksack*)
+ equal min max include-min include-max
+ order include-subclasses)
+ &body body)
+ "Evaluate BODY for each instance of CLASS where SLOT has the
+specified value. INSTANCE-VAR will be bound successively to each
+instance. See the documentation of RUCKSACK-MAP-SLOT for more
+details."
+ (check-type instance-var symbol)
+ `(rucksack-map-slot ,rucksack ,class ,slot
+ (lambda (,instance-var) , at body)
+ :equal ,equal
+ :min ,min
+ :max ,max
+ :include-min ,include-min
+ :include-max ,include-max
+ :order ,order
+ :include-subclasses ,include-subclasses))
+
+
#+later
(defgeneric rucksack-map-objects (rucksack class-designator function
@@ -369,7 +406,7 @@
(defmethod initialize-instance :after ((rucksack standard-rucksack)
&key
- (cache-class 'standard-cache)
+ (cache-class 'lazy-cache)
(cache-args '())
&allow-other-keys)
;; Open cache.
@@ -455,7 +492,7 @@
(class 'serial-transaction-rucksack)
(if-exists :overwrite)
(if-does-not-exist :create)
- (cache-class 'standard-cache)
+ (cache-class 'lazy-cache)
(cache-args '())
&allow-other-keys)
"Opens the rucksack in the directory designated by DIRECTORY-DESIGNATOR.
@@ -729,7 +766,7 @@
(simple-rucksack-error "Class index for ~S doesn't exist in ~A."
class
rucksack))))
- (btree-delete-key class
+ (btree-delete-key (class-index-table rucksack) class
:if-does-not-exist (if errorp :error :ignore))))
@@ -877,18 +914,20 @@
class object slot
old-value new-value
old-boundp new-boundp)
- (let ((index (rucksack-slot-index rucksack class slot
- :errorp nil
- :include-superclasses t)))
- (when index
- (when old-boundp
- (index-delete index old-value object
- :if-does-not-exist :ignore))
- (when new-boundp
- (index-insert index new-value object
- :if-exists (if (slot-unique slot)
- :error
- :overwrite))))))
+ ;; SLOT is a slot-definition, not a slot name.
+ (when (slot-index slot)
+ (let ((index (rucksack-slot-index rucksack class slot
+ :errorp nil
+ :include-superclasses t)))
+ (when index
+ (when old-boundp
+ (index-delete index old-value object
+ :if-does-not-exist :ignore))
+ (when new-boundp
+ (index-insert index new-value object
+ :if-exists (if (slot-unique slot)
+ :error
+ :overwrite)))))))
(defmethod rucksack-slot-index ((rucksack standard-rucksack) class slot
More information about the rucksack-cvs
mailing list