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
9 :: foo ( a b -- a a ) a a ;
11 [ 1 1 ] [ 1 2 foo ] unit-test
13 :: add-test ( a b -- c ) a b + ;
15 [ 3 ] [ 1 2 add-test ] unit-test
17 :: sub-test ( a b -- c ) a b - ;
19 [ -1 ] [ 1 2 sub-test ] unit-test
21 :: map-test ( a b -- seq ) a [ b + ] map ;
23 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
25 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
27 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
29 :: let-test ( c -- d )
30 [let 1 :> a 2 :> b a b + c + ] ;
32 [ 7 ] [ 4 let-test ] unit-test
34 :: let-test-2 ( a -- a )
35 a [let :> a [let a :> b a ] ] ;
37 [ 3 ] [ 3 let-test-2 ] unit-test
39 :: let-test-3 ( a -- a )
40 a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ;
42 :: let-test-4 ( a -- b )
43 a [let 1 :> a :> b a b 2array ] ;
45 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
47 :: let-test-5 ( a b -- b )
48 a b [let :> a :> b a b 2array ] ;
50 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
52 :: let-test-6 ( a -- b )
53 a [let :> a 1 :> b a b 2array ] ;
55 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
57 [ -1 ] [ -1 let-test-3 call ] unit-test
59 :: write-test-1 ( n! -- q )
60 [| i | n i + dup n! ] ;
62 0 write-test-1 "q" set
64 { 1 1 } "q" get must-infer-as
66 [ 1 ] [ 1 "q" get call ] unit-test
68 [ 2 ] [ 1 "q" get call ] unit-test
70 [ 3 ] [ 1 "q" get call ] unit-test
72 [ 5 ] [ 2 "q" get call ] unit-test
74 :: write-test-2 ( -- q )
75 [let 0 :> n! [| i | n i + dup n! ] ] ;
79 [ 1 ] [ 1 "q" get call ] unit-test
81 [ 2 ] [ 1 "q" get call ] unit-test
83 [ 3 ] [ 1 "q" get call ] unit-test
85 [ 5 ] [ 2 "q" get call ] unit-test
89 20 10 [| a! | [| b! | a b ] ] call call
92 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
94 [ ] [ 1 2 write-test-3 call ] unit-test
96 :: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ;
98 [ ] [ 5 write-test-4 drop ] unit-test
100 :: let-let-test ( n -- n ) [let n 3 + :> n n ] ;
102 [ 13 ] [ 10 let-let-test ] unit-test
104 GENERIC: lambda-generic ( a b -- c )
106 GENERIC# lambda-generic-1 1 ( a b -- c )
108 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
110 M:: string lambda-generic-1 ( a b -- c )
111 a b CHAR: x <string> lambda-generic ;
113 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
115 GENERIC# lambda-generic-2 1 ( a b -- c )
117 M:: integer lambda-generic-2 ( a b -- c )
118 a CHAR: x <string> b lambda-generic ;
120 M:: string lambda-generic-2 ( a b -- c ) a b append ;
122 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
124 [ 10 ] [ 5 2 lambda-generic ] unit-test
126 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
128 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
130 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
132 [ ] [ \ lambda-generic-1 see ] unit-test
134 [ ] [ \ lambda-generic-2 see ] unit-test
136 [ ] [ \ lambda-generic see ] unit-test
138 :: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ;
140 [ "[let 3 :> a! 4 :> b ]" ] [
141 \ unparse-test-1 "lambda" word-prop body>> first unparse
144 :: unparse-test-3 ( -- b ) [| a! | ] ;
147 \ unparse-test-3 "lambda" word-prop body>> first unparse
153 "IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
154 <string-reader> "lambda-generic-test" parse-stream drop
157 [ 10 ] [ 10 xyzzy ] unit-test
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
164 [ 5 ] [ 10 xyzzy ] unit-test
166 GENERIC: next-method-test ( a -- b )
168 M: integer next-method-test 3 + ;
170 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
172 [ 5 ] [ 1 next-method-test ] unit-test
174 : no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
176 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
178 { 3 0 } [| a b c | ] must-infer-as
180 [ ] [ 1 [let :> a ] ] unit-test
182 [ 3 ] [ 1 [let :> a 3 ] ] unit-test
184 [ ] [ 1 2 [let :> a :> b ] ] unit-test
186 :: a-word-with-locals ( a b -- ) ;
188 CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
190 [ ] [ new-definition eval( -- ) ] unit-test
193 [ \ a-word-with-locals see ] with-string-writer
197 CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
199 GENERIC: method-with-locals ( x -- y )
201 M:: sequence method-with-locals ( a -- y ) a reverse ;
204 [ \ sequence \ method-with-locals lookup-method see ] with-string-writer
208 :: cond-test ( a b -- c )
215 \ cond-test def>> must-infer
217 [ 3 ] [ 1 2 cond-test ] unit-test
218 [ 4 ] [ 2 2 cond-test ] unit-test
219 [ 5 ] [ 3 2 cond-test ] unit-test
221 :: 0&&-test ( a -- ? )
222 { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
224 \ 0&&-test def>> must-infer
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
231 :: &&-test ( a -- ? )
232 { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
234 \ &&-test def>> must-infer
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
241 :: let-and-cond-test-1 ( -- a )
245 { [ t ] [ [let 30 :> c a ] ] }
250 \ let-and-cond-test-1 def>> must-infer
252 [ 20 ] [ let-and-cond-test-1 ] unit-test
254 :: let-and-cond-test-2 ( -- pair )
257 { { [ t ] [ { A B } ] } } cond
261 \ let-and-cond-test-2 def>> must-infer
263 [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
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
269 [ { 10 20 30 } ] [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
271 [ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
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
276 [ T{ slice f 0 3 "abc" } ]
277 [ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
279 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
281 ERROR: punned-class x ;
283 [ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
285 :: literal-identity-test ( -- a b )
289 literal-identity-test
290 literal-identity-test
291 [ eq? ] [ eq? ] bi-curry* bi*
294 :: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
296 [ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test
298 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
300 { +lt+ [ lt-quot call ] }
301 { +eq+ [ eq-quot call ] }
302 { +gt+ [ gt-quot call ] }
305 [ [ ] [ ] [ ] compare-case ] must-infer
307 :: big-case-test ( a -- b )
317 \ big-case-test def>> must-infer
319 [ 9 ] [ 3 big-case-test ] unit-test
321 ! Dan found this problem
322 : littledan-case-problem-1 ( a -- b )
326 [| x | x 12 + { "howdy" } nth ]
329 \ littledan-case-problem-1 def>> must-infer
331 [ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
332 [ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
334 :: littledan-case-problem-2 ( a -- b )
338 [| x | x a - { "howdy" } nth ]
341 \ littledan-case-problem-2 def>> must-infer
343 [ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
344 [ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
346 :: littledan-cond-problem-1 ( a -- b )
348 { [ dup 0 < ] [ drop a not ] }
349 { [| y | y y 0 > ] [ drop 4 ] }
350 [| x | x a - { "howdy" } nth ]
353 \ littledan-cond-problem-1 def>> must-infer
355 [ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
356 [ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
357 [ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test
358 [ f ] [ -12 littledan-cond-problem-1 ] unit-test
359 [ 4 ] [ 12 littledan-cond-problem-1 ] unit-test
360 [ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test
363 :: littledan-case-problem-3 ( a quot -- b )
370 [ f ] [ t [ ] littledan-case-problem-3 ] unit-test
371 [ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test
372 [| | [| a | a ] littledan-case-problem-3 ] must-infer
374 : littledan-case-problem-4 ( a -- b )
375 [ 1 + ] littledan-case-problem-3 ;
377 \ littledan-case-problem-4 def>> must-infer
380 GENERIC: lambda-method-forget-test ( a -- b )
382 M:: integer lambda-method-forget-test ( a -- b ) a ;
384 [ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
386 [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
389 "USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]"
391 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
393 :: (funny-macro-test) ( obj quot -- ? ) obj { [ quot call ] } 1&& ; inline
394 : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
396 \ funny-macro-test def>> must-infer
398 [ t ] [ 3 funny-macro-test ] unit-test
399 [ f ] [ 2 funny-macro-test ] unit-test
401 [ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
402 [ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
404 [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
405 [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
407 :: FAILdog-1 ( -- b ) { [| c | c ] } ;
409 \ FAILdog-1 def>> must-infer
411 :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
413 \ FAILdog-2 def>> must-infer
415 [ 3 ] [ 3 [| a | \ a ] call ] unit-test
417 [ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail
419 [ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
421 [ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
423 [ "USE: locals 3 :> a" eval( -- ) ] must-fail
425 [ 3 ] [ 3 [| | :> a a ] call ] unit-test
427 [ 3 ] [ 3 [| | :> a! a ] call ] unit-test
429 [ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
431 : fry-locals-test-1 ( -- n )
432 [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
434 \ fry-locals-test-1 def>> must-infer
435 [ 10 ] [ fry-locals-test-1 ] unit-test
437 :: fry-locals-test-2 ( -- n )
438 [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
440 \ fry-locals-test-2 def>> must-infer
441 [ 10 ] [ fry-locals-test-2 ] unit-test
443 [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
444 [ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
445 [ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
446 [ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
447 [ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
448 [ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
452 [| | '[ [| a b | a _ b _ 4array ] call ] call ] call
456 [| | 0 '[ [let 10 :> A A _ + ] ] call ] call
459 ! littledan found this problem
460 [ "bar" ] [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test
461 [ 10 ] [ [let 10 :> a [let a :> b b ] ] ] unit-test
463 [ { \ + } ] [ [let \ + :> x { \ x } ] ] unit-test
465 [ { \ + 3 } ] [ [let 3 :> a { \ + a } ] ] unit-test
467 [ 3 ] [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
469 ! erg found this problem
470 :: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
472 [ 3 ] [ 3 f erg's-:>-bug ] unit-test
474 [ 3 ] [ 3 t erg's-:>-bug ] unit-test
476 :: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
478 [ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
480 [ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test
482 ! dharmatech found this problem
483 GENERIC: ed's-bug ( a -- b )
485 M: string ed's-bug reverse ;
486 M: integer ed's-bug neg ;
488 :: ed's-test-case ( a -- b )
489 { [ a ed's-bug ] } && ;
491 [ t ] [ \ ed's-test-case optimized? ] unit-test
494 [ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test
496 ! Test smart combinators and locals interaction
497 :: smart-combinator-locals ( a b c -- seq ) [ a b c ] output>array ;
499 [ { 1 2 3 } ] [ 1 2 3 smart-combinator-locals ] unit-test