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