1 USING: compiler.units tools.test kernel kernel.private
2 sequences.private math.private math combinators strings
3 alien arrays memory vocabs parser ;
7 [ ] [ [ ] compile-call ] unit-test
10 [ 1 ] [ [ 1 ] compile-call ] unit-test
11 [ 31 ] [ [ 31 ] compile-call ] unit-test
12 [ 255 ] [ [ 255 ] compile-call ] unit-test
13 [ -1 ] [ [ -1 ] compile-call ] unit-test
14 [ 65536 ] [ [ 65536 ] compile-call ] unit-test
15 [ -65536 ] [ [ -65536 ] compile-call ] unit-test
16 [ "hey" ] [ [ "hey" ] compile-call ] unit-test
21 [ ] [ [ no-op ] compile-call ] unit-test
22 [ 3 ] [ [ no-op 3 ] compile-call ] unit-test
23 [ 3 ] [ [ 3 no-op ] compile-call ] unit-test
27 [ 4 ] [ [ bar no-op ] compile-call ] unit-test
28 [ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
29 [ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
31 [ ] [ no-op ] unit-test
35 [ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
36 [ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
37 [ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
38 [ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
40 [ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
41 [ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
43 [ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
44 [ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
46 [ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
47 [ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
48 [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
49 [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
51 [ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
55 : recursive ( ? -- ) [ f recursive ] when ; inline
57 [ ] [ t [ recursive ] compile-call ] unit-test
59 [ ] [ t recursive ] unit-test
61 ! Make sure error reporting works
63 [ [ dup ] compile-call ] must-fail
64 [ [ drop ] compile-call ] must-fail
68 [ ] [ [ callstack ] compile-call drop ] unit-test
74 [ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
76 : dummy-if-1 ( -- ) t [ ] [ ] if ;
78 [ ] [ dummy-if-1 ] unit-test
80 : dummy-if-2 ( -- ) f [ ] [ ] if ;
82 [ ] [ dummy-if-2 ] unit-test
84 : dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
86 [ 1 ] [ dummy-if-3 ] unit-test
88 : dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
90 [ 2 ] [ dummy-if-4 ] unit-test
92 : dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
94 [ 1 ] [ dummy-if-5 ] unit-test
96 : dummy-if-6 ( n -- n )
100 1 fixnum- dup 1 fixnum- fixnum+
103 [ 17 ] [ 10 dummy-if-6 ] unit-test
105 : dead-code-rec ( -- obj )
112 [ 3.2 ] [ dead-code-rec ] unit-test
114 : one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
116 [ "hi" ] [ t one-rec ] unit-test
118 : after-if-test ( -- n )
121 [ 5 ] [ after-if-test ] unit-test
125 : countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ;
126 : countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ;
128 [ ] [ 10 countdown-b ] unit-test
130 : dummy-when-1 ( -- ) t [ ] when ;
132 [ ] [ dummy-when-1 ] unit-test
134 : dummy-when-2 ( -- ) f [ ] when ;
136 [ ] [ dummy-when-2 ] unit-test
138 : dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
140 [ 16 ] [ 4 dummy-when-3 ] unit-test
141 [ f ] [ f dummy-when-3 ] unit-test
143 : dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
145 [ 64 f ] [ f 4 dummy-when-4 ] unit-test
146 [ f t ] [ t f dummy-when-4 ] unit-test
148 : dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
150 [ f ] [ f dummy-when-5 ] unit-test
152 : dummy-unless-1 ( -- ) t [ ] unless ;
154 [ ] [ dummy-unless-1 ] unit-test
156 : dummy-unless-2 ( -- ) f [ ] unless ;
158 [ ] [ dummy-unless-2 ] unit-test
160 : dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
162 [ 3 ] [ f dummy-unless-3 ] unit-test
163 [ 4 ] [ 4 dummy-unless-3 ] unit-test
165 ! Test cond expansion
169 { [ dup 2 mod 0 = ] [ drop "even" ] }
170 { [ dup 2 mod 1 = ] [ drop "odd" ] }
178 { [ dup 2 mod 0 = ] [ drop "even" ] }
179 { [ dup 2 mod 1 = ] [ drop "odd" ] }
187 { [ dup string? ] [ drop "string" ] }
188 { [ dup float? ] [ drop "float" ] }
189 { [ dup alien? ] [ drop "alien" ] }
198 { [ dup fixnum? ] [ ] }
204 GENERIC: single-combination-test ( obj1 obj2 -- obj )
206 M: object single-combination-test drop ;
207 M: f single-combination-test nip ;
208 M: array single-combination-test drop ;
209 M: integer single-combination-test drop ;
211 [ 2 3 ] [ 2 3 t single-combination-test ] unit-test
212 [ 2 3 ] [ 2 3 4 single-combination-test ] unit-test
213 [ 2 f ] [ 2 3 f single-combination-test ] unit-test
215 DEFER: single-combination-test-2
217 : single-combination-test-4 ( obj -- obj )
218 dup [ single-combination-test-2 ] when ;
220 : single-combination-test-3 ( obj -- obj )
223 GENERIC: single-combination-test-2 ( obj -- obj )
224 M: object single-combination-test-2 single-combination-test-3 ;
225 M: f single-combination-test-2 single-combination-test-4 ;
227 [ 3 ] [ t single-combination-test-2 ] unit-test
228 [ 3 ] [ 3 single-combination-test-2 ] unit-test
229 [ f ] [ f single-combination-test-2 ] unit-test
232 [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
236 [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
238 "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval