[Guile-commits] 03/12: Add intmap-replace.

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8f578af0bbfc2edf0bbb23da8df1578afd6659a4
Author: Andy Wingo <address@hidden>
Date:   Sun May 24 16:50:36 2015 +0200

    Add intmap-replace.
    
    * module/language/cps/intmap.scm (intmap-replace): New interface.
---
 module/language/cps/intmap.scm |   37 +++++++++++++++++++++++++++++++++++++
 1 files changed, 37 insertions(+), 0 deletions(-)

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index cb56cb3..d96801c 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -42,6 +42,7 @@
             transient-intmap
             intmap-add
             intmap-add!
+            intmap-replace
             intmap-remove
             intmap-ref
             intmap-next
@@ -284,6 +285,42 @@
     (($ <transient-intmap>)
      (intmap-add (persistent-intmap map) i val meet))))
 
+(define* (intmap-replace map i val #:optional (meet (lambda (old new) new)))
+  "Like intmap-add, but requires that @var{i} was present in the map
+already, and always calls the meet procedure."
+  (define (not-found i)
+    (error "not found" i))
+  (define (adjoin i shift root)
+    (if (zero? shift)
+        (if (absent? root)
+            (not-found i)
+            (meet root val))
+        (let* ((shift (- shift *branch-bits*))
+               (idx (logand (ash i (- shift)) *branch-mask*)))
+          (if (absent? root)
+              (not-found i)
+              (let* ((node (vector-ref root idx))
+                     (node* (adjoin i shift node)))
+                (if (eq? node node*)
+                    root
+                    (clone-branch-and-set root idx node*)))))))
+  (match map
+    (($ <intmap> min shift root)
+     (cond
+      ((< i 0)
+       ;; The power-of-two spanning trick doesn't work across 0.
+       (error "Intmaps can only map non-negative integers." i))
+      ((and (present? root) (<= min i) (< i (+ min (ash 1 shift))))
+       (let ((old-root root)
+             (root (adjoin (- i min) shift root)))
+         (if (eq? root old-root)
+             map
+             (make-intmap min shift root))))
+      (else
+       (not-found i))))
+    (($ <transient-intmap>)
+     (intmap-replace (persistent-intmap map) i val meet))))
+
 (define (intmap-remove map i)
   (define (remove i shift root)
     (cond