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

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