1 USING: accessors arrays compiler.units kernel kernel.private
2 math math.constants math.private math.integers.private sequences
3 strings tools.test words continuations sequences.private
4 hashtables.private byte-arrays system random layouts vectors
5 sbufs strings.private slots.private alien math.order
6 alien.accessors alien.c-types alien.data alien.syntax alien.strings
7 namespaces libc io.encodings.ascii classes compiler.test ;
9 FROM: alien.c-types => short ;
10 QUALIFIED-WITH: alien.c-types c
11 IN: compiler.tests.intrinsics
13 ! Make sure that intrinsic ops compile to correct code.
14 [ ] [ 1 [ drop ] compile-call ] unit-test
15 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
16 [ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
17 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
18 [ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
19 [ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
20 [ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
21 [ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
22 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
23 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
24 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
25 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
26 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
27 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
28 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
30 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
31 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
33 [ { f f } ] [ 2 f <array> ] unit-test
35 [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
36 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
37 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
38 [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
39 [ 3 ] [ 3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
40 [ 3 ] [ [ 3 1 2 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
42 ! Write barrier hits on the wrong value were causing segfaults
43 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
45 [ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
46 [ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
47 [ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
48 [ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
49 [ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
50 [ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
52 [ 0x123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
53 [ 0x123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
54 [ 0x123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
55 [ 0x123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
56 [ 0x123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
57 [ 0x123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
59 [ ] [ [ 0 special-object ] compile-call drop ] unit-test
60 [ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
62 [ ] [ 1 [ drop ] compile-call ] unit-test
63 [ ] [ [ 1 drop ] compile-call ] unit-test
64 [ ] [ [ 1 2 2drop ] compile-call ] unit-test
65 [ ] [ 1 [ 2 2drop ] compile-call ] unit-test
66 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
67 [ 2 1 ] [ [ 1 2 swap ] compile-call ] unit-test
68 [ 2 1 ] [ 1 [ 2 swap ] compile-call ] unit-test
69 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
70 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
71 [ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
72 [ 1 2 1 ] [ [ 1 2 over ] compile-call ] unit-test
73 [ 1 2 1 ] [ 1 [ 2 over ] compile-call ] unit-test
74 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
75 [ 1 2 3 1 ] [ [ 1 2 3 pick ] compile-call ] unit-test
76 [ 1 2 3 1 ] [ 1 [ 2 3 pick ] compile-call ] unit-test
77 [ 1 2 3 1 ] [ 1 2 [ 3 pick ] compile-call ] unit-test
78 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
79 [ 1 1 2 ] [ [ 1 2 dupd ] compile-call ] unit-test
80 [ 1 1 2 ] [ 1 [ 2 dupd ] compile-call ] unit-test
81 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
82 [ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
83 [ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
84 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
86 [ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
88 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-call ] unit-test
89 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-call ] unit-test
90 [ 4 ] [ [ 12 7 fixnum-bitand ] compile-call ] unit-test
91 [ -16 ] [ -1 [ -16 fixnum-bitand ] compile-call ] unit-test
93 [ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
94 [ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
95 [ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
96 [ -1 ] [ -1 [ -16 fixnum-bitor ] compile-call ] unit-test
98 [ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
99 [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
100 [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
101 [ 15 ] [ -1 [ -16 fixnum-bitxor ] compile-call ] unit-test
103 [ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
104 [ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
105 [ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
106 [ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
107 [ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
109 [ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
110 [ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
111 [ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
113 [ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
114 [ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
115 [ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
116 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
117 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
118 [ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
120 [ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
121 [ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
122 [ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
124 [ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
125 [ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
126 [ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
127 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
128 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
129 [ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
131 [ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
132 [ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
133 [ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
135 [ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
136 [ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
137 [ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
138 [ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
139 [ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
141 [ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
142 [ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
143 [ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
145 [ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
146 [ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
147 [ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
148 [ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
149 [ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
150 [ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
152 [ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
153 [ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
155 [ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
156 [ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
157 [ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
158 [ -3 ] [ -13 10 [ fixnum-mod ] compile-call ] unit-test
159 [ -3 ] [ -13 [ 10 fixnum-mod ] compile-call ] unit-test
160 [ -3 ] [ [ -13 10 fixnum-mod ] compile-call ] unit-test
162 [ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
163 [ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
164 [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
165 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
167 [ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
168 [ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
169 [ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
170 [ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
172 [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
173 [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
174 [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
176 [ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
177 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
178 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
180 [ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
181 [ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
182 [ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
184 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
186 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
187 [ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
188 [ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
189 [ -6 ] [ 2 -3 [ fixnum*fast ] compile-call ] unit-test
190 [ -6 ] [ 2 [ -3 fixnum*fast ] compile-call ] unit-test
191 [ -6 ] [ [ 2 -3 fixnum*fast ] compile-call ] unit-test
193 [ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
194 [ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
195 [ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
196 [ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
197 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
198 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
200 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
201 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
202 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
203 [ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
205 [ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
206 [ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
207 [ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
208 [ -8 ] [ -1 3 [ fixnum-shift ] compile-call ] unit-test
209 [ -8 ] [ -1 [ 3 fixnum-shift ] compile-call ] unit-test
210 [ -8 ] [ [ -1 3 fixnum-shift ] compile-call ] unit-test
212 [ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
213 [ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
215 [ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
216 [ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
217 [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
218 [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
220 [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
221 [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
222 [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
223 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
224 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
225 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
227 [ 8 ] [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test
228 [ 8 ] [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
229 [ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
230 [ 8 ] [ [ 1 3 fixnum-shift-fast ] compile-call ] unit-test
231 [ -8 ] [ -1 3 [ fixnum-shift-fast ] compile-call ] unit-test
232 [ -8 ] [ -1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
233 [ -8 ] [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
234 [ -8 ] [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test
236 [ 2 ] [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test
237 [ 2 ] [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test
238 [ 2 ] [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test
240 [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
241 [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
242 [ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
243 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
244 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
245 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
247 [ 0x10000000 ] [ 0x1000000 0x10 [ fixnum* ] compile-call ] unit-test
248 [ 0x8000000 ] [ -0x8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
249 [ 0x8000000 ] [ -0x7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
251 [ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
252 [ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
254 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
255 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
256 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
257 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
259 [ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
261 [ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
263 [ t ] [ f [ f eq? ] compile-call ] unit-test
267 0x4200 [ 0x7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ]
274 100001 f <array> 3 100000 pick set-nth
275 [ 100000 swap array-nth ] compile-call
278 [ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test
279 [ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test
280 [ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test
281 [ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test
282 [ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test
283 [ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test
284 [ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test
285 [ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test
289 [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
290 [ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
292 [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
293 [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
294 [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
295 [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
296 [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
298 [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
299 [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
300 [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
301 [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
302 [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
303 [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
305 [ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
307 [ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
309 [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
312 ! Some randomized tests
313 : compiled-fixnum* ( a b -- c ) fixnum* ;
315 ERROR: bug-in-fixnum* x y a b ;
319 32 random-bits >fixnum
320 32 random-bits >fixnum
321 2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
322 [ 4drop ] [ throw-bug-in-fixnum* ] if
326 : compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
328 [ bignum ] [ 0 compiled-fixnum>bignum class-of ] unit-test
332 32 random-bits >fixnum
333 dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
334 [ drop ] [ "Oops" throw ] if
338 : compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
342 5 random iota [ drop 32 random-bits ] map product >bignum
343 dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
344 [ drop ] [ "Oops" throw ] if
348 ! Test overflow check removal
350 most-positive-fixnum 100 - >fixnum
352 [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
353 [ fixnum+ >fixnum ] compile-call
358 most-negative-fixnum 100 + >fixnum
360 [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
361 [ fixnum+ >fixnum ] compile-call
366 most-negative-fixnum 100 + >fixnum
368 [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
369 [ fixnum- >fixnum ] compile-call
373 ! Test inline allocators
375 [ 3 1 <array> ] compile-call
379 [ 3 <byte-array> ] compile-call
383 [ 500 <byte-array> length ] compile-call
387 1 2 [ complex boa ] compile-call
388 dup real-part swap imaginary-part
392 1 2 [ ratio boa ] compile-call dup numerator swap denominator
395 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
398 [ 5 <byte-array> ] compile-call
402 { 1 2 3 } 2 [ vector boa ] compile-call
406 "hello world" 5 [ sbuf boa ] compile-call
410 3 [ + ] [ curry ] compile-call
414 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
415 [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
416 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
417 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
419 [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
420 [ t ] [ "b" get >boolean ] unit-test
423 [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
424 [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
425 [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
426 [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
428 [ ] [ "b" get free ] unit-test
431 [ ] [ "hello world" ascii malloc-string "s" set ] unit-test
434 [ "hello world" ] [ "s" get void* <ref> [ { byte-array } declare void* deref ] compile-call ascii alien>string ] unit-test
435 [ "hello world" ] [ "s" get void* <ref> [ { c-ptr } declare void* deref ] compile-call ascii alien>string ] unit-test
437 [ ] [ "s" get free ] unit-test
440 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare void* <ref> ] compile-call void* deref ] unit-test
441 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare void* <ref> ] compile-call void* deref ] unit-test
442 [ f ] [ f [ { POSTPONE: f } declare void* <ref> ] compile-call void* deref ] unit-test
444 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
445 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
447 [ -100 ] [ -100 char <ref> [ { byte-array } declare char deref ] compile-call ] unit-test
448 [ 156 ] [ -100 uchar <ref> [ { byte-array } declare uchar deref ] compile-call ] unit-test
450 [ -100 ] [ -100 [ char <ref> ] [ { fixnum } declare ] prepend compile-call char deref ] unit-test
451 [ 156 ] [ -100 [ uchar <ref> ] [ { fixnum } declare ] prepend compile-call uchar deref ] unit-test
453 [ -1000 ] [ -1000 short <ref> [ { byte-array } declare short deref ] compile-call ] unit-test
454 [ 64536 ] [ -1000 ushort <ref> [ { byte-array } declare ushort deref ] compile-call ] unit-test
456 [ -1000 ] [ -1000 [ short <ref> ] [ { fixnum } declare ] prepend compile-call short deref ] unit-test
457 [ 64536 ] [ -1000 [ ushort <ref> ] [ { fixnum } declare ] prepend compile-call ushort deref ] unit-test
459 [ -100000 ] [ -100000 int <ref> [ { byte-array } declare int deref ] compile-call ] unit-test
460 [ 4294867296 ] [ -100000 uint <ref> [ { byte-array } declare uint deref ] compile-call ] unit-test
462 [ -100000 ] [ -100000 [ int <ref> ] [ { fixnum } declare ] prepend compile-call int deref ] unit-test
463 [ 4294867296 ] [ -100000 [ uint <ref> ] [ { fixnum } declare ] prepend compile-call uint deref ] unit-test
465 [ t ] [ pi pi double <ref> double deref = ] unit-test
467 [ t ] [ pi double <ref> [ { byte-array } declare double deref ] compile-call pi = ] unit-test
470 [ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep c:float deref pi - -0.001 0.001 between? ] unit-test
471 [ t ] [ pi c:float <ref> [ { byte-array } declare c:float deref ] compile-call pi - -0.001 0.001 between? ] unit-test
473 [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep double deref pi = ] unit-test
476 2 B{ 1 2 3 4 5 6 } <displaced-alien> [
477 { alien } declare 1 alien-unsigned-1
482 0x123 [ <alien> ] compile-call
486 0x123 [ { fixnum } declare <alien> ] compile-call
490 [ 0x123 <alien> ] compile-call
494 0 [ <alien> ] compile-call
498 0 [ { fixnum } declare <alien> ] compile-call
502 [ 0 <alien> ] compile-call
506 0 ALIEN: 321 [ <displaced-alien> ] compile-call
510 0 ALIEN: 321 [ { fixnum c-ptr } declare <displaced-alien> ] compile-call
514 ALIEN: 321 [ 0 swap <displaced-alien> ] compile-call
518 2 B{ 0 1 2 3 4 } <displaced-alien>
519 [ 1 swap <displaced-alien> ] compile-call
524 2 B{ 0 1 2 3 4 } <displaced-alien>
525 [ 1 swap { c-ptr } declare <displaced-alien> ] compile-call
529 [ ALIEN: 1234 ALIEN: 2234 ] [
532 [ 0x1000 swap <displaced-alien> ]
533 [ 0x2000 swap <displaced-alien> ] bi
537 ! These tests must fail because we're not allowed to store
538 ! a pointer to a byte array inside of an alien object
540 B{ 0 0 0 0 } [ { byte-array } declare void* <ref> ] compile-call
544 B{ 0 0 0 0 } [ { c-ptr } declare void* <ref> ] compile-call
552 { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
558 8 -3 [ fixnum-shift-fast ] compile-call
562 16 -3 [ fixnum-shift-fast ] compile-call
566 16 [ -3 fixnum-shift-fast ] compile-call
570 1 3 [ fixnum-shift-fast ] compile-call
574 1 [ 3 fixnum-shift-fast ] compile-call
577 TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
580 B{ 0 0 } 1 alien-accessor-regression boa
582 { alien-accessor-regression } declare
583 [ i>> ] [ b>> ] bi over set-alien-unsigned-1
588 : mutable-value-bug-1 ( a b -- c )
590 { tuple } declare 1 slot
595 [ 0 ] [ f { } mutable-value-bug-1 ] unit-test
597 : mutable-value-bug-2 ( a b -- c )
601 { tuple } declare 1 slot
604 [ 0 ] [ t { } mutable-value-bug-2 ] unit-test