[Guile-commits] 03/09: Add intmap-fold.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit b7668bd9498ec93cbb1ddb5f57b6e2bf05faabda
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 1 10:45:31 2015 +0200

    Add intmap-fold.
    
    * module/language/cps/intmap.scm (intmap-fold): New function.
---
 module/language/cps/intmap.scm |   28 ++++++++++++++++++++++++++++
 1 files changed, 28 insertions(+), 0 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index abaf459..467a63d 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -40,6 +40,7 @@
             intmap-ref
             intmap-next
             intmap-prev
+            intmap-fold
             intmap-union
             intmap-intersect))
 
@@ -233,6 +234,33 @@
             (let ((i (visit-node root shift i)))
               (and i (+ min i))))))))
 
+(define (intmap-fold f map seed)
+  (define (visit-branch node shift min seed)
+    (let ((shift (- shift *branch-bits*)))
+      (if (zero? shift)
+          (let lp ((i 0) (seed seed))
+            (if (< i *branch-size*)
+                (let ((elt (vector-ref node i)))
+                  (lp (1+ i)
+                      (if elt
+                          (f (+ i min) elt seed)
+                          seed)))
+                seed))
+          (let lp ((i 0) (seed seed))
+            (if (< i *branch-size*)
+                (let ((elt (vector-ref node i)))
+                  (lp (1+ i)
+                      (if elt
+                          (visit-branch elt shift (+ min (ash i shift)) seed)
+                          seed)))
+                seed)))))
+  (match map
+    (($ <intmap> min shift root)
+     (cond
+      ((not root) seed)
+      ((zero? shift) (f min root seed))
+      (else (visit-branch root shift min seed))))))
+
 (define* (intmap-union a b #:optional (meet meet-error))
   ;; Union A and B from index I; the result will be fresh.
   (define (union-branches/fresh shift a b i fresh)