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