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 sequences.deep arrays
   4 stack-checker.inlining namespaces compiler.tree ;
   5 IN: compiler.tree.combinators
   6
   7 : each-node ( nodes quot: ( node -- ) -- )
   8     dup dup '[
   9         , [
  10             dup #branch? [
  11                 children>> [ , each-node ] each
  12             ] [
  13                 dup #recursive? [
  14                     child>> , each-node
  15                 ] [ drop ] if
  16             ] if
  17         ] bi
  18     ] each ; inline recursive
  19
  20 : map-nodes ( nodes quot: ( node -- node' ) -- nodes )
  21     dup dup '[
  22         @
  23         dup #branch? [
  24             [ [ , map-nodes ] map ] change-children
  25         ] [
  26             dup #recursive? [
  27                 [ , map-nodes ] change-child
  28             ] when
  29         ] if
  30     ] map flatten ; inline recursive
  31
  32 : contains-node? ( nodes quot: ( node -- ? ) -- ? )
  33     dup dup '[
  34         , keep swap [ drop t ] [
  35             dup #branch? [
  36                 children>> [ , contains-node? ] contains?
  37             ] [
  38                 dup #recursive? [
  39                     child>> , contains-node?
  40                 ] [ drop f ] if
  41             ] if
  42         ] if
  43     ] contains? ; inline recursive
  44
  45 : select-children ( seq flags -- seq' )
  46     [ [ drop f ] unless ] 2map ;
  47
  48 : sift-children ( seq flags -- seq' )
  49     zip [ nip ] assoc-filter keys ;
  50
  51 : (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
  52
  53 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
  54
  55 : 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
  56
  57 : until-fixed-point ( #recursive quot: ( node -- ) -- )
  58     over label>> t >>fixed-point drop
  59     [ with-scope ] 2keep
  60     over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
  61     inline recursive