]> gitweb.factorcode.org Git - factor.git/blob - basis/compiler/tests/intrinsics.factor
Update documentation for stricter vocabulary search path semantics
[factor.git] / basis / compiler / tests / intrinsics.factor
1 USING: accessors arrays compiler.units kernel kernel.private math
2 math.constants math.private sequences strings tools.test words
3 continuations sequences.private hashtables.private byte-arrays
4 system random layouts vectors
5 sbufs strings.private slots.private alien math.order
6 alien.accessors alien.c-types alien.syntax alien.strings
7 namespaces libc io.encodings.ascii
8 classes compiler ;
9 IN: compiler.tests.intrinsics
10
11 ! Make sure that intrinsic ops compile to correct code.
12 [ ] [ 1 [ drop ] compile-call ] unit-test
13 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
14 [ ] [ 1 2 3 [ 3drop ] compile-call ] unit-test
15 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
16 [ 1 2 1 2 ] [ 1 2 [ 2dup ] compile-call ] unit-test
17 [ 1 2 3 1 2 3 ] [ 1 2 3 [ 3dup ] compile-call ] unit-test
18 [ 2 3 1 ] [ 1 2 3 [ rot ] compile-call ] unit-test
19 [ 3 1 2 ] [ 1 2 3 [ -rot ] compile-call ] unit-test
20 [ 1 1 2 ] [ 1 2 [ dupd ] compile-call ] unit-test
21 [ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
22 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
23 [ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
24 [ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
25 [ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
26 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
27 [ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
28
29 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
30 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
31
32 [ { f f } ] [ 2 f <array> ] unit-test
33
34 [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
35 [ 3 ] [ 3 1 2 [ 2array [ 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 [ [ 3 set-slot ] keep ] compile-call second ] 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
41 ! Write barrier hits on the wrong value were causing segfaults
42 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
43
44 [ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] 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: b ] [ 1 "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
51 [ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
52 [ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
53 [ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
54 [ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
55 [ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
56 [ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
57
58 [ ] [ [ 0 getenv ] compile-call drop ] unit-test
59 [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
60
61 [ ] [ 1 [ drop ] compile-call ] unit-test
62 [ ] [ [ 1 drop ] compile-call ] unit-test
63 [ ] [ [ 1 2 2drop ] compile-call ] unit-test
64 [ ] [ 1 [ 2 2drop ] compile-call ] unit-test
65 [ ] [ 1 2 [ 2drop ] compile-call ] unit-test
66 [ 2 1 ] [ [ 1 2 swap ] 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 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
70 [ 1 1 ] [ [ 1 dup ] compile-call ] unit-test
71 [ 1 2 1 ] [ [ 1 2 over ] 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 3 1 ] [ [ 1 2 3 pick ] 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 1 2 ] [ [ 1 2 dupd ] 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 [ 2 ] [ [ 1 2 nip ] compile-call ] unit-test
82 [ 2 ] [ 1 [ 2 nip ] compile-call ] unit-test
83 [ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
84
85 [ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-call ] unit-test
86
87 [ 4 ] [ 12 7 [ fixnum-bitand ] 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
91 [ 15 ] [ 12 7 [ fixnum-bitor ] compile-call ] unit-test
92 [ 15 ] [ 12 [ 7 fixnum-bitor ] compile-call ] unit-test
93 [ 15 ] [ [ 12 7 fixnum-bitor ] compile-call ] unit-test
94
95 [ 11 ] [ 12 7 [ fixnum-bitxor ] compile-call ] unit-test
96 [ 11 ] [ 12 [ 7 fixnum-bitxor ] compile-call ] unit-test
97 [ 11 ] [ [ 12 7 fixnum-bitxor ] compile-call ] unit-test
98
99 [ f ] [ 12 7 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
100 [ f ] [ 12 [ 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
101 [ f ] [ [ 12 7 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
102 [ f ] [ [ 12 12 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
103 [ f ] [ 12 12 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
104
105 [ t ] [ 12 70 [ fixnum< [ t ] [ f ] if ] compile-call ] unit-test
106 [ t ] [ 12 [ 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
107 [ t ] [ [ 12 70 fixnum< [ t ] [ f ] if ] compile-call ] unit-test
108
109 [ f ] [ 12 7 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
110 [ f ] [ 12 [ 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
111 [ f ] [ [ 12 7 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
112 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
113 [ t ] [ [ 12 12 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
114 [ t ] [ 12 12 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
115
116 [ t ] [ 12 70 [ fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
117 [ t ] [ 12 [ 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
118 [ t ] [ [ 12 70 fixnum<= [ t ] [ f ] if ] compile-call ] unit-test
119
120 [ t ] [ 12 7 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
121 [ t ] [ 12 [ 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
122 [ t ] [ [ 12 7 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
123 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
124 [ f ] [ [ 12 12 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
125 [ f ] [ 12 12 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
126
127 [ f ] [ 12 70 [ fixnum> [ t ] [ f ] if ] compile-call ] unit-test
128 [ f ] [ 12 [ 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
129 [ f ] [ [ 12 70 fixnum> [ t ] [ f ] if ] compile-call ] unit-test
130
131 [ t ] [ 12 7 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
132 [ t ] [ 12 [ 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
133 [ t ] [ [ 12 7 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
134 [ t ] [ [ 12 12 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
135 [ t ] [ 12 12 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
136
137 [ f ] [ 12 70 [ fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
138 [ f ] [ 12 [ 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
139 [ f ] [ [ 12 70 fixnum>= [ t ] [ f ] if ] compile-call ] unit-test
140
141 [ f ] [ 1 2 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
142 [ f ] [ 1 [ 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
143 [ f ] [ [ 1 2 eq? [ t ] [ f ] if ] compile-call ] unit-test
144 [ t ] [ 3 3 [ eq? [ t ] [ f ] if ] compile-call ] unit-test
145 [ t ] [ 3 [ 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
146 [ t ] [ [ 3 3 eq? [ t ] [ f ] if ] compile-call ] unit-test
147
148 [ -1 ] [ 0 [ fixnum-bitnot ] compile-call ] unit-test
149 [ -1 ] [ [ 0 fixnum-bitnot ] compile-call ] unit-test
150
151 [ 3 ] [ 13 10 [ fixnum-mod ] compile-call ] unit-test
152 [ 3 ] [ 13 [ 10 fixnum-mod ] compile-call ] unit-test
153 [ 3 ] [ [ 13 10 fixnum-mod ] compile-call ] unit-test
154 [ -3 ] [ -13 10 [ fixnum-mod ] 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
158 [ 2 ] [ 4 2 [ fixnum/i ] compile-call ] unit-test
159 [ 2 ] [ 4 [ 2 fixnum/i ] compile-call ] unit-test
160 [ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
161 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
162
163 [ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
164 [ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
165 [ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
166 [ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
167
168 [ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
169 [ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
170 [ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
171
172 [ 4 ] [ 1 3 [ fixnum+fast ] compile-call ] unit-test
173 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
174 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
175
176 [ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
177 [ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
178 [ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
179
180 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
181
182 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
183 [ 6 ] [ 2 [ 3 fixnum*fast ] compile-call ] unit-test
184 [ 6 ] [ [ 2 3 fixnum*fast ] compile-call ] unit-test
185 [ -6 ] [ 2 -3 [ 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
189 [ 6 ] [ 2 3 [ fixnum* ] compile-call ] unit-test
190 [ 6 ] [ 2 [ 3 fixnum* ] compile-call ] unit-test
191 [ 6 ] [ [ 2 3 fixnum* ] compile-call ] unit-test
192 [ -6 ] [ 2 -3 [ fixnum* ] compile-call ] unit-test
193 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
194 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
195
196 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
197 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
198 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
199 [ 5 ] [ 2 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
200
201 [ 8 ] [ 1 3 [ fixnum-shift ] compile-call ] unit-test
202 [ 8 ] [ 1 [ 3 fixnum-shift ] compile-call ] unit-test
203 [ 8 ] [ [ 1 3 fixnum-shift ] compile-call ] unit-test
204 [ -8 ] [ -1 3 [ fixnum-shift ] 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
208 [ 2 ] [ 8 -2 [ fixnum-shift ] compile-call ] unit-test
209 [ 2 ] [ 8 [ -2 fixnum-shift ] compile-call ] unit-test
210
211 [ 0 ] [ [ 123 -64 fixnum-shift ] compile-call ] unit-test
212 [ 0 ] [ 123 -64 [ fixnum-shift ] compile-call ] unit-test
213 [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
214 [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
215
216 [ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
217 [ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
218 [ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
219
220 [ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
221 [ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
222
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
226 [ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
227 [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
228 [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
229
230 [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
231 [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
232 [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
233 [ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
234
235 [ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
236
237 [ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
238
239 [ t ] [ f [ f eq? ] compile-call ] unit-test
240
241 ! regression
242 [ 3 ] [
243     100001 f <array> 3 100000 pick set-nth
244     [ 100000 swap array-nth ] compile-call
245 ] unit-test
246
247 ! 64-bit overflow
248 cell 8 = [
249     [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
250     [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
251     
252     [ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
253     [ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
254     [ t ] [ 1 40 shift neg 1 40 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
255     [ t ] [ 1 30 shift neg 1 50 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
256     [ t ] [ 1 50 shift neg 1 30 shift neg [ fixnum* ] compile-call 1 80 shift = ] unit-test
257
258     [ 18446744073709551616 ] [ 1 64 [ fixnum-shift ] compile-call ] unit-test
259     [ 18446744073709551616 ] [ 1 [ 64 fixnum-shift ] compile-call ] unit-test
260     [ 18446744073709551616 ] [ 1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
261     [ -18446744073709551616 ] [ -1 64 [ fixnum-shift ] compile-call ] unit-test
262     [ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
263     [ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
264     
265     [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
266
267     [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
268
269     [ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
270 ] when
271
272 ! Some randomized tests
273 : compiled-fixnum* ( a b -- c ) fixnum* ;
274
275 [ ] [
276     10000 [ 
277         32 random-bits >fixnum 32 random-bits >fixnum
278         2dup
279         [ fixnum* ] 2keep compiled-fixnum* =
280         [ 2drop ] [ "Oops" throw ] if
281     ] times
282 ] unit-test
283
284 : compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
285
286 [ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
287
288 [ ] [
289     10000 [
290         32 random-bits >fixnum
291         dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
292         [ drop ] [ "Oops" throw ] if
293     ] times
294 ] unit-test
295
296 : compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
297
298 [ ] [
299     10000 [
300         5 random [ drop 32 random-bits ] map product >bignum
301         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
302         [ drop ] [ "Oops" throw ] if
303     ] times
304 ] unit-test
305
306 ! Test overflow check removal
307 [ t ] [
308     most-positive-fixnum 100 - >fixnum
309     200
310     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
311     [ fixnum+ >fixnum ] compile-call
312     =
313 ] unit-test
314
315 [ t ] [
316     most-negative-fixnum 100 + >fixnum
317     -200
318     [ [ fixnum+ ] compile-call [ bignum>fixnum ] compile-call ] 2keep
319     [ fixnum+ >fixnum ] compile-call
320     =
321 ] unit-test
322
323 [ t ] [
324     most-negative-fixnum 100 + >fixnum
325     200
326     [ [ fixnum- ] compile-call [ bignum>fixnum ] compile-call ] 2keep
327     [ fixnum- >fixnum ] compile-call
328     =
329 ] unit-test
330
331 ! Test inline allocators
332 [ { 1 1 1 } ] [
333     [ 3 1 <array> ] compile-call
334 ] unit-test
335
336 [ B{ 0 0 0 } ] [
337     [ 3 <byte-array> ] compile-call
338 ] unit-test
339
340 [ 500 ] [
341     [ 500 <byte-array> length ] compile-call
342 ] unit-test
343
344 [ 1 2 ] [
345     1 2 [ complex boa ] compile-call
346     dup real-part swap imaginary-part
347 ] unit-test
348
349 [ 1 2 ] [
350     1 2 [ ratio boa ] compile-call dup numerator swap denominator
351 ] unit-test
352
353 [ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
354
355 [ B{ 0 0 0 0 0 } ] [
356     [ 5 <byte-array> ] compile-call
357 ] unit-test
358
359 [ V{ 1 2 } ] [
360     { 1 2 3 } 2 [ vector boa ] compile-call
361 ] unit-test
362
363 [ SBUF" hello" ] [
364     "hello world" 5 [ sbuf boa ] compile-call
365 ] unit-test
366
367 [ [ 3 + ] ] [
368     3 [ + ] [ curry ] compile-call
369 ] unit-test
370
371 ! Alien intrinsics
372 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-call ] unit-test
373 [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-call ] unit-test
374 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
375 [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
376
377 [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
378 [ t ] [ "b" get >boolean ] unit-test
379
380 "b" get [
381     [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
382     [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
383     [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
384     [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
385
386     [ ] [ "b" get free ] unit-test
387 ] when
388
389 [ ] [ "hello world" ascii malloc-string "s" set ] unit-test
390
391 "s" get [
392     [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
393     [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
394
395     [ ] [ "s" get free ] unit-test
396 ] when
397
398 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-call *void* ] unit-test
399 [ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-call *void* ] unit-test
400 [ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-call *void* ] unit-test
401
402 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
403 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
404
405 [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
406 [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
407
408 [ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
409 [ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
410
411 [ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
412 [ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
413
414 [ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
415 [ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
416
417 [ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
418 [ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
419
420 [ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
421 [ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
422
423 [ t ] [ pi pi <double> *double = ] unit-test
424
425 [ t ] [ pi <double> [ { byte-array } declare *double ] compile-call pi = ] unit-test
426
427 ! Silly
428 [ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-call ] keep *float pi - -0.001 0.001 between? ] unit-test
429 [ t ] [ pi <float> [ { byte-array } declare *float ] compile-call pi - -0.001 0.001 between? ] unit-test
430
431 [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-call ] keep *double pi = ] unit-test
432
433 [ 4 ] [
434     2 B{ 1 2 3 4 5 6 } <displaced-alien> [
435         { alien } declare 1 alien-unsigned-1
436     ] compile-call
437 ] unit-test
438
439 [
440     B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
441 ] must-fail
442
443 [
444     B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-call
445 ] must-fail
446
447 [
448     4 5
449 ] [
450     3 [
451         [
452             { [ 4444 ] [ 444 ] [ 44 ] [ 4 ] } dispatch
453         ] keep 2 fixnum+fast
454     ] compile-call
455 ] unit-test
456
457 [ 1 ] [
458     8 -3 [ fixnum-shift-fast ] compile-call
459 ] unit-test
460
461 [ 2 ] [
462     16 -3 [ fixnum-shift-fast ] compile-call
463 ] unit-test
464
465 [ 2 ] [
466     16 [ -3 fixnum-shift-fast ] compile-call
467 ] unit-test
468
469 [ 8 ] [
470     1 3 [ fixnum-shift-fast ] compile-call
471 ] unit-test
472
473 [ 8 ] [
474     1 [ 3 fixnum-shift-fast ] compile-call
475 ] unit-test
476
477 TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
478
479 [ B{ 0 1 } ] [
480     B{ 0 0 } 1 alien-accessor-regression boa
481     dup [
482         { alien-accessor-regression } declare
483         [ i>> ] [ b>> ] bi over set-alien-unsigned-1
484     ] compile-call
485     b>>
486 ] unit-test
487
488 : mutable-value-bug-1 ( a b -- c )
489     swap [
490         { tuple } declare 1 slot
491     ] [
492         0 slot
493     ] if ;
494
495 [ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
496
497 : mutable-value-bug-2 ( a b -- c )
498     swap [
499         0 slot
500     ] [
501         { tuple } declare 1 slot
502     ] if ;
503
504 [ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test