basis/locals/locals-tests.factor

   1 USING: locals math sequences tools.test hashtables words kernel
   2 namespaces arrays strings prettyprint io.streams.string parser
   3 accessors generic eval combinators combinators.short-circuit
   4 combinators.short-circuit.smart math.order math.functions
   5 definitions compiler.units fry lexer words.symbol ;
   6 IN: locals.tests
   7
   8 :: foo ( a b -- a a ) a a ;
   9
  10 [ 1 1 ] [ 1 2 foo ] unit-test
  11
  12 :: add-test ( a b -- c ) a b + ;
  13
  14 [ 3 ] [ 1 2 add-test ] unit-test
  15
  16 :: sub-test ( a b -- c ) a b - ;
  17
  18 [ -1 ] [ 1 2 sub-test ] unit-test
  19
  20 :: map-test ( a b -- seq ) a [ b + ] map ;
  21
  22 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
  23
  24 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
  25
  26 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
  27
  28 :: let-test ( c -- d )
  29     [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
  30
  31 [ 7 ] [ 4 let-test ] unit-test
  32
  33 :: let-test-2 ( a -- a )
  34     a [let | a [ ] | [let | b [ a ] | a ] ] ;
  35
  36 [ 3 ] [ 3 let-test-2 ] unit-test
  37
  38 :: let-test-3 ( a -- a )
  39     a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
  40
  41 :: let-test-4 ( a -- b )
  42     a [let | a [ 1 ] b [ ] | a b 2array ] ;
  43
  44 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
  45
  46 :: let-test-5 ( a -- b )
  47     a [let | a [ ] b [ ] | a b 2array ] ;
  48
  49 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
  50
  51 :: let-test-6 ( a -- b )
  52     a [let | a [ ] b [ 1 ] | a b 2array ] ;
  53
  54 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
  55
  56 [ -1 ] [ -1 let-test-3 call ] unit-test
  57
  58 [ 5 ] [
  59     [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
  60 ] unit-test
  61
  62 :: wlet-test-2 ( a b -- seq )
  63     [wlet | add-b [ b + ] |
  64         a [ add-b ] map ] ;
  65
  66
  67 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
  68
  69 :: wlet-test-3 ( a -- b )
  70     [wlet | add-a [ a + ] | [ add-a ] ]
  71     [let | a [ 3 ] | a swap call ] ;
  72
  73 [ 5 ] [ 2 wlet-test-3 ] unit-test
  74
  75 :: wlet-test-4 ( a -- b )
  76     [wlet | sub-a [| b | b a - ] |
  77         3 sub-a ] ;
  78
  79 [ -7 ] [ 10 wlet-test-4 ] unit-test
  80
  81 :: write-test-1 ( n! -- q )
  82     [| i | n i + dup n! ] ;
  83
  84 0 write-test-1 "q" set
  85
  86 { 1 1 } "q" get must-infer-as
  87
  88 [ 1 ] [ 1 "q" get call ] unit-test
  89
  90 [ 2 ] [ 1 "q" get call ] unit-test
  91
  92 [ 3 ] [ 1 "q" get call ] unit-test
  93
  94 [ 5 ] [ 2 "q" get call ] unit-test
  95
  96 :: write-test-2 ( -- q )
  97     [let | n! [ 0 ] |
  98         [| i | n i + dup n! ] ] ;
  99
 100 write-test-2 "q" set
 101
 102 [ 1 ] [ 1 "q" get call ] unit-test
 103
 104 [ 2 ] [ 1 "q" get call ] unit-test
 105
 106 [ 3 ] [ 1 "q" get call ] unit-test
 107
 108 [ 5 ] [ 2 "q" get call ] unit-test
 109
 110 [ 10 20 ]
 111 [
 112     20 10 [| a! | [| b! | a b ] ] call call
 113 ] unit-test
 114
 115 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
 116
 117 [ ] [ 1 2 write-test-3 call ] unit-test
 118
 119 :: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
 120
 121 [ ] [ 5 write-test-4 drop ] unit-test
 122
 123 ! Not really a write test; just enforcing consistency
 124 :: write-test-5 ( x -- y )
 125     [wlet | fun! [ x + ] | 5 fun! ] ;
 126
 127 [ 9 ] [ 4 write-test-5 ] unit-test
 128
 129 SYMBOL: a
 130
 131 :: use-test ( a b c -- a b c )
 132     USE: kernel ;
 133
 134 [ t ] [ a symbol? ] unit-test
 135
 136 :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
 137
 138 [ 13 ] [ 10 let-let-test ] unit-test
 139
 140 GENERIC: lambda-generic ( a b -- c )
 141
 142 GENERIC# lambda-generic-1 1 ( a b -- c )
 143
 144 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
 145
 146 M:: string lambda-generic-1 ( a b -- c )
 147     a b CHAR: x <string> lambda-generic ;
 148
 149 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
 150
 151 GENERIC# lambda-generic-2 1 ( a b -- c )
 152
 153 M:: integer lambda-generic-2 ( a b -- c )
 154     a CHAR: x <string> b lambda-generic ;
 155
 156 M:: string lambda-generic-2 ( a b -- c ) a b append ;
 157
 158 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 159
 160 [ 10 ] [ 5 2 lambda-generic ] unit-test
 161
 162 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
 163
 164 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
 165
 166 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
 167
 168 [ ] [ \ lambda-generic-1 see ] unit-test
 169
 170 [ ] [ \ lambda-generic-2 see ] unit-test
 171
 172 [ ] [ \ lambda-generic see ] unit-test
 173
 174 :: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
 175
 176 [ "[let | a! [ ] | ]" ] [
 177     \ unparse-test-1 "lambda" word-prop body>> first unparse
 178 ] unit-test
 179
 180 :: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
 181
 182 [ "[wlet | a! [ ] | ]" ] [
 183     \ unparse-test-2 "lambda" word-prop body>> first unparse
 184 ] unit-test
 185
 186 :: unparse-test-3 ( -- b ) [| a! | ] ;
 187
 188 [ "[| a! | ]" ] [
 189     \ unparse-test-3 "lambda" word-prop body>> first unparse
 190 ] unit-test
 191
 192 DEFER: xyzzy
 193
 194 [ ] [
 195     "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
 196     <string-reader> "lambda-generic-test" parse-stream drop
 197 ] unit-test
 198
 199 [ 10 ] [ 10 xyzzy ] unit-test
 200
 201 [ ] [
 202     "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
 203     <string-reader> "lambda-generic-test" parse-stream drop
 204 ] unit-test
 205
 206 [ 5 ] [ 10 xyzzy ] unit-test
 207
 208 :: let*-test-1 ( a -- b )
 209     [let* | b [ a 1+ ]
 210             c [ b 1+ ] |
 211         a b c 3array ] ;
 212
 213 [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
 214
 215 :: let*-test-2 ( a -- b )
 216     [let* | b [ a 1+ ]
 217             c! [ b 1+ ] |
 218         a b c 3array ] ;
 219
 220 [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
 221
 222 :: let*-test-3 ( a -- b )
 223     [let* | b [ a 1+ ]
 224             c! [ b 1+ ] |
 225         c 1+ c!  a b c 3array ] ;
 226
 227 [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
 228
 229 :: let*-test-4 ( a b -- c d )
 230     [let | a [ b ]
 231            b [ a ] |
 232         [let* | a'  [ a  ]
 233                 a'' [ a' ]
 234                 b'  [ b  ]
 235                 b'' [ b' ] |
 236             a'' b'' ] ] ;
 237
 238 [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
 239
 240 GENERIC: next-method-test ( a -- b )
 241
 242 M: integer next-method-test 3 + ;
 243
 244 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 245
 246 [ 5 ] [ 1 next-method-test ] unit-test
 247
 248 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
 249
 250 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
 251
 252 { 3 0 } [| a b c | ] must-infer-as
 253
 254 [ ] [ 1 [let | a [ ] | ] ] unit-test
 255
 256 [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
 257
 258 [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
 259
 260 :: a-word-with-locals ( a b -- ) ;
 261
 262 : new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
 263
 264 [ ] [ new-definition eval ] unit-test
 265
 266 [ t ] [
 267     [ \ a-word-with-locals see ] with-string-writer
 268     new-definition =
 269 ] unit-test
 270
 271 : method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
 272
 273 GENERIC: method-with-locals ( x -- y )
 274
 275 M:: sequence method-with-locals ( a -- y ) a reverse ;
 276
 277 [ t ] [
 278     [ \ sequence \ method-with-locals method see ] with-string-writer
 279     method-definition =
 280 ] unit-test
 281
 282 :: cond-test ( a b -- c )
 283     {
 284         { [ a b < ] [ 3 ] }
 285         { [ a b = ] [ 4 ] }
 286         { [ a b > ] [ 5 ] }
 287     } cond ;
 288
 289 \ cond-test must-infer
 290
 291 [ 3 ] [ 1 2 cond-test ] unit-test
 292 [ 4 ] [ 2 2 cond-test ] unit-test
 293 [ 5 ] [ 3 2 cond-test ] unit-test
 294
 295 :: 0&&-test ( a -- ? )
 296     { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
 297
 298 \ 0&&-test must-infer
 299
 300 [ f ] [ 1.5 0&&-test ] unit-test
 301 [ f ] [ 3 0&&-test ] unit-test
 302 [ f ] [ 8 0&&-test ] unit-test
 303 [ t ] [ 12 0&&-test ] unit-test
 304
 305 :: &&-test ( a -- ? )
 306     { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
 307
 308 \ &&-test must-infer
 309
 310 [ f ] [ 1.5 &&-test ] unit-test
 311 [ f ] [ 3 &&-test ] unit-test
 312 [ f ] [ 8 &&-test ] unit-test
 313 [ t ] [ 12 &&-test ] unit-test
 314
 315 :: let-and-cond-test-1 ( -- a )
 316     [let | a [ 10 ] |
 317         [let | a [ 20 ] |
 318             {
 319                 { [ t ] [ [let | c [ 30 ] | a ] ] }
 320             } cond
 321         ]
 322     ] ;
 323
 324 \ let-and-cond-test-1 must-infer
 325
 326 [ 20 ] [ let-and-cond-test-1 ] unit-test
 327
 328 :: let-and-cond-test-2 ( -- pair )
 329     [let | A [ 10 ] |
 330         [let | B [ 20 ] |
 331             { { [ t ] [ { A B } ] } } cond
 332         ]
 333     ] ;
 334
 335 \ let-and-cond-test-2 must-infer
 336
 337 [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
 338
 339 [ { 10       } ] [ 10       [| a     | { a     } ] call ] unit-test
 340 [ { 10 20    } ] [ 10 20    [| a b   | { a b   } ] call ] unit-test
 341 [ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
 342
 343 [ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
 344
 345 [ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
 346
 347 [ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
 348 [ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
 349
 350 [ T{ slice f 0 3 "abc" } ]
 351 [ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
 352
 353 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
 354
 355 ERROR: punned-class x ;
 356
 357 [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
 358
 359 :: literal-identity-test ( -- a b )
 360     { } V{ } ;
 361
 362 [ t f ] [
 363     literal-identity-test
 364     literal-identity-test
 365     swapd [ eq? ] [ eq? ] 2bi*
 366 ] unit-test
 367
 368 :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
 369
 370 [ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test
 371
 372 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
 373     obj1 obj2 <=> {
 374         { +lt+ [ lt-quot call ] }
 375         { +eq+ [ eq-quot call ] }
 376         { +gt+ [ gt-quot call ] }
 377     } case ; inline
 378
 379 [ [ ] [ ] [ ] compare-case ] must-infer
 380
 381 :: big-case-test ( a -- b )
 382     a {
 383         { 0 [ a 1 + ] }
 384         { 1 [ a 1 - ] }
 385         { 2 [ a 1 swap / ] }
 386         { 3 [ a dup * ] }
 387         { 4 [ a sqrt ] }
 388         { 5 [ a a ^ ] }
 389     } case ;
 390
 391 \ big-case-test must-infer
 392
 393 [ 9 ] [ 3 big-case-test ] unit-test
 394
 395 GENERIC: lambda-method-forget-test ( a -- b )
 396
 397 M:: integer lambda-method-forget-test ( a -- b ) ;
 398
 399 [ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
 400
 401 [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
 402
 403 [
 404     "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
 405 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
 406
 407 :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
 408 : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
 409
 410 \ funny-macro-test must-infer
 411
 412 [ t ] [ 3 funny-macro-test ] unit-test
 413 [ f ] [ 2 funny-macro-test ] unit-test
 414
 415 ! Some odd parser corner cases
 416 [ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
 417 [ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
 418 [ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
 419 [ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
 420
 421 [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
 422 [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
 423
 424 :: FAILdog-1 ( -- b ) { [| c | c ] } ;
 425
 426 \ FAILdog-1 must-infer
 427
 428 :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
 429
 430 \ FAILdog-2 must-infer
 431
 432 [ 3 ] [ 3 [| a | \ a ] call ] unit-test
 433
 434 [ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
 435
 436 [ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
 437
 438 [ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
 439
 440 [ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
 441
 442 [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
 443
 444 [ "USE: locals [| | { :> a } ]" eval ] must-fail
 445
 446 [ "USE: locals 3 :> a" eval ] must-fail
 447
 448 [ 3 ] [ 3 [| | :> a a ] call ] unit-test
 449
 450 [ 3 ] [ 3 [| | :> a! a ] call ] unit-test
 451
 452 [ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
 453
 454 :: wlet-&&-test ( a -- ? )
 455     [wlet | is-integer? [ a integer? ]
 456             is-even? [ a even? ]
 457             >10? [ a 10 > ] |
 458         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
 459     ] ;
 460
 461 \ wlet-&&-test must-infer
 462 [ f ] [ 1.5 wlet-&&-test ] unit-test
 463 [ f ] [ 3 wlet-&&-test ] unit-test
 464 [ f ] [ 8 wlet-&&-test ] unit-test
 465 [ t ] [ 12 wlet-&&-test ] unit-test
 466
 467 : fry-locals-test-1 ( -- n )
 468     [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
 469
 470 \ fry-locals-test-1 must-infer
 471 [ 10 ] [ fry-locals-test-1 ] unit-test
 472
 473 :: fry-locals-test-2 ( -- n )
 474     [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
 475
 476 \ fry-locals-test-2 must-infer
 477 [ 10 ] [ fry-locals-test-2 ] unit-test
 478
 479 [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
 480 [ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
 481 [ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
 482 [ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
 483 [ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
 484 [ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
 485
 486 [ { 1 2 3 4 } ] [
 487     1 3 2 4
 488     [| | '[ [| a b | a _ b _ 4array ] call ] call ] call
 489 ] unit-test
 490
 491 [ 10 ] [
 492     [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
 493 ] unit-test
 494
 495 ! Discovered by littledan
 496 [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
 497 [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
 498
 499 [ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
 500
 501 [ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
 502
 503 [ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test