basis/compiler/tests/simple.factor

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