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

Fixing iset-node-extract.

Browse source
This commit is contained in:
Alex Shinn 2014-05-19 21:49:10 +09:00
parent 2b3a85d7e7
commit cccd4cfbc9
2 changed files with 54 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -171,10 +171,19 @@
(iset-node-extract node (+ end 1) (iset-end node)))))
(define (iset-node-extract node start end)
(let ((bits (and (iset-bits node)
(arithmetic-shift (iset-bits node)
(- (iset-start node) start)))))
(%make-iset start end bits #f #f)))
(cond
((iset-bits node)
=> (lambda (node-bits)
(let* ((bits
(bitwise-and
(arithmetic-shift node-bits (- (iset-start node) start))
(range->bits start end)))
(new-end (min end (+ start (integer-length bits)))))
(%make-iset start new-end bits #f #f))))
(else
(%make-iset (max start (iset-start node))
(min end (iset-end node))
#f #f #f))))
(define (iset-adjoin! iset . ls)
(list->iset! ls iset))

41
tests/iset-tests.scm
View file

@ -102,5 +102,46 @@
(test-assert (iset= (iset-union (iset 1 3) (iset 3 4)) (iset 1 3 4)))
(test-assert (iset= (iset-union (iset 3) (iset 1 3)) (iset 1 3)))
(test-assert (iset= (iset-union (iset 1 4) (iset 3 4 5)) (iset 1 3 4 5)))
(test '(1 2 3 4 5 6 7 8) (iset->list (iset 1 2 3 4 5 6 7 8)))
(test '(1 3 4 5 6 7 8) (iset->list (iset 1 3 4 5 6 7 8)))
(test '(1 2 4 5 6 7 8) (iset->list (iset 1 2 4 5 6 7 8)))
(test '(1 2 3 5 6 7 8) (iset->list (iset 1 2 3 5 6 7 8)))
(test '(1 2 3 4 6 7 8) (iset->list (iset 1 2 3 4 6 7 8)))
(test '(1 2 3 4 5 7 8) (iset->list (iset 1 2 3 4 5 7 8)))
(test '(1 2 3 4 5 6 8) (iset->list (iset 1 2 3 4 5 6 8)))
(test '(1 2 3 4 5 6 7 8)
(iset->list (iset-union (iset 1 2 3 4) (iset 5 6 7 8))))
(test '(1 3 4 5 6 7 8)
(iset->list (iset-union (iset 1 3 4) (iset 5 6 7 8))))
(test '(1 2 4 5 6 7 8)
(iset->list (iset-union (iset 1 2 4) (iset 5 6 7 8))))
(test '(1 2 3 5 6 7 8)
(iset->list (iset-union (iset 1 2 3) (iset 5 6 7 8))))
(test '(1 2 3 4 6 7 8)
(iset->list (iset-union (iset 1 2 3 4) (iset 6 7 8))))
(test '(1 2 3 4 5 7 8)
(iset->list (iset-union (iset 1 2 3 4) (iset 5 7 8))))
(test '(1 2 3 4 5 6 8)
(iset->list (iset-union (iset 1 2 3 4) (iset 5 6 8))))
(test '(1 2 3 6 7 8)
(iset->list (iset-union (iset 1 2 3) (iset 6 7 8))))
(test '(1 3 6 8)
(iset->list (iset-union (iset 1 3) (iset 6 8))))
(test '(1 2 3 4 1001 1002 1003 1004 2001 2002 2003 2004)
(iset->list (iset-union (iset 1 2 3 4 1001 1002)
(iset 1003 1004 2001 2002 2003 2004))))
(test '(1 2 4 1001 1002 1003 1004 2001 2002 2003 2004)
(iset->list (iset-union (iset 1 2 4 1001 1002)
(iset 1003 1004 2001 2002 2003 2004))))
(test '(1 2 3 4 1001 1002 1004 2001 2002 2003 2004)
(iset->list (iset-union (iset 1 2 3 4 1001 1002)
(iset 1004 2001 2002 2003 2004))))
(test '(1 2 3 4 1001 1002 1003 1004 2001 2003 2004)
(iset->list (iset-union (iset 1 2 3 4 1001 1002)
(iset 1003 1004 2001 2003 2004))))
(test-end)