core/compiler/test/inference.factor

   1 USING: arrays errors generic inference kernel kernel-internals
   2 math math-internals namespaces parser sequences strings test
   3 vectors words ;
   4 IN: temporary
   5
   6 : short-effect
   7     dup effect-in length swap effect-out length 2array nip ;
   8
   9 [ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
  10
  11 [ t ] [ [ ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
  12
  13 [ t ] [ [ 1 2 ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
  14
  15 [ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
  16
  17 [ { 0 0 } ] [ f infer short-effect ] unit-test
  18 [ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test
  19 [ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test
  20
  21 [ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test
  22 [ [ call ] infer short-effect ] unit-test-fails
  23
  24 [ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test
  25
  26 [ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test
  27 [ [ if ] infer short-effect ] unit-test-fails
  28 [ [ [ ] if ] infer short-effect ] unit-test-fails
  29 [ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails
  30 [ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test
  31
  32 [ { 4 3 } ] [
  33     [
  34         [
  35             [ swap 3 ] [ nip 5 5 ] if
  36         ] [
  37             -rot
  38         ] if
  39     ] infer short-effect
  40 ] unit-test
  41
  42 [ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test
  43 [ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test
  44 [ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test
  45
  46 [ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test
  47 [ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test
  48
  49 [ { 0 1 } ] [
  50     [ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect
  51 ] unit-test
  52
  53 [
  54     [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call
  55 ] unit-test-fails
  56
  57 ! Test inference of termination of control flow
  58 : termination-test-1
  59     "foo" throw ;
  60
  61 : termination-test-2 [ termination-test-1 ] [ 3 ] if ;
  62
  63 [ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test
  64
  65 : infinite-loop infinite-loop ;
  66
  67 [ [ infinite-loop ] infer short-effect ] unit-test-fails
  68
  69 : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
  70 [ [ no-base-case-1 ] infer short-effect ] unit-test-fails
  71
  72 : simple-recursion-1 ( obj -- obj )
  73     dup [ simple-recursion-1 ] [ ] if ;
  74
  75 [ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test
  76
  77 : simple-recursion-2 ( obj -- obj )
  78     dup [ ] [ simple-recursion-2 ] if ;
  79
  80 [ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test
  81
  82 : bad-recursion-2 ( obj -- obj )
  83     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
  84
  85 [ [ bad-recursion-2 ] infer short-effect ] unit-test-fails
  86
  87 : funny-recursion ( obj -- obj )
  88     dup [ funny-recursion 1 ] [ 2 ] if drop ;
  89
  90 [ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test
  91
  92 ! Simple combinators
  93 [ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test
  94
  95 ! Mutual recursion
  96 DEFER: foe
  97
  98 : fie ( element obj -- ? )
  99     dup array? [ foe ] [ eq? ] if ;
 100
 101 : foe ( element tree -- ? )
 102     dup [
 103         2dup first fie [
 104             nip
 105         ] [
 106             second dup array? [
 107                 foe
 108             ] [
 109                 fie
 110             ] if
 111         ] if
 112     ] [
 113         2drop f
 114     ] if ;
 115
 116 [ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test
 117 [ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test
 118
 119 : nested-when ( -- )
 120     t [
 121         t [
 122             5 drop
 123         ] when
 124     ] when ;
 125
 126 [ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test
 127
 128 : nested-when* ( obj -- )
 129     [
 130         [
 131             drop
 132         ] when*
 133     ] when* ;
 134
 135 [ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test
 136
 137 SYMBOL: sym-test
 138
 139 [ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test
 140
 141 : terminator-branch
 142     dup [
 143         length
 144     ] [
 145         "foo" throw
 146     ] if ;
 147
 148 [ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test
 149
 150 : recursive-terminator ( obj -- )
 151     dup [
 152         recursive-terminator
 153     ] [
 154         "Hi" throw
 155     ] if ;
 156
 157 [ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test
 158
 159 GENERIC: potential-hang ( obj -- obj )
 160 M: fixnum potential-hang dup [ potential-hang ] when ;
 161
 162 [ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test
 163
 164 TUPLE: funny-cons car cdr ;
 165 GENERIC: iterate ( obj -- )
 166 M: funny-cons iterate funny-cons-cdr iterate ;
 167 M: f iterate drop ;
 168 M: real iterate drop ;
 169
 170 [ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test
 171
 172 ! Regression
 173 : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
 174 : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
 175 [ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test
 176
 177 ! Regression
 178 DEFER: monkey
 179 : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
 180 : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
 181 [ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test
 182
 183 ! Regression -- same as above but we infer short-effect the second word first
 184 DEFER: blah2
 185 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
 186 : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
 187 [ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test
 188
 189 ! Regression
 190 DEFER: blah4
 191 : blah3 ( a b c -- )
 192     dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
 193 : blah4 ( a b c -- )
 194     dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
 195 [ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test
 196
 197 ! Regression
 198 : bad-combinator ( obj quot -- )
 199     over [
 200         2drop
 201     ] [
 202         [ swap slip ] keep swap bad-combinator
 203     ] if ; inline
 204
 205 [ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails
 206
 207 ! Regression
 208 : bad-input#
 209     dup string? [ 2array throw ] unless
 210     over string? [ 2array throw ] unless ;
 211
 212 [ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test
 213
 214 ! Regression
 215
 216 ! This order of branches works
 217 DEFER: do-crap
 218 : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
 219 : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
 220 [ [ do-crap ] infer short-effect ] unit-test-fails
 221
 222 ! This one does not
 223 DEFER: do-crap*
 224 : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
 225 : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
 226 [ [ do-crap* ] infer short-effect ] unit-test-fails
 227
 228 ! Regression
 229 : too-deep ( a b -- c )
 230     dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
 231 [ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test
 232
 233 ! Error reporting is wrong
 234 G: xyz math-combination ;
 235 M: fixnum xyz 2array ;
 236 M: ratio xyz
 237     [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
 238
 239 [ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
 240
 241 ! Doug Coleman discovered this one while working on the
 242 ! calendar library
 243 DEFER: A
 244 DEFER: B
 245 DEFER: C
 246
 247 : A ( a -- )
 248     dup {
 249         [ drop ]
 250         [ A ]
 251         [ \ A no-method ]
 252         [ dup C A ]
 253     } dispatch ;
 254
 255 : B ( b -- )
 256     dup {
 257         [ C ]
 258         [ B ]
 259         [ \ B no-method ]
 260         [ dup B B ]
 261     } dispatch ;
 262
 263 : C ( c -- )
 264     dup {
 265         [ A ]
 266         [ C ]
 267         [ \ C no-method ]
 268         [ dup B C ]
 269     } dispatch ;
 270
 271 [ { 1 0 } ] [ [ A ] infer short-effect ] unit-test
 272 [ { 1 0 } ] [ [ B ] infer short-effect ] unit-test
 273 [ { 1 0 } ] [ [ C ] infer short-effect ] unit-test
 274
 275 ! I found this bug by thinking hard about the previous one
 276 DEFER: Y
 277 : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
 278 : Y ( a b -- c d ) X ;
 279
 280 [ { 2 2 } ] [ [ X ] infer short-effect ] unit-test
 281 [ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test
 282
 283 ! This one comes from UI code
 284 DEFER: #1
 285 : #2 ( a b -- ) dup [ call ] [ 2drop ] if ; inline
 286 : #3 ( a -- ) [ #1 ] #2 ;
 287 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
 288 : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
 289
 290 [ \ #4 word-def infer short-effect ] unit-test-fails
 291 [ [ #1 ] infer short-effect ] unit-test-fails
 292
 293 ! Similar
 294 DEFER: bar
 295 : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
 296 : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 297
 298 [ [ foo ] infer short-effect ] unit-test-fails
 299
 300 [ 1234 infer short-effect ] unit-test-fails
 301
 302 ! This used to hang
 303 [ [ [ dup call ] dup call ] infer short-effect ] unit-test-fails
 304
 305 ! This form should not have a stack effect
 306
 307 : bad-recursion-1 ( a -- b )
 308     dup [ drop bad-recursion-1 5 ] [ ] if ;
 309
 310 [ [ bad-recursion-1 ] infer short-effect ] unit-test-fails
 311
 312 : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
 313 [ [ bad-bin ] infer short-effect ] unit-test-fails
 314
 315 [ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test
 316
 317 ! Test some random library words
 318
 319 [ { 1 1 } ] [ [ unit ] infer short-effect ] unit-test
 320
 321 ! Unbalanced >n/n> is an error now!
 322 ! [ { 1 0 } ] [ [ >n ] infer short-effect ] unit-test
 323 ! [ { 0 1 } ] [ [ n> ] infer short-effect ] unit-test
 324
 325 [ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test
 326 [ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test
 327 [ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test
 328 [ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test
 329 [ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test
 330 [ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test
 331 [ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test
 332 [ { 2 1 } ] [ [ + ] infer short-effect ] unit-test
 333 [ { 2 1 } ] [ [ - ] infer short-effect ] unit-test
 334 [ { 2 1 } ] [ [ * ] infer short-effect ] unit-test
 335 [ { 2 1 } ] [ [ / ] infer short-effect ] unit-test
 336 [ { 2 1 } ] [ [ < ] infer short-effect ] unit-test
 337 [ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test
 338 [ { 2 1 } ] [ [ > ] infer short-effect ] unit-test
 339 [ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test
 340 [ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test
 341
 342 [ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test
 343 [ { 2 1 } ] [ [ = ] infer short-effect ] unit-test
 344 [ { 1 1 } ] [ [ get ] infer short-effect ] unit-test
 345
 346 [ { 2 0 } ] [ [ push ] infer short-effect ] unit-test
 347 [ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test
 348 [ { 2 1 } ] [ [ append ] infer short-effect ] unit-test
 349 [ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test
 350
 351 [ { 1 1 } ] [ [ length ] infer short-effect ] unit-test
 352 [ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test
 353 [ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test
 354 [ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test
 355 [ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test
 356
 357 ! Test scope inference
 358 SYMBOL: x
 359
 360 [ [ n> ] infer ] unit-test-fails
 361 [ [ ndrop ] infer ] unit-test-fails
 362 [ V{ x } ] [ [ x get ] infer drop inferred-vars-reads ] unit-test
 363 [ V{ x } ] [ [ x set ] infer drop inferred-vars-writes ] unit-test
 364 [ V{ x } ] [ [ [ x get ] with-scope ] infer drop inferred-vars-reads ] unit-test
 365 [ V{ } ] [ [ [ x set ] with-scope ] infer drop inferred-vars-writes ] unit-test
 366 [ V{ x } ] [ [ [ x get ] bind ] infer drop inferred-vars-reads ] unit-test
 367 [ V{ } ] [ [ [ x set ] bind ] infer drop inferred-vars-writes ] unit-test
 368 [ V{ x } ] [ [ [ x get ] make-hash ] infer drop inferred-vars-reads ] unit-test
 369 [ V{ } ] [ [ [ x set ] make-hash ] infer drop inferred-vars-writes ] unit-test
 370 [ V{ building } ] [ [ , ] infer drop inferred-vars-reads ] unit-test
 371 [ V{ } ] [ [ [ 3 , ] { } make ] infer drop inferred-vars-reads ] unit-test
 372 [ V{ x } ] [ [ [ x get ] [ 5 ] if ] infer drop inferred-vars-reads ] unit-test
 373 [ V{ x } ] [ [ >n [ x get ] [ 5 ] if n> ] infer drop inferred-vars-reads ] unit-test
 374 [ V{ } ] [ [ >n [ x set ] [ drop ] if x get n> ] infer drop inferred-vars-reads ] unit-test
 375 [ V{ x } ] [ [ >n x get ndrop ] infer drop inferred-vars-reads ] unit-test
 376 [ V{ } ] [ [ >n x set ndrop ] infer drop inferred-vars-writes ] unit-test
 377
 378 [ [ >n ] [ ] if ] unit-test-fails
 379
 380 [ V{ 2 3 } ] [ [ [ [ 2 get 3 throw ] [ 3 get ] if ] with-scope ] infer drop inferred-vars-reads ] unit-test
 381
 382 [ V{ } ] [ [ 5 set 5 get ] infer drop inferred-vars-reads ] unit-test
 383
 384 [ [ 3.1 execute ] infer ] unit-test-fails