Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Restoring iset merge node logic.

Browse source
This commit is contained in:
Alex Shinn 2014-05-13 23:01:09 +09:00
parent d7e65edc96
commit a886737b20
1 changed files with 46 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
lib/chibi/iset/constructors.scm
View file

@ -3,7 +3,7 @@
;; Utilities for constructing and joining isets. ;; Utilities for constructing and joining isets.
(define bits-thresh 128) ; within 128 we join into a bitmap (define bits-thresh 128) ; within 128 we join into a bitmap
(define bits-max 512) ; don't make bitmaps larger than this ;;(define bits-max 512) ; don't make bitmaps larger than this
(define (bit-set n index) (define (bit-set n index)
(bitwise-ior n (arithmetic-shift 1 index))) (bitwise-ior n (arithmetic-shift 1 index)))
@ -65,9 +65,46 @@
(if (and bits (= bits (range->bits (iset-start iset) (iset-end iset)))) (if (and bits (= bits (range->bits (iset-start iset) (iset-end iset))))
(iset-bits-set! iset #f)))) (iset-bits-set! iset #f))))
(define (iset-should-merge-left? a b)
(and (< (- (iset-start a) (iset-end b))
bits-thresh)
(or (not (iset-left a))
(> (iset-start b) (iset-max-end (iset-left a))))))
(define (iset-should-merge-right? a b)
(and (< (- (iset-start b) (iset-end a))
bits-thresh)
(or (not (iset-right a))
(< (iset-end b) (iset-min-start (iset-right a))))))
(define (iset-merge-left! a b)
(if (or (iset-bits a) (iset-bits b)
(< (+ 1 (iset-end b)) (iset-start a)))
(let* ((a-bits (or (iset-bits a)
(range->bits (iset-start a) (iset-end a))))
(b-bits (or (iset-bits b)
(range->bits (iset-start b) (iset-end b))))
(shift (- (iset-start a) (iset-start b)))
(bits (bitwise-ior b-bits (arithmetic-shift a-bits shift))))
(iset-bits-set! a bits)))
(iset-start-set! a (iset-start b)))
(define (iset-merge-right! a b)
(if (or (iset-bits a) (iset-bits b)
(< (+ 1 (iset-end a)) (iset-start b)))
(let* ((a-bits (or (iset-bits a)
(range->bits (iset-start a) (iset-end a))))
(b-bits (or (iset-bits b)
(range->bits (iset-start b) (iset-end b))))
(shift (- (iset-start b) (iset-start a)))
(bits (bitwise-ior a-bits (arithmetic-shift b-bits shift))))
(iset-bits-set! a bits)))
(iset-end-set! a (iset-end b)))
(define (iset-adjoin1! is n) (define (iset-adjoin1! is n)
(iset-adjoin-node! is (%make-iset n n #f #f #f))) (iset-adjoin-node! is (%make-iset n n #f #f #f)))
;; adjoin just the node b (ignoring left/right) to the full iset a
(define (iset-adjoin-node! a b) (define (iset-adjoin-node! a b)
(cond (cond
((iset-empty? a) ((iset-empty? a)
@ -85,11 +122,15 @@
;; aaaa... ;; aaaa...
;; ...bbbb ;; ...bbbb
((< b-end a-start) ((< b-end a-start)
(iset-adjoin-node-left! a b)) (if (iset-should-merge-left? a b)
(iset-merge-left! a b)
(iset-adjoin-node-left! a b)))
;; ...aaaa ;; ...aaaa
;; bbbb... ;; bbbb...
((> b-start a-end) ((> b-start a-end)
(iset-adjoin-node-right! a b)) (if (iset-should-merge-right? a b)
(iset-merge-right! a b)
(iset-adjoin-node-right! a b)))
;; ...aaaaa... ;; ...aaaaa...
;; ...bb... ;; ...bb...
((and (>= b-start a-start) (<= b-end a-end)) ((and (>= b-start a-start) (<= b-end a-end))
@ -97,7 +138,8 @@
(let ((b-bits (arithmetic-shift (let ((b-bits (arithmetic-shift
(or b-bits (range->bits b-start b-end)) (or b-bits (range->bits b-start b-end))
(- b-start a-start)))) (- b-start a-start))))
(iset-bits-set! a (bitwise-ior a-bits b-bits))))) (iset-bits-set! a (bitwise-ior a-bits b-bits))
(iset-squash-bits! a))))
(else (else
;; general case: split, recurse, join sides ;; general case: split, recurse, join sides
(let ((ls (iset-node-split b a-start a-end))) (let ((ls (iset-node-split b a-start a-end)))