basis/compiler/tests/simple.factor

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