basis/compiler/tree/combinators/combinators.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 compiler.tree compiler.utilities kernel locals namespaces
   5 sequences stack-checker.inlining ;
   6 IN: compiler.tree.combinators
   7
   8 :: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
   9     nodes [
  10         quot
  11         [
  12             {
  13                 { [ dup #branch? ] [ children>> [ quot each-node ] each ] }
  14                 { [ dup #recursive? ] [ child>> quot each-node ] }
  15                 { [ dup #alien-callback? ] [ child>> quot each-node ] }
  16                 [ drop ]
  17             } cond
  18         ] bi
  19     ] each ; inline recursive
  20
  21 :: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
  22     nodes [
  23         quot call
  24         {
  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 ] }
  28             [ ]
  29         } cond
  30     ] map-flat ; inline recursive
  31
  32 :: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
  33     nodes [
  34         {
  35             quot
  36             [
  37                 {
  38                     { [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
  39                     { [ dup #recursive? ] [ child>> quot contains-node? ] }
  40                     { [ dup #alien-callback? ] [ child>> quot contains-node? ] }
  41                     [ drop f ]
  42                 } cond
  43             ]
  44         } 1||
  45     ] any? ; inline recursive
  46
  47 : select-children ( seq flags -- seq' )
  48     [ [ drop f ] unless ] 2map ;
  49
  50 : sift-children ( seq flags -- seq' )
  51     zip sift-values keys ;
  52
  53 : until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
  54     over label>> t >>fixed-point drop
  55     [ with-scope ] 2keep
  56     over label>> fixed-point>>
  57     [ 2drop ] [ until-fixed-point ] if ; inline recursive