[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Sun Aug 12 13:01:18 UTC 2007
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv13430
Modified Files:
do.txt done.txt index.lisp make.lisp p-btrees.lisp
rucksack.asd rucksack.lisp test.lisp
Log Message:
Fix btree bug during btree-delete: if we're deleting the biggest key
from a leaf, we should update the parents so they'll use the key that
has now become the biggest. (Henrik Hjelte.)
Try to signal an error when an incompatible value is given to indexed
slots, e.g. trying to put a string into a slot with a :symbol-index.
(Henrik Hjelte)
Signal an error during when putting duplicate values into a slot for
which duplicate values are not allowed. (Henrik Hjelte)
Use BTREE-VALUE-TYPE, not BTREE-KEY-TYPE, when type checking a value
during BTREE-INSERT. (Henrik Hjelte)
Wrap COMPILE-FILE calls in a WITH-COMPILATION-UNIT to prevent
superfluous warnings about undefined functions.
--- /project/rucksack/cvsroot/rucksack/do.txt 2007/01/22 10:23:14 1.6
+++ /project/rucksack/cvsroot/rucksack/do.txt 2007/08/12 13:01:13 1.7
@@ -1,13 +1,7 @@
DO:
-- There's still a btree bug that's detected (very rarely) by the
- stress test. Fix it.
-
- Make Rucksack crash proof. (Use a copying GC?)
-- Check that btrees actually signal an error for duplicate keys.
- Handle those errors correctly for slot indexes.
-
- Make sure that the GC gets rid of all obsolete object versions.
- Add export/import to s-expression format. This is necessary
--- /project/rucksack/cvsroot/rucksack/done.txt 2007/03/13 13:13:00 1.9
+++ /project/rucksack/cvsroot/rucksack/done.txt 2007/08/12 13:01:13 1.10
@@ -1,3 +1,23 @@
+* 2007-08-12 - version 0.1.9
+
+- Fix btree bug during btree-delete: if we're deleting the biggest key
+ from a leaf, we should update the parents so they'll use the key that
+ has now become the biggest. (Henrik Hjelte.)
+
+- Try to signal an error when an incompatible value is given to
+ indexed slots, e.g. trying to put a string into a slot with a
+ :symbol-index. (Henrik Hjelte)
+
+- Signal an error during when putting duplicate values into a slot for
+ which duplicate values are not allowed. (Henrik Hjelte)
+
+- Use BTREE-VALUE-TYPE, not BTREE-KEY-TYPE, when type checking a value
+ during BTREE-INSERT. (Henrik Hjelte)
+
+- Wrap COMPILE-FILE calls in a WITH-COMPILATION-UNIT to prevent
+ superfluous warnings about undefined functions.
+
+
* 2007-03-13 - version 0.1.8
- Fix a bug in LEAF-DELETE-KEY (thanks to Henrik Hjelte).
--- /project/rucksack/cvsroot/rucksack/index.lisp 2007/01/20 18:17:55 1.9
+++ /project/rucksack/cvsroot/rucksack/index.lisp 2007/08/12 13:01:13 1.10
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.9 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: index.lisp,v 1.10 2007/08/12 13:01:13 alemmens Exp $
(in-package :rucksack)
@@ -196,17 +196,18 @@
'(btree :key< < :value= p-eql))
(define-index-spec :string-index
- '(btree :key< string< :value p-eql))
+ '(btree :key< string< :value p-eql :key-type string))
(define-index-spec :symbol-index
- '(btree :key< string< :value p-eql))
+ '(btree :key< string< :value p-eql :key-type symbol))
(define-index-spec :case-insensitive-string-index
- '(btree :key< string-lessp :value p-eql))
+ '(btree :key< string-lessp :value p-eql :key-type string))
(define-index-spec :trimmed-string-index
;; Like :STRING-INDEX, but with whitespace trimmed left
;; and right.
'(btree :key< string<
:key-key trim-whitespace
- :value p-eql)))
+ :value p-eql
+ :key-type string)))
--- /project/rucksack/cvsroot/rucksack/make.lisp 2007/01/20 18:17:55 1.6
+++ /project/rucksack/cvsroot/rucksack/make.lisp 2007/08/12 13:01:13 1.7
@@ -1,4 +1,5 @@
-;; $Id: make.lisp,v 1.6 2007/01/20 18:17:55 alemmens Exp $
+
+;; $Id: make.lisp,v 1.7 2007/08/12 13:01:13 alemmens Exp $
(in-package :cl-user)
@@ -8,37 +9,38 @@
(defun make (&key (debug t))
(when debug
(proclaim '(optimize (debug 3) (speed 0) (space 0))))
- (loop for file in '("queue"
- "package"
- "errors"
- "mop"
- "serialize"
- "heap"
- "object-table"
- "schema-table"
- "garbage-collector"
- "cache"
- "objects"
- "p-btrees"
- "index"
- "rucksack"
- "transactions"
- "test")
- do (tagbody
- :retry
- (let ((lisp (make-pathname :name file
- :type "lisp"
- :defaults *rucksack-directory*)))
- (multiple-value-bind (fasl warnings failure)
- (compile-file lisp)
- (declare (ignore warnings))
- (when failure
- (restart-case
- (error "COMPILE-FILE reported failure on ~A" lisp)
- (retry ()
- :report "Retry compilation"
- (go :retry))
- (continue ()
- :report "Load resulting fasl anyway"
- nil)))
- (load fasl))))))
+ (with-compilation-unit ()
+ (loop for file in '("queue"
+ "package"
+ "errors"
+ "mop"
+ "serialize"
+ "heap"
+ "object-table"
+ "schema-table"
+ "garbage-collector"
+ "cache"
+ "objects"
+ "p-btrees"
+ "index"
+ "rucksack"
+ "transactions"
+ "test")
+ do (tagbody
+ :retry
+ (let ((lisp (make-pathname :name file
+ :type "lisp"
+ :defaults *rucksack-directory*)))
+ (multiple-value-bind (fasl warnings failure)
+ (compile-file lisp)
+ (declare (ignore warnings))
+ (when failure
+ (restart-case
+ (error "COMPILE-FILE reported failure on ~A" lisp)
+ (retry ()
+ :report "Retry compilation"
+ (go :retry))
+ (continue ()
+ :report "Load resulting fasl anyway"
+ nil)))
+ (load fasl)))))))
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/03/13 13:13:00 1.14
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/08/12 13:01:14 1.15
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.14 2007/03/13 13:13:00 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.15 2007/08/12 13:01:14 alemmens Exp $
(in-package :rucksack)
@@ -538,6 +538,61 @@
candidate))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Debugging
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun check-btree (btree)
+ ;; Check that it is completely sorted.
+ (let (prev-key)
+ (map-btree-keys btree
+ (lambda (key value)
+ (declare (ignore value))
+ (when prev-key
+ (unless (funcall (btree-key< btree) prev-key key)
+ (pprint (btree-as-cons btree))
+ (error "Btree inconsistency between ~D and ~D" prev-key key)))
+ (setq prev-key key))))
+ ;; Check that it is balanced
+ (unless (btree-balanced-p btree)
+ (error "Btree ~S is not balanced." btree)))
+
+(defun check-bnode-keys (tree node)
+ "Check a btree node (and its descendants) for consistency. This is only used
+for debugging."
+ (car
+ (last
+ (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
+ (if leaf-p
+ (if (btree-unique-keys-p tree)
+ (binding-key binding)
+ (binding-key (node-binding node
+ i)))
+ (progn
+ (let ((x (check-bnode-keys tree
+ (binding-value binding))))
+ (when x
+ (unless (or (eq x 'key-irrelevant)
+ (eq (binding-key binding) 'key-irrelevant))
+ (unless (funcall (btree-key= tree)
+ (funcall (btree-key-key tree)
+ (binding-key binding))
+ (funcall (btree-key-key tree)
+ x))
+ (print "Found error")
+ (describe (binding-key binding))
+ (describe x)
+ (pprint (btree-as-cons tree))
+ (error "Inconsistent bnode key at ~a binding ~a binding-key ~a val ~a X ~a"
+ node binding (binding-key binding)
+ (binding-value binding) x)))))
+ (binding-key binding)))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Insert
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -548,7 +603,7 @@
:btree btree
:datum key
:expected-type (btree-key-type btree)))
- (unless (typep value (btree-key-type btree))
+ (unless (typep value (btree-value-type btree))
(error 'btree-type-error
:btree btree
:datum value
@@ -569,21 +624,6 @@
;; Return the inserted value.
value)
-(defun check-btree (btree)
- ;; Check that it is completely sorted.
- (let (prev-key)
- (map-btree-keys btree
- (lambda (key value)
- (declare (ignore value))
- (when prev-key
- (unless (funcall (btree-key< btree) prev-key key)
- (pprint (btree-as-cons btree))
- (error "Btree inconsistency between ~D and ~D" prev-key key)))
- (setq prev-key key))))
- ;; Check that it is balanced
- (unless (btree-balanced-p btree)
- (error "Btree ~S is not balanced." btree)))
-
(defun make-root (btree left-key left-subnode right-key right-subnode)
(let* ((root (make-instance (btree-node-class btree) :btree btree)))
@@ -828,9 +868,20 @@
(ecase if-does-not-exist
(:ignore (return-from leaf-delete-key))
(:error (error 'btree-search-error :btree btree :key key))))
- (remove-key leaf (binding-key binding))
- (unless (node-full-enough-p btree leaf)
- (enlarge-node btree leaf parent-stack))))
+
+ (let* ((position (key-position key leaf))
+ (length (btree-node-index-count leaf))
+ (was-biggest-key-p (= position (1- length))))
+
+ (remove-key leaf (binding-key binding))
+
+ (unless (node-full-enough-p btree leaf)
+ (enlarge-node btree leaf parent-stack))
+
+ (when was-biggest-key-p
+ (unless (= 0 (btree-node-index-count leaf))
+ (update-parents-for-deleted-key btree parent-stack key (biggest-key leaf)))))))
+
(defun enlarge-node (btree node parent-stack)
;; NODE is not full enough (less than half full), so we redistribute
@@ -859,6 +910,17 @@
(return-from enlarge-node))))
(error "This should not happen."))
+
+(defun update-parents-for-deleted-key (btree parent-stack old-key new-key)
+ (when parent-stack
+ (let ((node (first parent-stack)))
+ (when node
+ (let ((position (key-position old-key node)))
+ (when position
+ (setf (binding-key (node-binding node position))
+ new-key)
+ (update-parents-for-deleted-key btree (rest parent-stack) old-key new-key)))))))
+
;; The idea is that DISTRIBUTE-ELEMENTS will only be called if the union of
;; the two nodes has enough elements for two "legal" nodes. JOIN-NODES,
--- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/03/13 13:13:00 1.10
+++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/08/12 13:01:14 1.11
@@ -1,9 +1,9 @@
-;;; $Id: rucksack.asd,v 1.10 2007/03/13 13:13:00 alemmens Exp $
+;;; $Id: rucksack.asd,v 1.11 2007/08/12 13:01:14 alemmens Exp $
(in-package :cl-user)
(asdf:defsystem :rucksack
- :version "0.1.8"
+ :version "0.1.9"
:serial t
:components ((:file "queue")
(:file "package")
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/03/13 13:13:00 1.20
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/08/12 13:01:14 1.21
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.20 2007/03/13 13:13:00 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.21 2007/08/12 13:01:14 alemmens Exp $
(in-package :rucksack)
@@ -874,9 +874,13 @@
(when index
(let ((id (object-id object)))
(when old-boundp
- (index-delete index old-value id :if-does-not-exist :ignore))
+ (index-delete index old-value id
+ :if-does-not-exist :ignore))
(when new-boundp
- (index-insert index new-value id))))))
+ (index-insert index new-value id
+ :if-exists (if (slot-unique slot)
+ :error
+ :overwrite)))))))
(defmethod rucksack-slot-index ((rucksack standard-rucksack) class slot
--- /project/rucksack/cvsroot/rucksack/test.lisp 2007/01/20 18:17:55 1.14
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2007/08/12 13:01:14 1.15
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.14 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: test.lisp,v 1.15 2007/08/12 13:01:14 alemmens Exp $
(in-package :rucksack-test)
@@ -207,7 +207,9 @@
(defun check-order (btree)
(format t "~&Checking order and balance~%")
- (rs::check-btree btree))
+ (rs::check-btree btree)
+ (format t " and keys~%")
+ (rs::check-bnode-keys btree (rs::btree-root btree)))
(defun check-contents (btree)
(format t "~&Checking contents~%")
More information about the rucksack-cvs
mailing list