From alemmens at common-lisp.net  Thu Nov 30 10:45:35 2006
From: alemmens at common-lisp.net (alemmens)
Date: Thu, 30 Nov 2006 05:45:35 -0500 (EST)
Subject: [rucksack-cvs] CVS rucksack
Message-ID: <20061130104535.1442733003@common-lisp.net>

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

Modified Files:
	done.txt index.lisp rucksack.lisp 
Log Message:
FLET MAP-INDEX should be LABELS MAP-INDEXES (thanks Cyrus Harmon).

The :EQUAL parameter for MAP-INDEX-DATA wasn't handled correctly
for indexes with non-unique keys (reported by Cyrus Harmon).


--- /project/rucksack/cvsroot/rucksack/done.txt	2006/09/04 12:34:34	1.5
+++ /project/rucksack/cvsroot/rucksack/done.txt	2006/11/30 10:45:34	1.6
@@ -1,3 +1,11 @@
+* 2006-11-30
+
+- FLET MAP-INDEXES should be LABELS MAP-INDEXES (thanks to Cyrus Harmon)
+
+- The :EQUAL parameter for MAP-INDEX-DATA wasn't handled correctly
+  for indexes with non-unique keys (reported by Cyrus Harmon).
+
+
 * 2006-09-04
 
 - Take care of some differences between the MOP implementations of Lispworks
--- /project/rucksack/cvsroot/rucksack/index.lisp	2006/08/31 15:47:58	1.7
+++ /project/rucksack/cvsroot/rucksack/index.lisp	2006/11/30 10:45:34	1.8
@@ -1,4 +1,4 @@
-;; $Id: index.lisp,v 1.7 2006/08/31 15:47:58 alemmens Exp $
+;; $Id: index.lisp,v 1.8 2006/11/30 10:45:34 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -99,7 +99,13 @@
   (if equal-supplied
       (let ((value (btree-search index equal :errorp nil :default-value index)))
         (unless (p-eql value index)
-          (funcall function equal value)))
+          (if (btree-unique-keys-p index)
+              ;; We have a single value: call FUNCTION directly.
+              (funcall function equal value)
+            ;; We have a persistent list of values: call FUNCTION for
+            ;; each element of that list.
+            (p-mapc (lambda (elt) (funcall function equal elt))
+                    value))))
     (apply #'map-btree index function :order order args)))
 
 
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp	2006/08/31 20:09:18	1.16
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp	2006/11/30 10:45:34	1.17
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.16 2006/08/31 20:09:18 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.17 2006/11/30 10:45:34 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -826,21 +826,21 @@
                               (lambda (slot slot-index)
                                 (funcall function class slot slot-index)))))
     (let ((visited-p (make-hash-table)))
-      (flet ((map-indexes (class)
-               (unless (gethash class visited-p)
-                 (let ((slot-index-table (btree-search (slot-index-tables rucksack)
-                                                       (class-name class)
-                                                       :errorp nil)))
-                   (when slot-index-table
-                     (map-btree slot-index-table
-                                (lambda (slot slot-index)
-                                  (funcall function (class-name class)
-                                           slot
-                                           slot-index)))))
-                 (setf (gethash class visited-p) t)
-                 (when include-subclasses
-                   (mapc #'map-indexes
-                         (class-direct-subclasses class))))))
+      (labels ((map-indexes (class)
+                 (unless (gethash class visited-p)
+                   (let ((slot-index-table (btree-search (slot-index-tables rucksack)
+                                                         (class-name class)
+                                                         :errorp nil)))
+                     (when slot-index-table
+                       (map-btree slot-index-table
+                                  (lambda (slot slot-index)
+                                    (funcall function (class-name class)
+                                             slot
+                                             slot-index)))))
+                   (setf (gethash class visited-p) t)
+                   (when include-subclasses
+                     (mapc #'map-indexes
+                           (class-direct-subclasses class))))))
         (map-indexes (if (symbolp class) (find-class class) class))))))