Add vhash-fold*' in (ice-9 vlist)'.

* module/ice-9/vlist.scm (%vhash-fold*): New inline procedure.
  (vhash-fold*, vhash-foldq*, vhash-foldv*): New procedures.

* test-suite/tests/vlist.test ("vhash")["vhash-fold*", "vhash-fold*
  tail", "vhash-fold* interleaved", "vhash-foldq* degenerate"]: New
  tests.

* doc/ref/api-compound.texi (VHashes): Add `vhash-fold*' & co.

doc/ref/api-compound.texi

@@ -3300,6 +3300,32 @@ Fold over the key/pair elements of @var{vhash}.  For each pair call @var{proc}
 as @code{(@var{proc} key value result)}.
 @end deffn
 
+@deffn {Scheme Procedure} vhash-fold* proc init key vhash [equal? [hash]]
+@deffnx {Scheme Procedure} vhash-foldq* proc init key vhash
+@deffnx {Scheme Procedure} vhash-foldv* proc init key vhash
+Fold over all the values associated with @var{key} in @var{vhash}, with each
+call to @var{proc} having the form @code{(proc value result)}, where
+@var{result} is the result of the previous call to @var{proc} and @var{init} the
+value of @var{result} for the first call to @var{proc}.
+
+Keys in @var{vhash} are hashed using @var{hash} are compared using @var{equal?}.
+The second form uses @code{eq?} as the equality predicate and @code{hashq} as
+the hash function; the third one uses @code{eqv?} and @code{hashv}.
+
+Example:
+
+@example
+(define vh
+  (alist->vhash '((a . 1) (a . 2) (z . 0) (a . 3))))
+
+(vhash-fold* cons '() 'a vh)
+@result{} (3 2 1)
+
+(vhash-fold* cons '() 'z vh)
+@result{} (0)
+@end example
+@end deffn
+
 @deffn {Scheme Procedure} alist->vhash alist [hash-proc]
 Return the vhash corresponding to @var{alist}, an association list, using
 @var{hash-proc} to compute key hashes.  When omitted, @var{hash-proc} defaults

module/ice-9/vlist.scm

@@ -31,7 +31,9 @@
 
             vhash? vhash-cons vhash-consq vhash-consv
             vhash-assoc vhash-assq vhash-assv
-            vhash-delete vhash-fold alist->vhash))
+            vhash-delete vhash-fold
+            vhash-fold* vhash-foldq* vhash-foldv*
+            alist->vhash))
 
 ;;; Author: Ludovic Courtès <ludo@gnu.org>
 ;;;
@@ -408,9 +410,62 @@ 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
+(define-inline (%vhash-fold* proc init key vhash equal? hash)
-;; of calling the `eq?' subr.
+  ;; Fold over all the values associated with KEY in VHASH.
+  (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)))))))
+
+(define* (vhash-fold* proc init key vhash
+                      #:optional (equal? equal?) (hash hash))
+  "Fold over all the values associated with @var{key} in @var{vhash}, with each
+call to @var{proc} having the form @code{(proc value result)}, where
+@var{result} is the result of the previous call to @var{proc} and @var{init} the
+value of @var{result} for the first call to @var{proc}."
+  (%vhash-fold* proc init key vhash equal? hash))
+
+(define (vhash-foldq* proc init key vhash)
+  "Same as @code{vhash-fold*}, but using @code{hashq} and @code{eq?}."
+  (%vhash-fold* proc init key vhash eq? hashq))
+
+(define (vhash-foldv* proc init key vhash)
+  "Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
+  (%vhash-fold* proc init key vhash eqv? hashv))
+
 (define-inline (%vhash-assoc key vhash equal? hash)
+  ;; A specialization of `vhash-fold*' 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 khash
     (let ((size (block-size (vlist-base vhash))))
       (and (> size 0) (hash key size))))

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 (test-suite lib)
-  :use-module (ice-9 vlist)
+  #:use-module (ice-9 vlist)
-  :use-module (srfi srfi-1))
+  #: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*"
+    (let* ((keys   (make-list 10 'a))
+           (values (iota 10))
+           (vh     (fold vhash-cons vlist-null keys values)))
+      (equal? (vhash-fold* cons '() 'a vh)
+              values)))
+
+  (pass-if "vhash-fold* tail"
+    (let* ((keys   (make-list 100 'a))
+           (values (iota 100))
+           (vh     (fold vhash-cons vlist-null keys values)))
+      (equal? (vhash-fold* cons '() 'a (vlist-drop vh 42))
+              (take values (- 100 42)))))
+
+  (pass-if "vhash-fold* 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* cons '() 'a vh)
+              (filter (cut > <> 0) values))))
+
+  (pass-if "vhash-foldq* 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-consq 'x 'x vh))
+                                  (vh2 (vlist-tail vh1)))
+                             (vhash-consq k v vh2)))
+                         vlist-null keys values)))
+      (equal? (vhash-foldq* cons '() 'a vh)
+              (filter (cut > <> 0) values)))))