diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-07-20 10:27:38 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-07-21 00:28:58 +0200 |
commit | 927bf5e8cc0af9515797ebab6d9ba162bef23c2a (patch) | |
tree | 8cc1f6a0a541259ab873e76eaa1198b358463d64 | |
parent | 442eaa681b0c2db4254d4903f8a0996b4ffc83d0 (diff) | |
download | guile-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.texi | 26 | ||||
-rw-r--r-- | module/ice-9/vlist.scm | 61 | ||||
-rw-r--r-- | test-suite/tests/vlist.test | 43 |
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))))) |