[rucksack-cvs] CVS rucksack

[alemmens]

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

Modified Files:
	done.txt heap.lisp p-btrees.lisp rucksack.asd rucksack.lisp 
Log Message:
Fix a bug in LEAF-DELETE-KEY (thanks to Henrik Hjelte).

Add RUCKSACK-DELETE-OBJECT, RUCKSACK-DELETE-OBJECTS and
RUCKSACK-ROOT-P (suggested by Henrik Hjelte).  I haven't
tested these functions yet.


--- /project/rucksack/cvsroot/rucksack/done.txt	2007/01/22 10:55:45	1.8
+++ /project/rucksack/cvsroot/rucksack/done.txt	2007/03/13 13:13:00	1.9
@@ -1,3 +1,12 @@
+* 2007-03-13 - version 0.1.8
+
+- Fix a bug in LEAF-DELETE-KEY (thanks to Henrik Hjelte).
+
+- Add RUCKSACK-DELETE-OBJECT, RUCKSACK-DELETE-OBJECTS and
+  RUCKSACK-ROOT-P (suggested by Henrik Hjelte).  I haven't
+  tested these functions yet.
+
+
 * 2007-01-22 - version 0.1.7
 
 - Get rid of two SBCL compiler warnings. (Reported by Cyrus Harmon.)
--- /project/rucksack/cvsroot/rucksack/heap.lisp	2007/01/22 10:55:46	1.14
+++ /project/rucksack/cvsroot/rucksack/heap.lisp	2007/03/13 13:13:00	1.15
@@ -1,4 +1,4 @@
-;; $Id: heap.lisp,v 1.14 2007/01/22 10:55:46 alemmens Exp $
+;; $Id: heap.lisp,v 1.15 2007/03/13 13:13:00 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -81,7 +81,8 @@
                       :element-type '(unsigned-byte 8)
                       :direction :io
                       :if-exists if-exists
-                      :if-does-not-exist if-does-not-exist)))
+                      :if-does-not-exist if-does-not-exist
+                      #+openmcl :sharing #+openmcl :external)))
     (apply #'make-instance
            class
            :stream stream
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp	2007/01/20 18:17:55	1.13
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp	2007/03/13 13:13:00	1.14
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.14 2007/03/13 13:13:00 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -828,7 +828,7 @@
       (ecase if-does-not-exist
         (:ignore (return-from leaf-delete-key))
         (:error (error 'btree-search-error :btree btree :key key))))
-    (remove-key leaf key)
+    (remove-key leaf (binding-key binding))
     (unless (node-full-enough-p btree leaf)
       (enlarge-node btree leaf parent-stack))))
 
--- /project/rucksack/cvsroot/rucksack/rucksack.asd	2007/01/22 10:55:46	1.9
+++ /project/rucksack/cvsroot/rucksack/rucksack.asd	2007/03/13 13:13:00	1.10
@@ -1,9 +1,9 @@
-;;; $Id: rucksack.asd,v 1.9 2007/01/22 10:55:46 alemmens Exp $
+;;; $Id: rucksack.asd,v 1.10 2007/03/13 13:13:00 alemmens Exp $
 
 (in-package :cl-user)
 
 (asdf:defsystem :rucksack
-  :version "0.1.7"
+  :version "0.1.8"
   :serial t
   :components ((:file "queue")
                (:file "package")
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp	2007/01/20 18:17:55	1.19
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp	2007/03/13 13:13:00	1.20
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.19 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.20 2007/03/13 13:13:00 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -31,6 +31,10 @@
  "Returns a list with all objects in the root set of a rucksack.  You
 shouldn't modify this list."))
 
+(defgeneric rucksack-root-p (object rucksack)
+  (:documentation
+   "Returns true iff OBJECT is a member of the root set of a rucksack."))
+
 (defgeneric rucksack-cache (rucksack)
   (:documentation "Returns the cache for a rucksack."))
 
@@ -180,6 +184,13 @@
 "))
 
 
+(defgeneric rucksack-delete-object (rucksack object)
+  (:documentation
+   "Removes OBJECT from RUCKSACK, i.e. removes object from the
+rucksack roots (if it is a root) and from all class and slot indexes
+in which it appears."))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Locks
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -422,6 +433,10 @@
     ;; We don't need to nreverse the list, because the order isn't specified.
     result))
 
+(defmethod rucksack-root-p (object (rucksack standard-rucksack))
+  (member (object-id object)
+          (slot-value rucksack 'roots)))
+
 ;;
 ;; Opening
 ;;
@@ -961,4 +976,33 @@
 
 
                        
-                                         
\ No newline at end of file
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Deleting objects
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod rucksack-delete-object ((rucksack standard-rucksack) object)
+  (let ((object-id (object-id object))
+        (class-name (class-name (class-of object))))
+    ;; Remove object from class index if necessary.
+    (let ((class-index (rucksack-class-index rucksack (class-of object)
+                                             :errorp nil)))
+      (when class-index
+        (index-delete class-index object-id object-id)))
+    ;; Remove object from slot indexes if necessary.
+    (let ((indexed-slot-names (rucksack-indexed-slots-for-class rucksack
+                                                                (class-of object))))
+      (loop for slot-name in indexed-slot-names do
+            (index-delete (rucksack-slot-index rucksack class-name slot-name)
+                          (slot-value object slot-name)
+                          object-id
+                          :if-does-not-exist :ignore)))
+    ;; Remove object from roots if necessary.
+    (when (rucksack-root-p object rucksack)
+      (delete-rucksack-root object rucksack))))
+
+
+(defun rucksack-delete-objects (rucksack objects)
+  (dolist (object objects)
+    (rucksack-delete-object rucksack object)))
+
+