basis/compiler/tests/simple.factor

   1 USING: compiler.test compiler.units tools.test kernel kernel.private
   2 sequences.private math.private math combinators strings alien
   3 arrays memory vocabs parser eval quotations compiler.errors
   4 definitions generic.single ;
   5 IN: compiler.tests.simple
   6
   7 ! Test empty word
   8 [ ] [ [ ] compile-call ] unit-test
   9
  10 ! Test literals
  11 [ 1 ] [ [ 1 ] compile-call ] unit-test
  12 [ 31 ] [ [ 31 ] compile-call ] unit-test
  13 [ 255 ] [ [ 255 ] compile-call ] unit-test
  14 [ -1 ] [ [ -1 ] compile-call ] unit-test
  15 [ 65536 ] [ [ 65536 ] compile-call ] unit-test
  16 [ -65536 ] [ [ -65536 ] compile-call ] unit-test
  17 [ "hey" ] [ [ "hey" ] compile-call ] unit-test
  18
  19 ! Calls
  20 : no-op ( -- ) ;
  21
  22 [ ] [ [ no-op ] compile-call ] unit-test
  23 [ 3 ] [ [ no-op 3 ] compile-call ] unit-test
  24 [ 3 ] [ [ 3 no-op ] compile-call ] unit-test
  25
  26 : bar ( -- value ) 4 ;
  27
  28 [ 4 ] [ [ bar no-op ] compile-call ] unit-test
  29 [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
  30 [ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
  31
  32 [ ] [ no-op ] unit-test
  33
  34 ! Conditionals
  35
  36 [ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
  37 [ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
  38 [ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
  39 [ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
  40
  41 [ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
  42 [ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
  43
  44 [ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
  45 [ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
  46
  47 [ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
  48 [ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
  49 [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
  50 [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
  51
  52 [ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
  53
  54 ! Labels
  55
  56 : recursive-test ( ? -- ) [ f recursive-test ] when ; inline recursive
  57
  58 [ ] [ t [ recursive-test ] compile-call ] unit-test
  59
  60 [ ] [ t recursive-test ] unit-test
  61
  62 ! Make sure error reporting works
  63
  64 ! [ [ dup ] compile-call ] must-fail
  65 ! [ [ drop ] compile-call ] must-fail
  66
  67 ! Regression
  68
  69 [ ] [ [ callstack ] compile-call drop ] unit-test
  70
  71 ! Regression
  72
  73 : empty ( -- ) ;
  74
  75 [ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
  76
  77 : dummy-if-1 ( -- ) t [ ] [ ] if ;
  78
  79 [ ] [ dummy-if-1 ] unit-test
  80
  81 : dummy-if-2 ( -- ) f [ ] [ ] if ;
  82
  83 [ ] [ dummy-if-2 ] unit-test
  84
  85 : dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
  86
  87 [ 1 ] [ dummy-if-3 ] unit-test
  88
  89 : dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
  90
  91 [ 2 ] [ dummy-if-4 ] unit-test
  92
  93 : dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
  94
  95 [ 1 ] [ dummy-if-5 ] unit-test
  96
  97 : dummy-if-6 ( n -- n )
  98     dup 1 fixnum<= [
  99         drop 1
 100     ] [
 101         1 fixnum- dup 1 fixnum- fixnum+
 102     ] if ;
 103
 104 [ 17 ] [ 10 dummy-if-6 ] unit-test
 105
 106 : dead-code-rec ( -- obj )
 107     t [
 108         3.2
 109     ] [
 110         dead-code-rec
 111     ] if ;
 112
 113 [ 3.2 ] [ dead-code-rec ] unit-test
 114
 115 : one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
 116
 117 [ "hi" ] [ t one-rec ] unit-test
 118
 119 : after-if-test ( -- n )
 120     t [ ] [ ] if 5 ;
 121
 122 [ 5 ] [ after-if-test ] unit-test
 123
 124 DEFER: countdown-b
 125
 126 : countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
 127 : countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
 128
 129 [ ] [ 10 countdown-b ] unit-test
 130
 131 : dummy-when-1 ( -- ) t [ ] when ;
 132
 133 [ ] [ dummy-when-1 ] unit-test
 134
 135 : dummy-when-2 ( -- ) f [ ] when ;
 136
 137 [ ] [ dummy-when-2 ] unit-test
 138
 139 : dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
 140
 141 [ 16 ] [ 4 dummy-when-3 ] unit-test
 142 [ f ] [ f dummy-when-3 ] unit-test
 143
 144 : dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
 145
 146 [ 64 f ] [ f 4 dummy-when-4 ] unit-test
 147 [ f t ] [ t f dummy-when-4 ] unit-test
 148
 149 : dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
 150
 151 [ f ] [ f dummy-when-5 ] unit-test
 152
 153 : dummy-unless-1 ( -- ) t [ ] unless ;
 154
 155 [ ] [ dummy-unless-1 ] unit-test
 156
 157 : dummy-unless-2 ( -- ) f [ ] unless ;
 158
 159 [ ] [ dummy-unless-2 ] unit-test
 160
 161 : dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
 162
 163 [ 3 ] [ f dummy-unless-3 ] unit-test
 164 [ 4 ] [ 4 dummy-unless-3 ] unit-test
 165
 166 ! Test cond expansion
 167 [ "even" ] [
 168     [
 169         2 {
 170             { [ dup 2 mod 0 = ] [ drop "even" ] }
 171             { [ dup 2 mod 1 = ] [ drop "odd" ] }
 172         } cond
 173     ] compile-call
 174 ] unit-test
 175
 176 [ "odd" ] [
 177     [
 178         3 {
 179             { [ dup 2 mod 0 = ] [ drop "even" ] }
 180             { [ dup 2 mod 1 = ] [ drop "odd" ] }
 181         } cond
 182     ] compile-call
 183 ] unit-test
 184
 185 [ "neither" ] [
 186     [
 187         3 {
 188             { [ dup string? ] [ drop "string" ] }
 189             { [ dup float? ] [ drop "float" ] }
 190             { [ dup alien? ] [ drop "alien" ] }
 191             [ drop "neither" ]
 192         } cond
 193     ] compile-call
 194 ] unit-test
 195
 196 [ 3 ] [
 197     [
 198         3 {
 199             { [ dup fixnum? ] [ ] }
 200             [ drop t ]
 201         } cond
 202     ] compile-call
 203 ] unit-test
 204
 205 GENERIC: single-combination-test ( obj1 obj2 -- obj )
 206
 207 M: object single-combination-test drop ;
 208 M: f single-combination-test nip ;
 209 M: array single-combination-test drop ;
 210 M: integer single-combination-test drop ;
 211
 212 [ 2 3 ] [ 2 3 t single-combination-test ] unit-test
 213 [ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
 214 [ 2 f ] [ 2 3 f single-combination-test ] unit-test
 215
 216 DEFER: single-combination-test-2
 217
 218 : single-combination-test-4 ( obj -- obj )
 219     dup [ single-combination-test-2 ] when ;
 220
 221 : single-combination-test-3 ( obj -- obj )
 222     drop 3 ;
 223
 224 GENERIC: single-combination-test-2 ( obj -- obj )
 225 M: object single-combination-test-2 single-combination-test-3 ;
 226 M: f single-combination-test-2 single-combination-test-4 ;
 227
 228 [ 3 ] [ t single-combination-test-2 ] unit-test
 229 [ 3 ] [ 3 single-combination-test-2 ] unit-test
 230 [ f ] [ f single-combination-test-2 ] unit-test
 231
 232 ! Regression
 233 [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
 234
 235 ! Regression
 236 10 [
 237     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
 238     [ t ] [
 239         "USING: prettyprint words accessors ;
 240         IN: compiler.tests.foo
 241         : (recursive) ( -- ) (recursive) (recursive) ; inline recursive
 242         : recursive ( -- ) (recursive) ;
 243         \\ (recursive) word-optimized?" eval( -- obj )
 244     ] unit-test
 245 ] times
 246
 247 ! This should not compile
 248 GENERIC: bad-effect-test ( a -- )
 249 M: quotation bad-effect-test call ; inline
 250 : bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
 251
 252 [ bad-effect-test* ] [ not-compiled? ] must-fail-with
 253
 254 ! Don't want compiler error to stick around
 255 [ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test
 256
 257 ! Make sure time bombs literalize
 258 [ [ \ + call ] compile-call ] [ no-method? ] must-fail-with