Changing the signature of ‘vhash-assoc’

[Ludovic Courtès]

Hello,

I wanted to access all the values associated with a key in a “vhash”.
To do that, I started implementing ‘vhash-fold-matches’ (attached), with
the vague feeling of piling feature on top of feature.

Indeed, if ‘vhash-assoc’ et al. are changed to return a vhash instead of
a pair, then we have all that’s needed to do that:

  (define (vhash-fold-matches proc init key vh)
    (let loop ((vh     vh)
               (result init))
      (let ((match (vhash-assoc key vh)))
        (if (vlist-null? match)
            result
            (loop (vlist-tail match)
                  (vlist-head match))))))

Thus I’m planning to make that change.  [The ‘vhash-fold-matches’ above
conses at each match whereas the attached one doesn’t, but that’s OK.]

However, it’s an incompatible change.  Instead of writing:

  (define first-value (and=> (vhash-assoc key vh) cdr))

one will have to write:

  (define first-value
    (let ((match (vhash-assoc key vh)))
      (if (vlist-null? match)
          #f
          (vlist-head match))))

Comments?  Objections?

Thanks,
Ludo’.

pgpuX_6cx6tg4.pgp
Description: PGP signature

diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0c92976..4b32302 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -30,6 +30,7 @@
             block-growth-factor
 
             vhash? vhash-cons vhash-consq vhash-consv
+            vhash-fold-matches
             vhash-assoc vhash-assq vhash-assv
             vhash-delete vhash-fold alist->vhash))
 
@@ -408,8 +409,48 @@ with @var{value}.  Use @var{hash} to compute @var{key}'s 
hash."
 (define vhash-consq (cut vhash-cons <> <> <> hashq))
 (define vhash-consv (cut vhash-cons <> <> <> hashv))
 
-;; This hack to make sure `vhash-assq' gets to use the `eq?' instruction 
instead
-;; of calling the `eq?' subr.
+(define* (vhash-fold-matches proc init key vhash
+                             #:optional (equal? equal?) (hash hash))
+  "Fold over all the values associated with KEY in VHASH, with each call to 
PROC
+having the form `(PROC VALUE RESULT)', where RESULT is the result of the
+previous call to PROC and INIT the value of RESULT for the first call to PROC."
+  (define khash
+    (let ((size (block-size (vlist-base vhash))))
+      (and (> size 0) (hash key size))))
+
+  (let loop ((base       (vlist-base vhash))
+             (khash      khash)
+             (offset     (and khash
+                              (block-hash-table-ref (vlist-base vhash)
+                                                    khash)))
+             (max-offset (vlist-offset vhash))
+             (result     init))
+
+    (let ((answer (and offset (block-ref base offset))))
+      (cond ((and (pair? answer)
+                  (<= offset max-offset)
+                  (let ((answer-key (caar answer)))
+                    (equal? key answer-key)))
+             (let ((result      (proc (cdar answer) result))
+                   (next-offset (cdr answer)))
+               (loop base khash next-offset max-offset result)))
+            ((and (pair? answer) (cdr answer))
+             =>
+             (lambda (next-offset)
+               (loop base khash next-offset max-offset result)))
+            (else
+             (let ((next-base (block-base base)))
+               (if (and next-base (> (block-size next-base) 0))
+                   (let* ((khash  (hash key (block-size next-base)))
+                          (offset (block-hash-table-ref next-base khash)))
+                     (loop next-base khash offset (block-offset base)
+                           result))
+                   result)))))))
+
+;; A specialization of `vhash-fold-matches' that stops when the first value
+;; associated with KEY is found or when the end-of-list is reached.  Inline to
+;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling
+;; the `eq?' subr.
 (define-inline (%vhash-assoc key vhash equal? hash)
   (define khash
     (let ((size (block-size (vlist-base vhash))))
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index 47e386e..94ae1f4 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -19,9 +19,10 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
 
 (define-module (test-vlist)
-  :use-module (test-suite lib)
-  :use-module (ice-9 vlist)
-  :use-module (srfi srfi-1))
+  #:use-module (test-suite lib)
+  #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26))
 
 
 ;;;
@@ -300,4 +301,38 @@
                         (equal? (assq k alist)
                                 (vhash-assoc k vh eq?))))
                  #t
-                 keys)))))
+                 keys))))
+
+  (pass-if "vhash-fold-matches"
+    (let* ((keys   (make-list 10 'a))
+           (values (iota 10))
+           (vh     (fold vhash-cons vlist-null keys values)))
+      (equal? (vhash-fold-matches cons '() 'a vh)
+              values)))
+
+  (pass-if "vhash-fold-matches tail"
+    (let* ((keys   (make-list 100 'a))
+           (values (iota 100))
+           (vh     (fold vhash-cons vlist-null keys values)))
+      (equal? (vhash-fold-matches cons '() 'a (vlist-drop vh 42))
+              (take values (- 100 42)))))
+
+  (pass-if "vhash-fold-matches interleaved"
+    (let* ((keys   '(a b a b a b a b a b c d e a b))
+           (values '(1 0 2 0 3 0 4 0 5 0 0 0 0 6 0))
+           (vh     (fold vhash-cons vlist-null keys values)))
+      (equal? (vhash-fold-matches cons '() 'a vh)
+              (filter (cut > <> 0) values))))
+
+  (pass-if "vhash-fold-matches degenerate"
+    (let* ((keys   '(a b a b a a a b a b a a a z))
+           (values '(1 0 2 0 3 4 5 0 6 0 7 8 9 0))
+           (vh     (fold (lambda (k v vh)
+                           ;; Degenerate case where VH2 contains only
+                           ;; 1-element blocks.
+                           (let* ((vh1 (vhash-cons 'x 'x vh))
+                                  (vh2 (vlist-tail vh1)))
+                             (vhash-cons k v vh2)))
+                         vlist-null keys values)))
+      (equal? (vhash-fold-matches cons '() 'a vh)
+              (filter (cut > <> 0) values)))))