1 USING: accessors alien alien.c-types alien.libraries
2 alien.syntax arrays classes.struct combinators
3 compiler continuations effects generalizations io
4 io.backend io.pathnames io.streams.string kernel
5 math memory namespaces namespaces.private parser
6 quotations sequences specialized-arrays stack-checker
7 stack-checker.errors system threads tools.test words
8 alien.complex concurrency.promises alien.data
9 byte-arrays classes compiler.test libc ;
10 FROM: alien.c-types => float short ;
11 SPECIALIZED-ARRAY: float
12 SPECIALIZED-ARRAY: char
13 IN: compiler.tests.alien
15 ! Make sure that invalid inputs don't pass the stack checker
16 [ [ void { } "cdecl" alien-indirect ] infer ] must-fail
17 [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
18 [ [ void* 3 cdecl alien-indirect ] infer ] must-fail
19 [ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
20 [ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
23 : libfactor-ffi-tests-path ( -- string )
24 "resource:" absolute-path
26 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
27 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
28 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
31 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
33 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
35 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
37 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
42 FUNCTION: void ffi_test_0 ;
43 [ ] [ ffi_test_0 ] unit-test
45 FUNCTION: int ffi_test_1 ;
46 [ 3 ] [ ffi_test_1 ] unit-test
48 [ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
50 FUNCTION: int ffi_test_2 int x int y ;
51 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
52 [ "hi" 3 ffi_test_2 ] must-fail
54 FUNCTION: int ffi_test_3 int x int y int z int t ;
55 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
57 FUNCTION: float ffi_test_4 ;
58 [ 1.5 ] [ ffi_test_4 ] unit-test
60 FUNCTION: double ffi_test_5 ;
61 [ 1.5 ] [ ffi_test_5 ] unit-test
63 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
64 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
65 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
66 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
68 STRUCT: FOO { x int } { y int } ;
70 : make-FOO ( x y -- FOO )
71 FOO <struct> swap >>y swap >>x ;
73 FUNCTION: int ffi_test_11 int a FOO b int c ;
75 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
77 FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
79 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
81 FUNCTION: FOO ffi_test_14 int x int y ;
83 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
85 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
87 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
88 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
89 [ 1 2 ffi_test_15 ] must-fail
91 STRUCT: BAR { x long } { y long } { z long } ;
93 FUNCTION: BAR ffi_test_16 long x long y long z ;
96 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
99 STRUCT: TINY { x int } ;
101 FUNCTION: TINY ffi_test_17 int x ;
103 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
105 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
107 : indirect-test-1 ( ptr -- result )
108 int { } cdecl alien-indirect ;
110 { 1 1 } [ indirect-test-1 ] must-infer-as
112 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
114 : indirect-test-1' ( ptr -- )
115 int { } cdecl alien-indirect drop ;
117 { 1 0 } [ indirect-test-1' ] must-infer-as
119 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
121 [ -1 indirect-test-1 ] must-fail
123 : indirect-test-2 ( x y ptr -- result )
124 int { int int } cdecl alien-indirect gc ;
126 { 3 1 } [ indirect-test-2 ] must-infer-as
129 [ 2 3 &: ffi_test_2 indirect-test-2 ]
132 : indirect-test-3 ( a b c d ptr -- result )
133 int { int int int int } stdcall alien-indirect
136 [ f ] [ "f-stdcall" load-library f = ] unit-test
137 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
139 : ffi_test_18 ( w x y z -- int )
140 int "f-stdcall" "ffi_test_18" { int int int int }
143 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
145 : ffi_test_19 ( x y z -- BAR )
146 BAR "f-stdcall" "ffi_test_19" { long long long }
150 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
153 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
154 [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
156 int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
159 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
161 FUNCTION: double ffi_test_6 float x float y ;
162 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
163 [ "a" "b" ffi_test_6 ] must-fail
165 FUNCTION: double ffi_test_7 double x double y ;
166 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
168 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
169 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
171 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
172 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
174 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
175 double y1, double y2, double y3,
176 double z1, double z2, double z3 ;
178 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
180 ! Make sure XT doesn't get clobbered in stack frame
182 : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
184 "f-cdecl" "ffi_test_31"
185 { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
188 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
190 : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
192 "f-cdecl" "ffi_test_31_point_5"
193 { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
196 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
198 FUNCTION: longlong ffi_test_21 long x long y ;
200 [ 121932631112635269 ]
201 [ 123456789 987654321 ffi_test_21 ] unit-test
203 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
206 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
208 [ 1111 f 123456789 ffi_test_22 ] must-fail
211 { x float } { y float }
212 { w float } { h float } ;
214 : <RECT> ( x y w h -- rect )
221 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
223 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
225 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
227 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
230 { 1.0 2.0 3.0 } >float-array
231 { 4.0 5.0 6.0 } >float-array
235 ! Test odd-size structs
236 STRUCT: test-struct-1 { x char[1] } ;
238 FUNCTION: test-struct-1 ffi_test_24 ;
240 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
242 STRUCT: test-struct-2 { x char[2] } ;
244 FUNCTION: test-struct-2 ffi_test_25 ;
246 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
248 STRUCT: test-struct-3 { x char[3] } ;
250 FUNCTION: test-struct-3 ffi_test_26 ;
252 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
254 STRUCT: test-struct-4 { x char[4] } ;
256 FUNCTION: test-struct-4 ffi_test_27 ;
258 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
260 STRUCT: test-struct-5 { x char[5] } ;
262 FUNCTION: test-struct-5 ffi_test_28 ;
264 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
266 STRUCT: test-struct-6 { x char[6] } ;
268 FUNCTION: test-struct-6 ffi_test_29 ;
270 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
272 STRUCT: test-struct-7 { x char[7] } ;
274 FUNCTION: test-struct-7 ffi_test_30 ;
276 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
278 STRUCT: test-struct-8 { x double } { y double } ;
280 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
283 test-struct-8 <struct>
289 STRUCT: test-struct-9 { x float } { y float } ;
291 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
294 test-struct-9 <struct>
300 STRUCT: test-struct-10 { x float } { y int } ;
302 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
305 test-struct-10 <struct>
311 STRUCT: test-struct-11 { x int } { y int } ;
313 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
316 test-struct-11 <struct>
322 STRUCT: test-struct-12 { a int } { x double } ;
324 : make-struct-12 ( x -- alien )
325 test-struct-12 <struct>
328 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
330 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
332 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
334 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
338 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
340 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
342 [ t ] [ callback-1 alien? ] unit-test
344 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
346 [ ] [ callback-1 callback_test_1 ] unit-test
348 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
350 [ ] [ callback-2 callback_test_1 ] unit-test
352 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
357 3 "x" set callback-3 callback_test_1
359 "x" get "x" get-global
363 : callback-5 ( -- callback )
364 void { } cdecl [ gc ] alien-callback ;
367 "testing" callback-5 callback_test_1
370 : callback-5b ( -- callback )
371 void { } cdecl [ compact-gc ] alien-callback ;
374 "testing" callback-5b callback_test_1
377 : callback-6 ( -- callback )
378 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
380 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
382 : callback-7 ( -- callback )
383 void { } cdecl [ 1000000 sleep ] alien-callback ;
385 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
387 [ f ] [ namespace global eq? ] unit-test
389 : callback-8 ( -- callback )
390 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
392 [ ] [ callback-8 callback_test_1 ] unit-test
394 : callback-9 ( -- callback )
395 int { int int int } cdecl [
399 FUNCTION: void ffi_test_36_point_5 ( ) ;
401 [ ] [ ffi_test_36_point_5 ] unit-test
403 FUNCTION: int ffi_test_37 ( void* func ) ;
405 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
407 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
409 STRUCT: test_struct_13
417 : make-test-struct-13 ( -- alien )
418 test_struct_13 <struct>
426 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
428 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
430 ! Joe Groff found this problem
437 : <double-rect> ( a b c d -- foo )
444 : >double-rect< ( foo -- a b c d )
452 : double-rect-callback ( -- alien )
453 void { void* void* double-rect } cdecl
454 [ "example" set-global 2drop ] alien-callback ;
456 : double-rect-test ( arg callback -- arg' )
458 void { void* void* double-rect } cdecl alien-indirect
459 "example" get-global ;
461 [ byte-array 1.0 2.0 3.0 4.0 ]
463 1.0 2.0 3.0 4.0 <double-rect>
464 double-rect-callback double-rect-test
465 [ >c-ptr class ] [ >double-rect< ] bi
468 STRUCT: test_struct_14
472 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
475 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
478 : callback-10 ( -- callback )
479 test_struct_14 { double double } cdecl
481 test_struct_14 <struct>
486 : callback-10-test ( x1 x2 callback -- result )
487 test_struct_14 { double double } cdecl alien-indirect ;
490 1.0 2.0 callback-10 callback-10-test
494 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
501 : callback-11 ( -- callback )
502 test-struct-12 { int double } cdecl
504 test-struct-12 <struct>
509 : callback-11-test ( x1 x2 callback -- result )
510 test-struct-12 { int double } cdecl alien-indirect ;
513 1 2.0 callback-11 callback-11-test
517 STRUCT: test_struct_15
521 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
523 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
525 : callback-12 ( -- callback )
526 test_struct_15 { float float } cdecl
528 test_struct_15 <struct>
533 : callback-12-test ( x1 x2 callback -- result )
534 test_struct_15 { float float } cdecl alien-indirect ;
537 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
540 STRUCT: test_struct_16
544 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
546 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
548 : callback-13 ( -- callback )
549 test_struct_16 { float int } cdecl
551 test_struct_16 <struct>
556 : callback-13-test ( x1 x2 callback -- result )
557 test_struct_16 { float int } cdecl alien-indirect ;
560 1.0 2 callback-13 callback-13-test
564 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
566 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
568 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
570 [ ] [ stack-frame-bustage 2drop ] unit-test
575 FUNCTION: complex-float ffi_test_45 ( int x ) ;
577 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
579 FUNCTION: complex-double ffi_test_46 ( int x ) ;
581 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
583 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
587 C{ 1.5 1.0 } ffi_test_47
591 STRUCT: bool-field-test
596 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
599 bool-field-test <struct>
606 ! Test interaction between threads and callbacks
607 : thread-callback-1 ( -- callback )
608 int { } cdecl [ yield 100 ] alien-callback ;
610 : thread-callback-2 ( -- callback )
611 int { } cdecl [ yield 200 ] alien-callback ;
613 : thread-callback-invoker ( callback -- n )
614 int { } cdecl alien-indirect ;
617 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
618 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
619 [ 100 ] [ "p" get ?promise ] unit-test
621 ! More alien-assembly tests are in cpu.* vocabs
622 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
624 [ ] [ assembly-test-1 ] unit-test
626 [ f ] [ "f-fastcall" load-library f = ] unit-test
627 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
629 : ffi_test_49 ( x -- int )
630 int "f-fastcall" "ffi_test_49" { int }
632 : ffi_test_50 ( x y -- int )
633 int "f-fastcall" "ffi_test_50" { int int }
635 : ffi_test_51 ( x y z -- int )
636 int "f-fastcall" "ffi_test_51" { int int int }
638 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
639 [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
641 int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
643 [ 4 ] [ 3 ffi_test_49 ] unit-test
644 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
645 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
646 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
648 : ffi_test_52 ( x y z -- int )
649 int "f-fastcall" "ffi_test_52" { int float int }
651 : ffi_test_53 ( x y z w -- int )
652 int "f-fastcall" "ffi_test_53" { int float int int }
654 : ffi_test_57 ( x y -- test-struct-11 )
655 test-struct-11 "f-fastcall" "ffi_test_57" { int int }
657 : ffi_test_58 ( x y z -- test-struct-11 )
658 test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
663 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
665 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
668 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
670 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
672 : fastcall-ii-indirect ( x y ptr -- result )
673 int { int int } fastcall alien-indirect ;
675 : fastcall-iii-indirect ( x y z ptr -- result )
676 int { int int int } fastcall alien-indirect ;
678 : fastcall-ifi-indirect ( x y z ptr -- result )
679 int { int float int } fastcall alien-indirect ;
681 : fastcall-ifii-indirect ( x y z w ptr -- result )
682 int { int float int int } fastcall alien-indirect ;
684 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
685 test-struct-11 { int int } fastcall alien-indirect ;
687 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
688 test-struct-11 { int int int } fastcall alien-indirect ;
690 : win32? ( -- ? ) os windows? cpu x86.32? and ;
694 win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
700 win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
701 fastcall-iii-indirect
707 win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
708 fastcall-ifi-indirect
713 win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
714 fastcall-ifii-indirect
718 [ S{ test-struct-11 f 7 -1 } ]
721 win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
722 fastcall-struct-return-ii-indirect
725 [ S{ test-struct-11 f 7 -3 } ]
728 win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
729 fastcall-struct-return-iii-indirect
732 : fastcall-ii-callback ( -- ptr )
733 int { int int } fastcall [ + 1 + ] alien-callback ;
735 : fastcall-iii-callback ( -- ptr )
736 int { int int int } fastcall [ + + 1 + ] alien-callback ;
738 : fastcall-ifi-callback ( -- ptr )
739 int { int float int } fastcall
740 [ [ >integer ] dip + + 1 + ] alien-callback ;
742 : fastcall-ifii-callback ( -- ptr )
743 int { int float int int } fastcall
744 [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
746 : fastcall-struct-return-ii-callback ( -- ptr )
747 test-struct-11 { int int } fastcall
748 [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
750 : fastcall-struct-return-iii-callback ( -- ptr )
751 test-struct-11 { int int int } fastcall
752 [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
754 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
756 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
758 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
760 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
762 [ S{ test-struct-11 f 7 -1 } ]
763 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
765 [ S{ test-struct-11 f 7 -3 } ]
766 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
768 : x64-regression-1 ( -- c )
769 int { int int int int int } cdecl [ + + + + ] alien-callback ;
771 : x64-regression-2 ( x x x x x c -- y )
772 int { int int int int int } cdecl alien-indirect ; inline
774 [ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test
777 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
779 [ 3 ] [ blah ] unit-test
781 : out-param-test-1 ( -- b )
782 { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
784 [ 12 ] [ out-param-test-1 ] unit-test
786 : out-param-test-2 ( -- b )
787 { { int initial: 12 } } [ drop ] with-out-parameters ;
789 [ 12 ] [ out-param-test-2 ] unit-test
791 : out-param-test-3 ( -- x y )
792 { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
796 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
798 : out-param-callback ( -- a )
799 void { int pointer: int } cdecl
800 [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
802 : out-param-indirect ( a a -- b )
804 swap void { int pointer: int } cdecl
806 ] with-out-parameters ;
808 [ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
810 ! Alias analysis regression
811 : aa-callback-1 ( -- c )
812 double { } cdecl [ 5.0 ] alien-callback ;
814 : aa-indirect-1 ( c -- x )
815 double { } cdecl alien-indirect ; inline
817 TUPLE: some-tuple x ;
819 [ T{ some-tuple f 5.0 } ] [
828 : anton's-regression ( -- )
831 [ ] [ anton's-regression ] unit-test