X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/856d318a9f543d8a61fcf61caae7d07102586802..cf512e32687b41690ab436f13322d7a9e00094b7:/module/language/cps/intmap.scm

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 152985a06..948d0baba 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -1,5 +1,5 @@
 ;;; Functional name maps
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -39,6 +39,8 @@
             intmap-remove
             intmap-ref
             intmap-next
+            intmap-prev
+            intmap-fold
             intmap-union
             intmap-intersect))
 
@@ -47,7 +49,7 @@
 (define-syntax-rule (define-inline name val)
   (define-syntax name (identifier-syntax val)))
 
-(define-inline *branch-bits* 4)
+(define-inline *branch-bits* 5)
 (define-inline *branch-size* (ash 1 *branch-bits*))
 (define-inline *branch-mask* (1- *branch-size*))
 
@@ -102,7 +104,10 @@
          ;; Shouldn't be reached...
          (else empty-intmap)))))
 
-(define (intmap-add bs i val meet)
+(define (meet-error old new)
+  (error "Multiple differing values and no meet procedure defined" old new))
+
+(define* (intmap-add bs i val #:optional (meet meet-error))
   (define (adjoin i shift root)
     (cond
      ((zero? shift)
@@ -175,18 +180,20 @@
 (define (intmap-ref bs i)
   (match bs
     (($ <intmap> min shift root)
-     (and (<= min i) (< i (+ min (ash 1 shift)))
-          (let ((i (- i min)))
-            (let lp ((node root) (shift shift))
-              (and node
-                   (if (= shift *branch-bits*)
-                       (vector-ref node (logand i *branch-mask*))
-                       (let* ((shift (- shift *branch-bits*))
-                              (idx (logand (ash i (- shift))
-                                           *branch-mask*)))
-                         (lp (vector-ref node idx) shift))))))))))
+     (if (zero? shift)
+         (and (= i min) root)
+         (and (<= min i) (< i (+ min (ash 1 shift)))
+              (let ((i (- i min)))
+                (let lp ((node root) (shift shift))
+                  (and node
+                       (if (= shift *branch-bits*)
+                           (vector-ref node (logand i *branch-mask*))
+                           (let* ((shift (- shift *branch-bits*))
+                                  (idx (logand (ash i (- shift))
+                                               *branch-mask*)))
+                             (lp (vector-ref node idx) shift)))))))))))
 
-(define (intmap-next bs i)
+(define* (intmap-next bs #:optional i)
   (define (visit-branch node shift i)
     (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
       (and (< idx *branch-size*)
@@ -207,7 +214,54 @@
             (let ((i (visit-node root shift i)))
               (and i (+ min i))))))))
 
-(define (intmap-union a b meet)
+(define* (intmap-prev bs #:optional i)
+  (define (visit-branch node shift i)
+    (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+      (and (<= 0 idx)
+           (or (visit-node (vector-ref node idx) shift i)
+               (lp (1- (round-down i shift)) (1- idx))))))
+  (define (visit-node node shift i)
+    (and node
+         (if (zero? shift)
+             i
+             (visit-branch node (- shift *branch-bits*) i))))
+  (match bs
+    (($ <intmap> min shift root)
+     (let* ((i (if (and i (< i (+ min (ash 1 shift))))
+                   (- i min)
+                   (1- (ash 1 shift)))))
+       (and (<= 0 i)
+            (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)
     (let lp ((i 0))
@@ -286,7 +340,7 @@
           ((eq? root b-root) b)
           (else (make-intmap a-min a-shift root)))))))))
 
-(define (intmap-intersect a b meet)
+(define* (intmap-intersect a b #:optional (meet meet-error))
   ;; Intersect A and B from index I; the result will be fresh.
   (define (intersect-branches/fresh shift a b i fresh)
     (let lp ((i 0))