summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-07-20 10:27:38 +0200
committerLudovic Courtès <ludo@gnu.org>2010-07-21 00:28:58 +0200
commit927bf5e8cc0af9515797ebab6d9ba162bef23c2a (patch)
tree8cc1f6a0a541259ab873e76eaa1198b358463d64
parent442eaa681b0c2db4254d4903f8a0996b4ffc83d0 (diff)
downloadguile-927bf5e8cc0af9515797ebab6d9ba162bef23c2a.tar.gz
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.
-rw-r--r--doc/ref/api-compound.texi26
-rw-r--r--module/ice-9/vlist.scm61
-rw-r--r--test-suite/tests/vlist.test43
3 files changed, 123 insertions, 7 deletions
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 93d930f9a..bc8cb7fbd 100644
--- a/doc/ref/api-compound.texi
+++ b/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
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0c9297654..d72e6c108 100644
--- a/module/ice-9/vlist.scm
+++ b/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
-;; of calling the `eq?' subr.
+(define-inline (%vhash-fold* proc init key vhash equal? hash)
+ ;; 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))))
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index 47e386e82..f3e0989c1 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*"
+ (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)))))