basis/compiler/tree/recursive/recursive-tests.factor

   1 IN: compiler.tree.recursive.tests
   2 USING: compiler.tree.recursive tools.test
   3 kernel combinators.short-circuit math sequences accessors
   4 compiler.tree
   5 compiler.tree.builder
   6 compiler.tree.combinators ;
   7
   8 [ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
   9 [ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
  10 [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
  11 [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
  12
  13 : label-is-loop? ( nodes word -- ? )
  14     [
  15         {
  16             [ drop #recursive? ]
  17             [ drop label>> loop?>> ]
  18             [ swap label>> word>> eq? ]
  19         } 2&&
  20     ] curry contains-node? ;
  21
  22 : label-is-not-loop? ( nodes word -- ? )
  23     [
  24         {
  25             [ drop #recursive? ]
  26             [ drop label>> loop?>> not ]
  27             [ swap label>> word>> eq? ]
  28         } 2&&
  29     ] curry contains-node? ;
  30
  31 : loop-test-1 ( a -- )
  32     dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
  33
  34 [ t ] [
  35     [ loop-test-1 ] build-tree analyze-recursive
  36     \ loop-test-1 label-is-loop?
  37 ] unit-test
  38
  39 [ t ] [
  40     [ loop-test-1 1 2 3 ] build-tree analyze-recursive
  41     \ loop-test-1 label-is-loop?
  42 ] unit-test
  43
  44 [ t ] [
  45     [ [ loop-test-1 ] each ] build-tree analyze-recursive
  46     \ loop-test-1 label-is-loop?
  47 ] unit-test
  48
  49 [ t ] [
  50     [ [ loop-test-1 ] each ] build-tree analyze-recursive
  51     \ (each-integer) label-is-loop?
  52 ] unit-test
  53
  54 : loop-test-2 ( a b -- a' )
  55     dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
  56
  57 [ t ] [
  58     [ loop-test-2 ] build-tree analyze-recursive
  59     \ loop-test-2 label-is-not-loop?
  60 ] unit-test
  61
  62 : loop-test-3 ( a -- )
  63     dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
  64
  65 [ t ] [
  66     [ loop-test-3 ] build-tree analyze-recursive
  67     \ loop-test-3 label-is-not-loop?
  68 ] unit-test
  69
  70 : loop-test-4 ( a -- )
  71     dup [
  72         loop-test-4
  73     ] [
  74         drop
  75     ] if ; inline recursive
  76
  77 [ f ] [
  78     [ [ [ ] map ] map ] build-tree analyze-recursive
  79     [
  80         dup #recursive? [ label>> loop?>> not ] [ drop f ] if
  81     ] contains-node?
  82 ] unit-test
  83
  84 : blah ( -- value ) f ;
  85
  86 DEFER: a
  87
  88 : b ( -- )
  89     blah [ b ] [ a ] if ; inline recursive
  90
  91 : a ( -- )
  92     blah [ b ] [ a ] if ; inline recursive
  93
  94 [ t ] [
  95     [ a ] build-tree analyze-recursive
  96     \ a label-is-loop?
  97 ] unit-test
  98
  99 [ t ] [
 100     [ a ] build-tree analyze-recursive
 101     \ b label-is-loop?
 102 ] unit-test
 103
 104 [ t ] [
 105     [ b ] build-tree analyze-recursive
 106     \ a label-is-loop?
 107 ] unit-test
 108
 109 [ t ] [
 110     [ a ] build-tree analyze-recursive
 111     \ b label-is-loop?
 112 ] unit-test
 113
 114 DEFER: a'
 115
 116 : b' ( -- )
 117     blah [ b' b' ] [ a' ] if ; inline recursive
 118
 119 : a' ( -- )
 120     blah [ b' ] [ a' ] if ; inline recursive
 121
 122 [ f ] [
 123     [ a' ] build-tree analyze-recursive
 124     \ a' label-is-loop?
 125 ] unit-test
 126
 127 [ f ] [
 128     [ b' ] build-tree analyze-recursive
 129     \ b' label-is-loop?
 130 ] unit-test
 131
 132 ! I used to think this should be f, but doing this on pen and
 133 ! paper almost convinced me that a loop conversion here is
 134 ! sound.
 135
 136 [ t ] [
 137     [ b' ] build-tree analyze-recursive
 138     \ a' label-is-loop?
 139 ] unit-test
 140
 141 [ f ] [
 142     [ a' ] build-tree analyze-recursive
 143     \ b' label-is-loop?
 144 ] unit-test
 145
 146 DEFER: a''
 147
 148 : b'' ( -- )
 149     a'' ; inline recursive
 150
 151 : a'' ( -- )
 152     b'' a'' ; inline recursive
 153
 154 [ t ] [
 155     [ a'' ] build-tree analyze-recursive
 156     \ a'' label-is-not-loop?
 157 ] unit-test
 158
 159 : loop-in-non-loop ( x quot: ( i -- ) -- )
 160     over 0 > [
 161         [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
 162     ] [ 2drop ] if ; inline recursive
 163
 164 [ t ] [
 165     [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
 166     build-tree analyze-recursive
 167     \ (each-integer) label-is-loop?
 168 ] unit-test