From alemmens at common-lisp.net Tue Mar 13 13:13:00 2007 From: alemmens at common-lisp.net (alemmens) Date: Tue, 13 Mar 2007 08:13:00 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070313131300.05EAA32032@common-lisp.net> 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))) + +