Default "meet" operator is meet-error for intmap

[bpt/guile.git] / module / language / cps / intmap.scm

diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 7be27c9..e3ed5da 100644 (file)
--- 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
@@ -102,7 +102,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)
@@ -121,6 +124,9 @@
   (match bs
     (($ <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))
       ((not val) (intmap-remove bs i))
       ((not root)
        ;; Add first element.
@@ -172,16 +178,18 @@
 (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 (visit-branch node shift i)
@@ -204,7 +212,7 @@
             (let ((i (visit-node root shift i)))
               (and i (+ min i))))))))
 
-(define (intmap-union a b meet)
+(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))
@@ -283,7 +291,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))