1 USING: locals math sequences tools.test hashtables words kernel
2 namespaces arrays strings prettyprint io.streams.string parser
6 :: foo ( a b -- a a ) a a ;
8 [ 1 1 ] [ 1 2 foo ] unit-test
10 :: add-test ( a b -- c ) a b + ;
12 [ 3 ] [ 1 2 add-test ] unit-test
14 :: sub-test ( a b -- c ) a b - ;
16 [ -1 ] [ 1 2 sub-test ] unit-test
18 :: map-test ( a b -- seq ) a [ b + ] map ;
20 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
22 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
24 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
26 :: let-test ( c -- d )
27 [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
29 [ 7 ] [ 4 let-test ] unit-test
31 :: let-test-2 ( a -- a )
32 a [let | a [ ] | [let | b [ a ] | a ] ] ;
34 [ 3 ] [ 3 let-test-2 ] unit-test
36 :: let-test-3 ( a -- a )
37 a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
39 :: let-test-4 ( a -- b )
40 a [let | a [ 1 ] b [ ] | a b 2array ] ;
42 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
44 :: let-test-5 ( a -- b )
45 a [let | a [ ] b [ ] | a b 2array ] ;
47 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
49 :: let-test-6 ( a -- b )
50 a [let | a [ ] b [ 1 ] | a b 2array ] ;
52 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
54 [ -1 ] [ -1 let-test-3 call ] unit-test
57 [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
60 :: wlet-test-2 ( a b -- seq )
61 [wlet | add-b [ b + ] |
65 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
67 :: wlet-test-3 ( a -- b )
68 [wlet | add-a [ a + ] | [ add-a ] ]
69 [let | a [ 3 ] | a swap call ] ;
71 [ 5 ] [ 2 wlet-test-3 ] unit-test
73 :: wlet-test-4 ( a -- b )
74 [wlet | sub-a [| b | b a - ] |
77 [ -7 ] [ 10 wlet-test-4 ] unit-test
79 :: write-test-1 ( n! -- q )
80 [| i | n i + dup n! ] ;
82 0 write-test-1 "q" set
84 { 1 1 } "q" get must-infer-as
86 [ 1 ] [ 1 "q" get call ] unit-test
88 [ 2 ] [ 1 "q" get call ] unit-test
90 [ 3 ] [ 1 "q" get call ] unit-test
92 [ 5 ] [ 2 "q" get call ] unit-test
94 :: write-test-2 ( -- q )
96 [| i | n i + dup n! ] ] ;
100 [ 1 ] [ 1 "q" get call ] unit-test
102 [ 2 ] [ 1 "q" get call ] unit-test
104 [ 3 ] [ 1 "q" get call ] unit-test
106 [ 5 ] [ 2 "q" get call ] unit-test
110 20 10 [| a! | [| b! | a b ] ] call call
113 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
115 [ ] [ 1 2 write-test-3 call ] unit-test
117 :: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
119 [ ] [ 5 write-test-4 drop ] unit-test
121 ! Not really a write test; just enforcing consistency
122 :: write-test-5 ( x -- y )
123 [wlet | fun! [ x + ] | 5 fun! ] ;
125 [ 9 ] [ 4 write-test-5 ] unit-test
129 :: use-test ( a b c -- a b c )
132 [ t ] [ a symbol? ] unit-test
134 :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
136 [ 13 ] [ 10 let-let-test ] unit-test
138 GENERIC: lambda-generic ( a b -- c )
140 GENERIC# lambda-generic-1 1 ( a b -- c )
142 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
144 M:: string lambda-generic-1 ( a b -- c )
145 a b CHAR: x <string> lambda-generic ;
147 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
149 GENERIC# lambda-generic-2 1 ( a b -- c )
151 M:: integer lambda-generic-2 ( a b -- c )
152 a CHAR: x <string> b lambda-generic ;
154 M:: string lambda-generic-2 ( a b -- c ) a b append ;
156 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
158 [ 10 ] [ 5 2 lambda-generic ] unit-test
160 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
162 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
164 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
166 [ ] [ \ lambda-generic-1 see ] unit-test
168 [ ] [ \ lambda-generic-2 see ] unit-test
170 [ ] [ \ lambda-generic see ] unit-test
172 :: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
174 [ "[let | a! [ ] | ]" ] [
175 \ unparse-test-1 "lambda" word-prop body>> first unparse
178 :: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
180 [ "[wlet | a! [ ] | ]" ] [
181 \ unparse-test-2 "lambda" word-prop body>> first unparse
184 :: unparse-test-3 ( -- b ) [| a! | ] ;
187 \ unparse-test-3 "lambda" word-prop body>> first unparse
193 "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
194 <string-reader> "lambda-generic-test" parse-stream drop
197 [ 10 ] [ 10 xyzzy ] unit-test
200 "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
201 <string-reader> "lambda-generic-test" parse-stream drop
204 [ 5 ] [ 10 xyzzy ] unit-test
206 :: let*-test-1 ( a -- b )
211 [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
213 :: let*-test-2 ( a -- b )
218 [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
220 :: let*-test-3 ( a -- b )
223 c 1+ c! a b c 3array ] ;
225 [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
227 :: let*-test-4 ( a b -- c d )
236 [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
238 GENERIC: next-method-test ( a -- b )
240 M: integer next-method-test 3 + ;
242 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
244 [ 5 ] [ 1 next-method-test ] unit-test
246 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
248 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
250 { 3 0 } [| a b c | ] must-infer-as
252 [ ] [ 1 [let | a [ ] | ] ] unit-test
254 [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
256 [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
258 :: a-word-with-locals ( a b -- ) ;
260 : new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
262 [ ] [ new-definition eval ] unit-test
265 [ \ a-word-with-locals see ] with-string-writer
269 : method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
271 GENERIC: method-with-locals ( x -- y )
273 M:: sequence method-with-locals ( a -- y ) a reverse ;
276 [ \ sequence \ method-with-locals method see ] with-string-writer