mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 11:34:09 +02:00
Code Activity

Add intset-fold, intset-fold2

Browse source 
* module/language/cps/intset.scm (intset-fold, intset-fold2): New
  functions.
This commit is contained in:
Andy Wingo 2015-04-01 10:45:53 +02:00
parent b7668bd949
commit 9c8d2b85e8
1 changed files with 61 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; Functional name maps
;;; Copyright (C) 2014 Free Software Foundation, Inc.
;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
@ -34,6 +34,8 @@
intset-remove
intset-ref
intset-next
intset-fold
intset-fold2
intset-union
intset-intersect
intset-subtract
@ -251,6 +253,64 @@
(let ((i (visit-node root shift i)))
(and i (+ min i))))))))
(define (intset-fold f set seed)
(define (visit-branch node shift min seed)
(cond
((= shift *leaf-bits*)
(let lp ((i 0) (seed seed))
(if (< i *leaf-size*)
(lp (1+ i)
(if (logbit? i node)
(f (+ i min) seed)
seed))
seed)))
(else
(let ((shift (- shift *branch-bits*)))
(let lp ((i 0) (seed seed))
(if (< i *branch-size*)
(let ((elt (vector-ref node i)))
(lp (1+ i)
(if elt
(visit-branch elt shift (+ min (ash i shift)) seed)
seed)))
seed))))))
(match set
(($ <intset> min shift root)
(cond
((not root) seed)
(else (visit-branch root shift min seed))))))
(define (intset-fold2 f set s0 s1)
(define (visit-branch node shift min s0 s1)
(cond
((= shift *leaf-bits*)
(let lp ((i 0) (s0 s0) (s1 s1))
(if (< i *leaf-size*)
(if (logbit? i node)
(call-with-values (lambda () (f (+ i min) s0 s1))
(lambda (s0 s1)
(lp (1+ i) s0 s1)))
(lp (1+ i) s0 s1))
(values s0 s1))))
(else
(let ((shift (- shift *branch-bits*)))
(let lp ((i 0) (s0 s0) (s1 s1))
(if (< i *branch-size*)
(let ((elt (vector-ref node i)))
(if elt
(call-with-values
(lambda ()
(visit-branch elt shift (+ min (ash i shift)) s0 s1))
(lambda (s0 s1)
(lp (1+ i) s0 s1)))
(lp (1+ i) s0 s1)))
(values s0 s1)))))))
(match set
(($ <intset> min shift root)
(cond
((not root) (values s0 s1))
(else (visit-branch root shift min s0 s1))))))
(define (intset-size shift root)
(cond
((not root) 0)