From e21dae43fcd63b0e261e76d78e7eaf4aed10a190 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Jun 2014 19:49:41 +0200 Subject: [PATCH] Fix intmap-intersect corner case * module/language/cps/intmap.scm (intmap-intersect): Fix a corner case, as was recently fixed for intsets. --- module/language/cps/intmap.scm | 38 ++++++++++++++++++++-------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index 19d04c020..7be27c906 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -349,23 +349,31 @@ (else (let* ((lo-shift (- lo-shift *branch-bits*)) (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) - (if (>= lo-idx *branch-size*) - ;; HI has a lower shift, but it not within LO. - empty-intmap - (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) - lo-shift - (vector-ref lo-root lo-idx)))) - (if lo-is-a? - (intmap-intersect lo hi meet) - (intmap-intersect hi lo meet)))))))) + (cond + ((>= lo-idx *branch-size*) + ;; HI has a lower shift, but it not within LO. + empty-intmap) + ((vector-ref lo-root lo-idx) + => (lambda (lo-root) + (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) + lo-shift + 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?) - (let ((hi (make-intmap min - (- hi-shift *branch-bits*) - (vector-ref hi-root 0)))) - (if lo-is-a? - (intmap-intersect lo hi meet) - (intmap-intersect hi lo meet)))) + (cond + ((vector-ref hi-root 0) + => (lambda (hi-root) + (let ((hi (make-intmap min + (- hi-shift *branch-bits*) + hi-root))) + (if lo-is-a? + (intmap-intersect lo hi meet) + (intmap-intersect hi lo meet))))) + (else empty-intmap))) (match (cons a b) ((($ a-min a-shift a-root) . ($ b-min b-shift b-root)) -- 2.20.1