1 ! Copyright (C) 2008, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs combinators combinators.short-circuit fry kernel
4 locals accessors sequences compiler.utilities arrays
5 stack-checker.inlining namespaces compiler.tree math.order ;
6 IN: compiler.tree.combinators
8 :: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
13 { [ dup #branch? ] [ children>> [ quot each-node ] each ] }
14 { [ dup #recursive? ] [ child>> quot each-node ] }
15 { [ dup #alien-callback? ] [ child>> quot each-node ] }
19 ] each ; inline recursive
21 :: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
25 { [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] }
26 { [ dup #recursive? ] [ [ quot map-nodes ] change-child ] }
27 { [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] }
30 ] map-flat ; inline recursive
32 :: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
38 { [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
39 { [ dup #recursive? ] [ child>> quot contains-node? ] }
40 { [ dup #alien-callback? ] [ child>> quot contains-node? ] }
45 ] any? ; inline recursive
47 : select-children ( seq flags -- seq' )
48 [ [ drop f ] unless ] 2map ;
50 : sift-children ( seq flags -- seq' )
51 zip sift-values keys ;
53 : until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
54 over label>> t >>fixed-point drop
56 over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;