mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

Fix intmap-intersect corner case

Browse source 
* module/language/cps/intmap.scm (intmap-intersect): Fix a corner case,
  as was recently fixed for intsets.
This commit is contained in:
Andy Wingo 2014-06-29 19:49:41 +02:00
parent 072b5a277c
commit e21dae43fc
1 changed files with 23 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/cps/intmap.scm
View file

@ -349,23 +349,31 @@
(else (else
(let* ((lo-shift (- lo-shift *branch-bits*)) (let* ((lo-shift (- lo-shift *branch-bits*))
(lo-idx (ash (- hi-min lo-min) (- lo-shift)))) (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
(if (>= lo-idx *branch-size*) (cond
;; HI has a lower shift, but it not within LO. ((>= lo-idx *branch-size*)
empty-intmap ;; HI has a lower shift, but it not within LO.
(let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) empty-intmap)
lo-shift ((vector-ref lo-root lo-idx)
(vector-ref lo-root lo-idx)))) => (lambda (lo-root)
(if lo-is-a? (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
(intmap-intersect lo hi meet) lo-shift
(intmap-intersect hi lo meet)))))))) lo-root)))
(if lo-is-a?
(intmap-intersect lo hi meet)
(intmap-intersect hi lo meet)))))
(else empty-intmap))))))
(define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
(let ((hi (make-intmap min (cond
(- hi-shift *branch-bits*) ((vector-ref hi-root 0)
(vector-ref hi-root 0)))) => (lambda (hi-root)
(if lo-is-a? (let ((hi (make-intmap min
(intmap-intersect lo hi meet) (- hi-shift *branch-bits*)
(intmap-intersect hi lo meet)))) hi-root)))
(if lo-is-a?
(intmap-intersect lo hi meet)
(intmap-intersect hi lo meet)))))
(else empty-intmap)))
(match (cons a b) (match (cons a b)
((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))