basis/compiler/tree/combinators/combinators.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs fry kernel accessors sequences compiler.utilities
   4 arrays stack-checker.inlining namespaces compiler.tree
   5 math.order ;
   6 IN: compiler.tree.combinators
   7
   8 : each-node ( nodes quot: ( node -- ) -- )
   9     dup dup '[
  10         _ [
  11             dup #branch? [
  12                 children>> [ _ each-node ] each
  13             ] [
  14                 dup #recursive? [
  15                     child>> _ each-node
  16                 ] [ drop ] if
  17             ] if
  18         ] bi
  19     ] each ; inline recursive
  20
  21 : map-nodes ( nodes quot: ( node -- node' ) -- nodes )
  22     dup dup '[
  23         @
  24         dup #branch? [
  25             [ [ _ map-nodes ] map ] change-children
  26         ] [
  27             dup #recursive? [
  28                 [ _ map-nodes ] change-child
  29             ] when
  30         ] if
  31     ] map-flat ; inline recursive
  32
  33 : contains-node? ( nodes quot: ( node -- ? ) -- ? )
  34     dup dup '[
  35         _ keep swap [ drop t ] [
  36             dup #branch? [
  37                 children>> [ _ contains-node? ] any?
  38             ] [
  39                 dup #recursive? [
  40                     child>> _ contains-node?
  41                 ] [ drop f ] if
  42             ] if
  43         ] if
  44     ] any? ; inline recursive
  45
  46 : select-children ( seq flags -- seq' )
  47     [ [ drop f ] unless ] 2map ;
  48
  49 : sift-children ( seq flags -- seq' )
  50     zip [ nip ] assoc-filter keys ;
  51
  52 : until-fixed-point ( #recursive quot: ( node -- ) -- )
  53     over label>> t >>fixed-point drop
  54     [ with-scope ] 2keep
  55     over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
  56     inline recursive