1 USING: accessors arrays combinators combinators.private io
2 kernel math math.functions prettyprint sequences stack-checker
6 { 3 } [ 1 2 [ + ] call( x y -- z ) ] unit-test
7 [ 1 2 [ + ] call( -- z ) ] must-fail
8 [ 1 2 [ + ] call( x y -- z a ) ] must-fail
9 { 1 2 3 { 1 2 3 4 } } [ 1 2 3 4 [ get-datastack nip ] call( x -- y ) ] unit-test
10 [ [ + ] call( x y -- z ) ] must-infer
12 { 3 } [ 1 2 \ + execute( x y -- z ) ] unit-test
13 [ 1 2 \ + execute( -- z ) ] must-fail
14 [ 1 2 \ + execute( x y -- z a ) ] must-fail
15 [ \ + execute( x y -- z ) ] must-infer
17 : compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
19 { t } [ \ compile-execute(-test-1 word-optimized? ] unit-test
20 { 4 } [ 1 3 compile-execute(-test-1 ] unit-test
22 : compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
24 { t } [ \ compile-execute(-test-2 word-optimized? ] unit-test
25 { 4 } [ 1 3 \ + compile-execute(-test-2 ] unit-test
26 { 5 } [ 1 4 \ + compile-execute(-test-2 ] unit-test
27 { -3 } [ 1 4 \ - compile-execute(-test-2 ] unit-test
28 { 5 } [ 1 4 \ + compile-execute(-test-2 ] unit-test
30 : compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
32 { t } [ \ compile-call(-test-1 word-optimized? ] unit-test
33 { 4 } [ 1 3 [ + ] compile-call(-test-1 ] unit-test
34 { 7 } [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
35 { 7 } [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
36 { 4 } [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
38 [ [ ] call( -- * ) ] must-fail
40 : compile-call(-test-2 ( -- ) [ ] call( -- * ) ;
42 [ compile-call(-test-2 ] [ wrong-values? ] must-fail-with
44 : compile-call(-test-3 ( quot -- ) call( -- * ) ;
46 [ [ ] compile-call(-test-3 ] [ wrong-values? ] must-fail-with
48 : compile-execute(-test-3 ( a -- ) \ . execute( value -- * ) ;
50 [ 10 compile-execute(-test-3 ] [ wrong-values? ] must-fail-with
52 : compile-execute(-test-4 ( a word -- ) execute( value -- * ) ;
54 [ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
57 : cond-test-1 ( obj -- str )
59 { [ dup 2 mod 0 = ] [ drop "even" ] }
60 { [ dup 2 mod 1 = ] [ drop "odd" ] }
63 \ cond-test-1 def>> must-infer
65 { "even" } [ 2 cond-test-1 ] unit-test
66 { "even" } [ 2 \ cond-test-1 def>> call ] unit-test
67 { "odd" } [ 3 cond-test-1 ] unit-test
68 { "odd" } [ 3 \ cond-test-1 def>> call ] unit-test
70 : cond-test-2 ( obj -- str )
72 { [ dup t = ] [ drop "true" ] }
73 { [ dup f = ] [ drop "false" ] }
74 [ drop "something else" ]
77 \ cond-test-2 def>> must-infer
79 { "true" } [ t cond-test-2 ] unit-test
80 { "true" } [ t \ cond-test-2 def>> call ] unit-test
81 { "false" } [ f cond-test-2 ] unit-test
82 { "false" } [ f \ cond-test-2 def>> call ] unit-test
83 { "something else" } [ "ohio" cond-test-2 ] unit-test
84 { "something else" } [ "ohio" \ cond-test-2 def>> call ] unit-test
86 : cond-test-3 ( obj -- str )
88 [ drop "something else" ]
89 { [ dup t = ] [ drop "true" ] }
90 { [ dup f = ] [ drop "false" ] }
93 \ cond-test-3 def>> must-infer
95 { "something else" } [ t cond-test-3 ] unit-test
96 { "something else" } [ t \ cond-test-3 def>> call ] unit-test
97 { "something else" } [ f cond-test-3 ] unit-test
98 { "something else" } [ f \ cond-test-3 def>> call ] unit-test
99 { "something else" } [ "ohio" cond-test-3 ] unit-test
100 { "something else" } [ "ohio" \ cond-test-3 def>> call ] unit-test
106 \ cond-test-4 def>> must-infer
108 [ cond-test-4 ] [ no-cond? ] must-fail-with
109 [ \ cond-test-4 def>> call ] [ no-cond? ] must-fail-with
111 : cond-test-5 ( a -- b )
113 { [ dup 2 mod 1 = ] [ drop "odd" ] }
115 { [ dup 2 mod 0 = ] [ drop "even" ] }
118 { "early" } [ 2 cond-test-5 ] unit-test
119 { "early" } [ 2 \ cond-test-5 def>> call ] unit-test
121 : cond-test-6 ( a -- b )
123 [ drop "really early" ]
124 { [ dup 2 mod 1 = ] [ drop "odd" ] }
125 { [ dup 2 mod 0 = ] [ drop "even" ] }
128 { "really early" } [ 2 cond-test-6 ] unit-test
129 { "really early" } [ 2 \ cond-test-6 def>> call ] unit-test
132 : case-test-1 ( obj -- obj' )
140 \ case-test-1 def>> must-infer
142 { "two" } [ 2 case-test-1 ] unit-test
143 { "two" } [ 2 \ case-test-1 def>> call ] unit-test
145 [ "x" case-test-1 ] must-fail
146 [ "x" \ case-test-1 def>> call ] must-fail
148 : case-test-2 ( obj -- obj' )
157 \ case-test-2 def>> must-infer
159 { 25 } [ 5 case-test-2 ] unit-test
160 { 25 } [ 5 \ case-test-2 def>> call ] unit-test
162 : case-test-3 ( obj -- obj' )
168 { H{ } [ "a hashtable" ] }
169 { { 1 2 3 } [ "an array" ] }
173 \ case-test-3 def>> must-infer
175 { "an array" } [ { 1 2 3 } case-test-3 ] unit-test
176 { "an array" } [ { 1 2 3 } \ case-test-3 def>> call ] unit-test
178 CONSTANT: case-const-1 1
179 CONSTANT: case-const-2 2
182 : case-test-4 ( obj -- str )
184 { case-const-1 [ "uno" ] }
185 { case-const-2 [ "dos" ] }
192 \ case-test-4 def>> must-infer
194 { "uno" } [ 1 case-test-4 ] unit-test
195 { "dos" } [ 2 case-test-4 ] unit-test
196 { "tres" } [ 3 case-test-4 ] unit-test
197 { "demasiado" } [ 100 case-test-4 ] unit-test
199 { "uno" } [ 1 \ case-test-4 def>> call ] unit-test
200 { "dos" } [ 2 \ case-test-4 def>> call ] unit-test
201 { "tres" } [ 3 \ case-test-4 def>> call ] unit-test
202 { "demasiado" } [ 100 \ case-test-4 def>> call ] unit-test
204 : case-test-5 ( obj -- )
206 { case-const-1 [ "uno" print ] }
207 { case-const-2 [ "dos" print ] }
208 { 3 [ "tres" print ] }
209 { 4 [ "cuatro" print ] }
210 { 5 [ "cinco" print ] }
211 [ drop "demasiado" print ]
214 \ case-test-5 def>> must-infer
216 { } [ 1 case-test-5 ] unit-test
217 { } [ 1 \ case-test-5 def>> call ] unit-test
219 : do-not-call ( -- * ) "do not call" throw ;
221 : test-case-6 ( obj -- value )
223 { \ do-not-call [ "do-not-call" ] }
227 \ test-case-6 def>> must-infer
229 { "three" } [ 3 test-case-6 ] unit-test
230 { "do-not-call" } [ \ do-not-call test-case-6 ] unit-test
232 { t } [ { 1 3 2 } contiguous-range? ] unit-test
233 { f } [ { 1 2 2 4 } contiguous-range? ] unit-test
234 { f } [ { + 3 2 } contiguous-range? ] unit-test
235 { f } [ { 1 0 7 } contiguous-range? ] unit-test
236 { f } [ { 1 1 3 7 } contiguous-range? ] unit-test
237 { t } [ { 7 6 4 8 5 } contiguous-range? ] unit-test
240 : test-case-7 ( obj -- str )
250 \ test-case-7 def>> must-infer
252 { "plus" } [ \ + test-case-7 ] unit-test
253 { "plus" } [ \ + \ test-case-7 def>> call ] unit-test
257 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry ( a -- b ) define-declared >>
259 { t } [ \ corner-case-1 word-optimized? ] unit-test
261 { 4 } [ 2 corner-case-1 ] unit-test
262 { 4 } [ 2 \ corner-case-1 def>> call ] unit-test
264 : test-case-8 ( n -- string )
269 [ 3 test-case-8 ] [ object>> 3 = ] must-fail-with
270 [ 3 \ test-case-8 def>> call ] [ object>> 3 = ] must-fail-with
272 : test-case-9 ( a -- b )
277 { \ - [ "minus 2" ] }
280 { "plus" } [ \ + test-case-9 ] unit-test
281 { "plus" } [ \ + \ test-case-9 def>> call ] unit-test
283 { "minus" } [ \ - test-case-9 ] unit-test
284 { "minus" } [ \ - \ test-case-9 def>> call ] unit-test
286 : test-case-10 ( a -- b )
296 { "dos" } [ 2 test-case-10 ] unit-test
297 { "dos" } [ 2 \ test-case-10 def>> call ] unit-test
299 : test-case-11 ( a -- b )
309 { "dos" } [ 22 test-case-11 ] unit-test
310 { "dos" } [ 22 \ test-case-11 def>> call ] unit-test
312 : test-case-12 ( a -- b )
322 { "nachos" } [ 33 test-case-12 ] unit-test
323 { "nachos" } [ 33 \ test-case-12 def>> call ] unit-test
326 [ { [ ] [ ] } spread ] infer
329 : test-case-13 ( a -- b )
338 [ 5.0 test-case-13 ] [ no-case? ] must-fail-with
346 [ dup 3 = [ drop "three" ] [ drop f ] if ] if