[rucksack-cvs] CVS rucksack

[alemmens]

Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv13762

Modified Files:
	p-btrees.lisp rucksack.asd transactions.lisp 
Log Message:
When deleting a key from a btree, use the BTREE-KEY= function (not P-EQL) to determine
the position of the key.  Reported and fixed by Leonid Novikov.

--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp	2007/08/12 13:01:14	1.15
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp	2008/01/16 15:08:20	1.16
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.15 2007/08/12 13:01:14 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.16 2008/01/16 15:08:20 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -869,11 +869,11 @@
         (:ignore (return-from leaf-delete-key))
         (:error (error 'btree-search-error :btree btree :key key))))
 
-    (let* ((position (key-position key leaf))
+    (let* ((position (key-position key leaf (btree-key= btree)))
            (length (btree-node-index-count leaf))
            (was-biggest-key-p (= position (1- length))))
       
-      (remove-key leaf (binding-key binding))
+      (remove-key leaf (binding-key binding) (btree-key= btree))
       
       (unless (node-full-enough-p btree leaf)
         (enlarge-node btree leaf parent-stack))
@@ -915,7 +915,7 @@
   (when parent-stack
     (let ((node (first parent-stack)))
       (when node
-        (let ((position (key-position old-key node)))
+        (let ((position (key-position old-key node (btree-key= btree))))
           (when position
             (setf (binding-key (node-binding node position))
                   new-key)
@@ -978,7 +978,7 @@
                :start1 left-length
                :start2 0 :end2 right-length)
     ;; Remove key which pointed to LEFT-NODE.
-    (remove-key parent (binding-key left-binding))
+    (remove-key parent (binding-key left-binding) (btree-key= btree))
     ;; Make binding which pointed to RIGHT-NODE point to LEFT-NODE.
     (setf (binding-value right-binding) left-node)
     ;; Set new length of LEFT-NODE.
@@ -1002,8 +1002,8 @@
         do (setf (node-binding node i) nil))
   (setf (btree-node-index-count node) new-length))
 
-(defun remove-key (node key)
-  (let ((position (key-position key node))
+(defun remove-key (node key test)
+  (let ((position (key-position key node test))
         (length (btree-node-index-count node)))
     (unless (>= position (1- length))
       ;; Move bindings to the left.
@@ -1013,9 +1013,10 @@
                    :start2 (1+ position) :end2 length)))
     (shorten node (1- length))))
     
-(defun key-position (key node)
+(defun key-position (key node test)
   (p-position key (btree-node-index node)
               :key #'binding-key
+              :test test
               :end (btree-node-index-count node)))
 
 (defun node-full-enough-p (btree node)
--- /project/rucksack/cvsroot/rucksack/rucksack.asd	2007/08/12 13:01:14	1.11
+++ /project/rucksack/cvsroot/rucksack/rucksack.asd	2008/01/16 15:08:21	1.12
@@ -1,24 +1,23 @@
-;;; $Id: rucksack.asd,v 1.11 2007/08/12 13:01:14 alemmens Exp $
-
-(in-package :cl-user)
-
-(asdf:defsystem :rucksack
-  :version "0.1.9"
-  :serial t
-  :components ((:file "queue")
-               (:file "package")
-               (:file "errors")
-               (:file "mop")
-               (:file "serialize" )
-               (:file "heap")
-               (:file "object-table")
-               (:file "schema-table")
-               (:file "garbage-collector")
-               (:file "cache")
-               (:file "objects")
-               (:file "p-btrees")
-               (:file "index")
-               (:file "rucksack")
-               (:file "transactions")
-               (:file "test")))
-    
+;;; $Id: rucksack.asd,v 1.12 2008/01/16 15:08:21 alemmens Exp $
+
+(in-package :cl-user)
+
+(asdf:defsystem :rucksack
+  :version "0.1.9"
+  :serial t
+  :components ((:file "queue")
+               (:file "package")
+               (:file "errors")
+               (:file "mop")
+               (:file "serialize" )
+               (:file "heap")
+               (:file "object-table")
+               (:file "schema-table")
+               (:file "garbage-collector")
+               (:file "cache")
+               (:file "objects")
+               (:file "p-btrees")
+               (:file "index")
+               (:file "rucksack")
+               (:file "transactions")
+               (:file "test")))
--- /project/rucksack/cvsroot/rucksack/transactions.lisp	2007/01/20 18:17:55	1.13
+++ /project/rucksack/cvsroot/rucksack/transactions.lisp	2008/01/16 15:08:21	1.14
@@ -1,4 +1,4 @@
-;; $Id: transactions.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: transactions.lisp,v 1.14 2008/01/16 15:08:21 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -39,7 +39,7 @@
    (dirty-objects :initarg :dirty-objects
                   :initform (make-hash-table)
                   :reader dirty-objects
-                  :documentation "A hash-table (from id to object)
+                  :documentation "A hash-table \(from id to object)
 containing all objects of which the slot changes have not been written
 to disk yet.")
    (dirty-queue :initarg :dirty-queue
@@ -48,7 +48,7 @@
                 :documentation "A queue with the ids of all objects
 that have been created or modified since the last commit.  The queue
 is in least-recently-dirtied-first order.  During a commit, the
-objects are written to disk in the same order (this is necessary to
+objects are written to disk in the same order \(this is necessary to
 guarantee that the garbage collector never sees an id of an object
 that doesn't exist on disk yet.")))