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 ;
8 :: foo ( a b -- a a ) a a ;
10 [ 1 1 ] [ 1 2 foo ] unit-test
12 :: add-test ( a b -- c ) a b + ;
14 [ 3 ] [ 1 2 add-test ] unit-test
16 :: sub-test ( a b -- c ) a b - ;
18 [ -1 ] [ 1 2 sub-test ] unit-test
20 :: map-test ( a b -- seq ) a [ b + ] map ;
22 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
24 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
26 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
28 :: let-test ( c -- d )
29 [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
31 [ 7 ] [ 4 let-test ] unit-test
33 :: let-test-2 ( a -- a )
34 a [let | a [ ] | [let | b [ a ] | a ] ] ;
36 [ 3 ] [ 3 let-test-2 ] unit-test
38 :: let-test-3 ( a -- a )
39 a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
41 :: let-test-4 ( a -- b )
42 a [let | a [ 1 ] b [ ] | a b 2array ] ;
44 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
46 :: let-test-5 ( a b -- b )
47 a b [let | a [ ] b [ ] | a b 2array ] ;
49 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
51 :: let-test-6 ( a -- b )
52 a [let | a [ ] b [ 1 ] | a b 2array ] ;
54 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
56 [ -1 ] [ -1 let-test-3 call ] unit-test
59 [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
62 :: wlet-test-2 ( a b -- seq )
63 [wlet | add-b [ b + ] |
67 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
69 :: wlet-test-3 ( a -- b )
70 [wlet | add-a [ a + ] | [ add-a ] ]
71 [let | a [ 3 ] | a swap call ] ;
73 [ 5 ] [ 2 wlet-test-3 ] unit-test
75 :: wlet-test-4 ( a -- b )
76 [wlet | sub-a [| b | b a - ] |
79 [ -7 ] [ 10 wlet-test-4 ] unit-test
81 :: write-test-1 ( n! -- q )
82 [| i | n i + dup n! ] ;
84 0 write-test-1 "q" set
86 { 1 1 } "q" get must-infer-as
88 [ 1 ] [ 1 "q" get call ] unit-test
90 [ 2 ] [ 1 "q" get call ] unit-test
92 [ 3 ] [ 1 "q" get call ] unit-test
94 [ 5 ] [ 2 "q" get call ] unit-test
96 :: write-test-2 ( -- q )
98 [| i | n i + dup n! ] ] ;
102 [ 1 ] [ 1 "q" get call ] unit-test
104 [ 2 ] [ 1 "q" get call ] unit-test
106 [ 3 ] [ 1 "q" get call ] unit-test
108 [ 5 ] [ 2 "q" get call ] unit-test
112 20 10 [| a! | [| b! | a b ] ] call call
115 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
117 [ ] [ 1 2 write-test-3 call ] unit-test
119 :: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
121 [ ] [ 5 write-test-4 drop ] unit-test
123 ! Not really a write test; just enforcing consistency
124 :: write-test-5 ( x -- y )
125 [wlet | fun! [ x + ] | 5 fun! ] ;
127 [ 9 ] [ 4 write-test-5 ] unit-test
131 :: use-test ( a b c -- a b c )
135 [ t ] [ a symbol? ] unit-test
137 :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
139 [ 13 ] [ 10 let-let-test ] unit-test
141 GENERIC: lambda-generic ( a b -- c )
143 GENERIC# lambda-generic-1 1 ( a b -- c )
145 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
147 M:: string lambda-generic-1 ( a b -- c )
148 a b CHAR: x <string> lambda-generic ;
150 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
152 GENERIC# lambda-generic-2 1 ( a b -- c )
154 M:: integer lambda-generic-2 ( a b -- c )
155 a CHAR: x <string> b lambda-generic ;
157 M:: string lambda-generic-2 ( a b -- c ) a b append ;
159 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
161 [ 10 ] [ 5 2 lambda-generic ] unit-test
163 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
165 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
167 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
169 [ ] [ \ lambda-generic-1 see ] unit-test
171 [ ] [ \ lambda-generic-2 see ] unit-test
173 [ ] [ \ lambda-generic see ] unit-test
175 :: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
177 [ "[let | a! [ 3 ] | ]" ] [
178 \ unparse-test-1 "lambda" word-prop body>> first unparse
181 :: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
183 [ "[wlet | a! [ ] | ]" ] [
184 \ unparse-test-2 "lambda" word-prop body>> first unparse
187 :: unparse-test-3 ( -- b ) [| a! | ] ;
190 \ unparse-test-3 "lambda" word-prop body>> first unparse
196 "IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
197 <string-reader> "lambda-generic-test" parse-stream drop
200 [ 10 ] [ 10 xyzzy ] unit-test
203 "IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
204 <string-reader> "lambda-generic-test" parse-stream drop
207 [ 5 ] [ 10 xyzzy ] unit-test
209 :: let*-test-1 ( a -- b )
214 [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
216 :: let*-test-2 ( a -- b )
221 [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
223 :: let*-test-3 ( a -- b )
226 c 1+ c! a b c 3array ] ;
228 [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
230 :: let*-test-4 ( a b -- c d )
239 [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
241 GENERIC: next-method-test ( a -- b )
243 M: integer next-method-test 3 + ;
245 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
247 [ 5 ] [ 1 next-method-test ] unit-test
249 : no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
251 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
253 { 3 0 } [| a b c | ] must-infer-as
255 [ ] [ 1 [let | a [ ] | ] ] unit-test
257 [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
259 [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
261 :: a-word-with-locals ( a b -- ) ;
263 CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
265 [ ] [ new-definition eval( -- ) ] unit-test
268 [ \ a-word-with-locals see ] with-string-writer
272 CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
274 GENERIC: method-with-locals ( x -- y )
276 M:: sequence method-with-locals ( a -- y ) a reverse ;
279 [ \ sequence \ method-with-locals method see ] with-string-writer
283 :: cond-test ( a b -- c )
290 \ cond-test def>> must-infer
292 [ 3 ] [ 1 2 cond-test ] unit-test
293 [ 4 ] [ 2 2 cond-test ] unit-test
294 [ 5 ] [ 3 2 cond-test ] unit-test
296 :: 0&&-test ( a -- ? )
297 { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
299 \ 0&&-test def>> must-infer
301 [ f ] [ 1.5 0&&-test ] unit-test
302 [ f ] [ 3 0&&-test ] unit-test
303 [ f ] [ 8 0&&-test ] unit-test
304 [ t ] [ 12 0&&-test ] unit-test
306 :: &&-test ( a -- ? )
307 { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
309 \ &&-test def>> must-infer
311 [ f ] [ 1.5 &&-test ] unit-test
312 [ f ] [ 3 &&-test ] unit-test
313 [ f ] [ 8 &&-test ] unit-test
314 [ t ] [ 12 &&-test ] unit-test
316 :: let-and-cond-test-1 ( -- a )
320 { [ t ] [ [let | c [ 30 ] | a ] ] }
325 \ let-and-cond-test-1 def>> must-infer
327 [ 20 ] [ let-and-cond-test-1 ] unit-test
329 :: let-and-cond-test-2 ( -- pair )
332 { { [ t ] [ { A B } ] } } cond
336 \ let-and-cond-test-2 def>> must-infer
338 [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
340 [ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
341 [ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
342 [ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
344 [ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
346 [ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
348 [ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
349 [ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
351 [ T{ slice f 0 3 "abc" } ]
352 [ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
354 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
356 ERROR: punned-class x ;
358 [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
360 :: literal-identity-test ( -- a b )
364 literal-identity-test
365 literal-identity-test
366 [ eq? ] [ eq? ] bi-curry* bi*
369 :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
371 [ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test
373 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
375 { +lt+ [ lt-quot call ] }
376 { +eq+ [ eq-quot call ] }
377 { +gt+ [ gt-quot call ] }
380 [ [ ] [ ] [ ] compare-case ] must-infer
382 :: big-case-test ( a -- b )
392 \ big-case-test def>> must-infer
394 [ 9 ] [ 3 big-case-test ] unit-test
396 ! Dan found this problem
397 : littledan-case-problem-1 ( a -- b )
401 [| x | x 12 + { "howdy" } nth ]
404 \ littledan-case-problem-1 def>> must-infer
406 [ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
407 [ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
409 :: littledan-case-problem-2 ( a -- b )
413 [| x | x a - { "howdy" } nth ]
416 \ littledan-case-problem-2 def>> must-infer
418 [ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
419 [ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
421 :: littledan-cond-problem-1 ( a -- b )
423 { [ dup 0 < ] [ drop a not ] }
424 { [| y | y y 0 > ] [ drop 4 ] }
425 [| x | x a - { "howdy" } nth ]
428 \ littledan-cond-problem-1 def>> must-infer
430 [ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
431 [ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
432 [ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test
433 [ f ] [ -12 littledan-cond-problem-1 ] unit-test
434 [ 4 ] [ 12 littledan-cond-problem-1 ] unit-test
435 [ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test
438 :: littledan-case-problem-3 ( a quot -- b )
445 [ f ] [ t [ ] littledan-case-problem-3 ] unit-test
446 [ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test
447 [| | [| a | a ] littledan-case-problem-3 ] must-infer
449 : littledan-case-problem-4 ( a -- b )
450 [ 1 + ] littledan-case-problem-3 ;
452 \ littledan-case-problem-4 def>> must-infer
455 GENERIC: lambda-method-forget-test ( a -- b )
457 M:: integer lambda-method-forget-test ( a -- b ) a ;
459 [ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
461 [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
464 "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
466 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
468 :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
469 : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
471 \ funny-macro-test def>> must-infer
473 [ t ] [ 3 funny-macro-test ] unit-test
474 [ f ] [ 2 funny-macro-test ] unit-test
476 ! Some odd parser corner cases
477 [ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
478 [ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
479 [ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
480 [ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
482 [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
483 [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
485 :: FAILdog-1 ( -- b ) { [| c | c ] } ;
487 \ FAILdog-1 def>> must-infer
489 :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
491 \ FAILdog-2 def>> must-infer
493 [ 3 ] [ 3 [| a | \ a ] call ] unit-test
495 [ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
497 [ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
499 [ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
501 [ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
503 [ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
505 [ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
507 [ "USE: locals 3 :> a" eval( -- ) ] must-fail
509 [ 3 ] [ 3 [| | :> a a ] call ] unit-test
511 [ 3 ] [ 3 [| | :> a! a ] call ] unit-test
513 [ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
515 :: wlet-&&-test ( a -- ? )
516 [wlet | is-integer? [ a integer? ]
519 { [ is-integer? ] [ is-even? ] [ >10? ] } &&
522 \ wlet-&&-test def>> must-infer
523 [ f ] [ 1.5 wlet-&&-test ] unit-test
524 [ f ] [ 3 wlet-&&-test ] unit-test
525 [ f ] [ 8 wlet-&&-test ] unit-test
526 [ t ] [ 12 wlet-&&-test ] unit-test
528 : fry-locals-test-1 ( -- n )
529 [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
531 \ fry-locals-test-1 def>> must-infer
532 [ 10 ] [ fry-locals-test-1 ] unit-test
534 :: fry-locals-test-2 ( -- n )
535 [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
537 \ fry-locals-test-2 def>> must-infer
538 [ 10 ] [ fry-locals-test-2 ] unit-test
540 [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
541 [ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
542 [ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
543 [ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
544 [ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
545 [ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
549 [| | '[ [| a b | a _ b _ 4array ] call ] call ] call
553 [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
556 ! littledan found this problem
557 [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
558 [ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
560 [ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
562 [ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
564 [ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
566 ! erg found this problem
567 :: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
569 [ 3 ] [ 3 f erg's-:>-bug ] unit-test
571 [ 3 ] [ 3 t erg's-:>-bug ] unit-test
573 :: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
575 [ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
577 [ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test
579 ! dharmatech found this problem
580 GENERIC: ed's-bug ( a -- b )
582 M: string ed's-bug reverse ;
583 M: integer ed's-bug neg ;
585 :: ed's-test-case ( a -- b )
586 { [ a ed's-bug ] } && ;
588 [ t ] [ \ ed's-test-case optimized? ] unit-test