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

Add bitvector->intset.

Browse source 
* module/language/cps/intset.scm (bitvector->intset): New interface.
This commit is contained in:
Andy Wingo 2014-07-03 10:37:20 +02:00
parent 4296c36ec8
commit 7f6aafa5ae
1 changed files with 19 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

20
module/language/cps/intset.scm
View file

@ -36,7 +36,8 @@
intset-next intset-next
intset-union intset-union
intset-intersect intset-intersect
intset-subtract)) intset-subtract
bitvector->intset))
(define-syntax-rule (define-inline name val) (define-syntax-rule (define-inline name val)
(define-syntax name (identifier-syntax val))) (define-syntax name (identifier-syntax val)))
@ -536,3 +537,20 @@
(if (eq? old new) (if (eq? old new)
a-root a-root
(clone-branch-and-set a-root a-idx new))))))))))) (clone-branch-and-set a-root a-idx new)))))))))))
(define (bitvector->intset bv)
(define (finish-tail out min tail)
(if (zero? tail)
out
(intset-union out (make-intset min *leaf-bits* tail))))
(let lp ((out empty-intset) (min 0) (pos 0) (tail 0))
(let ((pos (bit-position #t bv pos)))
(cond
((not pos)
(finish-tail out min tail))
((< pos (+ min *leaf-size*))
(lp out min (1+ pos) (logior tail (ash 1 (- pos min)))))
(else
(let ((min* (round-down pos *leaf-bits*)))
(lp (finish-tail out min tail)
min* pos (ash 1 (- pos min*)))))))))