1 USING: accessors alien alien.c-types alien.complex alien.data alien.libraries
2 alien.syntax arrays byte-arrays classes classes.struct combinators
3 combinators.extras compiler compiler.test concurrency.promises continuations
4 destructors effects generalizations io io.backend io.pathnames
5 io.streams.string kernel kernel.private libc layouts locals math math.bitwise
6 math.private memory namespaces namespaces.private random parser quotations
7 sequences slots.private specialized-arrays stack-checker stack-checker.errors
8 system threads tools.test words ;
9 FROM: alien.c-types => float short ;
10 SPECIALIZED-ARRAY: float
11 SPECIALIZED-ARRAY: char
12 IN: compiler.tests.alien
14 ! Make sure that invalid inputs don't pass the stack checker
15 [ [ void { } "cdecl" alien-indirect ] infer ] must-fail
16 [ [ "void" { } cdecl alien-indirect ] infer ] must-fail
17 [ [ void* 3 cdecl alien-indirect ] infer ] must-fail
18 [ [ void* { "int" } cdecl alien-indirect ] infer ] must-fail
19 [ [ void* { int } cdecl { } alien-callback ] infer ] must-fail
22 : libfactor-ffi-tests-path ( -- string )
23 "resource:" absolute-path
25 { [ os windows? ] [ "libfactor-ffi-test.dll" ] }
26 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
27 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
30 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
32 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
34 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
36 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
41 FUNCTION: void ffi_test_0 ( )
42 [ ] [ ffi_test_0 ] unit-test
44 FUNCTION: int ffi_test_1 ( )
45 [ 3 ] [ ffi_test_1 ] unit-test
47 [ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
49 FUNCTION: int ffi_test_2 ( int x, int y )
50 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
51 [ "hi" 3 ffi_test_2 ] must-fail
53 FUNCTION: int ffi_test_3 ( int x, int y, int z, int t )
54 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
56 FUNCTION: float ffi_test_4 ( )
57 [ 1.5 ] [ ffi_test_4 ] unit-test
59 FUNCTION: double ffi_test_5 ( )
60 [ 1.5 ] [ ffi_test_5 ] unit-test
62 FUNCTION: int ffi_test_9 ( int a, int b, int c, int d, int e, int f, int g )
63 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
64 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
65 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
67 STRUCT: FOO { x int } { y int } ;
69 : make-FOO ( x y -- FOO )
70 FOO <struct> swap >>y swap >>x ;
72 FUNCTION: int ffi_test_11 ( int a, FOO b, int c )
74 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
76 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 )
78 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
80 FUNCTION: FOO ffi_test_14 ( int x, int y )
82 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
84 FUNCTION: c-string ffi_test_15 ( c-string x, c-string y )
86 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
87 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
88 [ 1 2 ffi_test_15 ] must-fail
90 STRUCT: BAR { x long } { y long } { z long } ;
92 FUNCTION: BAR ffi_test_16 ( long x, long y, long z )
95 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
98 STRUCT: TINY { x int } ;
100 FUNCTION: TINY ffi_test_17 ( int x )
102 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
104 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
106 : indirect-test-1 ( ptr -- result )
107 int { } cdecl alien-indirect ;
109 { 1 1 } [ indirect-test-1 ] must-infer-as
111 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
113 : indirect-test-1' ( ptr -- )
114 int { } cdecl alien-indirect drop ;
116 { 1 0 } [ indirect-test-1' ] must-infer-as
118 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
120 [ -1 indirect-test-1 ] must-fail
122 : indirect-test-2 ( x y ptr -- result )
123 int { int int } cdecl alien-indirect gc ;
125 { 3 1 } [ indirect-test-2 ] must-infer-as
128 [ 2 3 &: ffi_test_2 indirect-test-2 ]
131 : indirect-test-3 ( a b c d ptr -- result )
132 int { int int int int } stdcall alien-indirect
135 [ f ] [ "f-stdcall" library-dll f = ] unit-test
136 [ stdcall ] [ "f-stdcall" lookup-library abi>> ] unit-test
138 : ffi_test_18 ( w x y z -- int )
139 int "f-stdcall" "ffi_test_18" { int int int int } f
142 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
144 : ffi_test_19 ( x y z -- BAR )
145 BAR "f-stdcall" "ffi_test_19" { long long long } f
149 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
152 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
153 [ int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke ]
155 int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke
158 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
160 FUNCTION: double ffi_test_6 ( float x, float y )
161 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
162 [ "a" "b" ffi_test_6 ] must-fail
164 FUNCTION: double ffi_test_7 ( double x, double y )
165 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
167 FUNCTION: double ffi_test_8 ( double x, float y, double z, float t, int w )
168 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
170 FUNCTION: int ffi_test_10 ( int a, int b, double c, int d, float e, int f, int g, int h )
171 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
173 FUNCTION: void ffi_test_20 ( double x1, double x2, double x3,
174 double y1, double y2, double y3,
175 double z1, double z2, double z3 )
177 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
179 ! Make sure XT doesn't get clobbered in stack frame
181 : 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 )
183 "f-cdecl" "ffi_test_31"
184 { 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 } f
187 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
189 : 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 )
191 "f-cdecl" "ffi_test_31_point_5"
192 { 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 } f
195 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
197 FUNCTION: longlong ffi_test_21 ( long x, long y )
199 [ 121932631112635269 ]
200 [ 123456789 987654321 ffi_test_21 ] unit-test
202 FUNCTION: long ffi_test_22 ( long x, longlong y, longlong z )
205 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
207 [ 1111 f 123456789 ffi_test_22 ] must-fail
210 { x float } { y float }
211 { w float } { h float } ;
213 : <RECT> ( x y w h -- rect )
220 FUNCTION: int ffi_test_12 ( int a, int b, RECT c, int d, int e, int f )
222 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
224 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
226 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y )
229 { 1.0 2.0 3.0 } float >c-array
230 { 4.0 5.0 6.0 } float >c-array
234 ! Test odd-size structs
235 STRUCT: test-struct-1 { x char[1] } ;
237 FUNCTION: test-struct-1 ffi_test_24 ( )
239 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
241 STRUCT: test-struct-2 { x char[2] } ;
243 FUNCTION: test-struct-2 ffi_test_25 ( )
245 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
247 STRUCT: test-struct-3 { x char[3] } ;
249 FUNCTION: test-struct-3 ffi_test_26 ( )
251 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
253 STRUCT: test-struct-4 { x char[4] } ;
255 FUNCTION: test-struct-4 ffi_test_27 ( )
257 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
259 STRUCT: test-struct-5 { x char[5] } ;
261 FUNCTION: test-struct-5 ffi_test_28 ( )
263 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
265 STRUCT: test-struct-6 { x char[6] } ;
267 FUNCTION: test-struct-6 ffi_test_29 ( )
269 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
271 STRUCT: test-struct-7 { x char[7] } ;
273 FUNCTION: test-struct-7 ffi_test_30 ( )
275 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
277 STRUCT: test-struct-8 { x double } { y double } ;
279 FUNCTION: double ffi_test_32 ( test-struct-8 x, int y )
282 test-struct-8 <struct>
288 STRUCT: test-struct-9 { x float } { y float } ;
290 FUNCTION: double ffi_test_33 ( test-struct-9 x, int y )
293 test-struct-9 <struct>
299 STRUCT: test-struct-10 { x float } { y int } ;
301 FUNCTION: double ffi_test_34 ( test-struct-10 x, int y )
304 test-struct-10 <struct>
310 STRUCT: test-struct-11 { x int } { y int } ;
312 FUNCTION: double ffi_test_35 ( test-struct-11 x, int y )
315 test-struct-11 <struct>
321 STRUCT: test-struct-12 { a int } { x double } ;
323 : make-struct-12 ( x -- alien )
324 test-struct-12 <struct>
327 FUNCTION: double ffi_test_36 ( test-struct-12 x )
329 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
331 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y )
333 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
336 : callback-throws ( -- x )
337 int { } cdecl [ "Hi" throw ] alien-callback ;
340 callback-throws [ alien? ] with-callback
343 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
345 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
347 { t } [ callback-1 [ alien? ] with-callback ] unit-test
349 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
351 { } [ callback-1 [ callback_test_1 ] with-callback ] unit-test
353 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
355 { } [ callback-2 [ callback_test_1 ] with-callback ] unit-test
357 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
362 3 "x" set callback-3 [ callback_test_1 ] with-callback
364 "x" get "x" get-global
368 : callback-5 ( -- callback )
369 void { } cdecl [ gc ] alien-callback ;
372 "testing" callback-5 [ callback_test_1 ] with-callback
375 : callback-5b ( -- callback )
376 void { } cdecl [ compact-gc ] alien-callback ;
379 "testing" callback-5b [ callback_test_1 ] with-callback
382 : callback-6 ( -- callback )
383 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
386 callback-6 [ callback_test_1 1 2 3 ] with-callback
389 : callback-7 ( -- callback )
390 void { } cdecl [ 1000000 sleep ] alien-callback ;
392 [ 1 2 3 ] [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test
394 [ f ] [ namespace global eq? ] unit-test
396 : callback-8 ( -- callback )
397 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
399 [ ] [ callback-8 [ callback_test_1 ] with-callback ] unit-test
401 : callback-9 ( -- callback )
402 int { int int int } cdecl [
406 FUNCTION: void ffi_test_36_point_5 ( )
408 [ ] [ ffi_test_36_point_5 ] unit-test
410 FUNCTION: int ffi_test_37 ( void* func )
412 [ 1 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
414 [ 7 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test
416 STRUCT: test_struct_13
424 : make-test-struct-13 ( -- alien )
425 test_struct_13 <struct>
433 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s )
435 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
437 ! Joe Groff found this problem
444 : <double-rect> ( a b c d -- foo )
451 : >double-rect< ( foo -- a b c d )
459 : double-rect-callback ( -- alien )
460 void { void* void* double-rect } cdecl
461 [ "example" set-global 2drop ] alien-callback ;
463 : double-rect-test ( arg callback -- arg' )
465 void { void* void* double-rect } cdecl alien-indirect
466 "example" get-global ;
468 { byte-array 1.0 2.0 3.0 4.0 } [
469 1.0 2.0 3.0 4.0 <double-rect>
470 double-rect-callback [
472 [ >c-ptr class-of ] [ >double-rect< ] bi
476 STRUCT: test_struct_14
480 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 )
483 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
486 : callback-10 ( -- callback )
487 test_struct_14 { double double } cdecl
489 test_struct_14 <struct>
494 : callback-10-test ( x1 x2 callback -- result )
495 test_struct_14 { double double } cdecl alien-indirect ;
498 1.0 2.0 callback-10 [
499 callback-10-test [ x1>> ] [ x2>> ] bi
503 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x )
510 : callback-11 ( -- callback )
511 test-struct-12 { int double } cdecl
513 test-struct-12 <struct>
518 : callback-11-test ( x1 x2 callback -- result )
519 test-struct-12 { int double } cdecl alien-indirect ;
523 callback-11-test [ a>> ] [ x>> ] bi
527 STRUCT: test_struct_15
531 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y )
533 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
535 : callback-12 ( -- callback )
536 test_struct_15 { float float } cdecl
538 test_struct_15 <struct>
543 : callback-12-test ( x1 x2 callback -- result )
544 test_struct_15 { float float } cdecl alien-indirect ;
547 1.0 2.0 callback-12 [
548 callback-12-test [ x>> ] [ y>> ] bi
552 STRUCT: test_struct_16
556 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a )
558 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
560 : callback-13 ( -- callback )
561 test_struct_16 { float int } cdecl
563 test_struct_16 <struct>
568 : callback-13-test ( x1 x2 callback -- result )
569 test_struct_16 { float int } cdecl alien-indirect ;
573 callback-13-test [ x>> ] [ a>> ] bi
577 FUNCTION: test_struct_14 ffi_test_44 ( ) inline
579 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
581 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
583 [ ] [ stack-frame-bustage 2drop ] unit-test
588 FUNCTION: complex-float ffi_test_45 ( int x )
590 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
592 FUNCTION: complex-double ffi_test_46 ( int x )
594 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
596 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y )
600 C{ 1.5 1.0 } ffi_test_47
604 STRUCT: bool-field-test
609 FUNCTION: short ffi_test_48 ( bool-field-test x )
612 bool-field-test <struct>
619 ! Test interaction between threads and callbacks
620 : thread-callback-1 ( -- callback )
621 int { } cdecl [ yield 100 ] alien-callback ;
623 : thread-callback-2 ( -- callback )
624 int { } cdecl [ yield 200 ] alien-callback ;
626 : thread-callback-invoker ( callback -- n )
627 int { } cdecl alien-indirect ;
632 thread-callback-invoker
633 ] with-callback "p" get fulfill
636 thread-callback-2 [ thread-callback-invoker ] with-callback
638 [ 100 ] [ "p" get ?promise ] unit-test
640 ! More alien-assembly tests are in cpu.* vocabs
641 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
643 [ ] [ assembly-test-1 ] unit-test
645 [ f ] [ "f-fastcall" library-dll f = ] unit-test
646 [ fastcall ] [ "f-fastcall" lookup-library abi>> ] unit-test
648 : ffi_test_49 ( x -- int )
649 int "f-fastcall" "ffi_test_49" { int } f
651 : ffi_test_50 ( x y -- int )
652 int "f-fastcall" "ffi_test_50" { int int } f
654 : ffi_test_51 ( x y z -- int )
655 int "f-fastcall" "ffi_test_51" { int int int } f
657 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
658 [ int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke ]
660 int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke gc ;
662 [ 4 ] [ 3 ffi_test_49 ] unit-test
663 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
664 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
665 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
667 : ffi_test_52 ( x y z -- int )
668 int "f-fastcall" "ffi_test_52" { int float int } f
670 : ffi_test_53 ( x y z w -- int )
671 int "f-fastcall" "ffi_test_53" { int float int int } f
673 : ffi_test_57 ( x y -- test-struct-11 )
674 test-struct-11 "f-fastcall" "ffi_test_57" { int int } f
676 : ffi_test_58 ( x y z -- test-struct-11 )
677 test-struct-11 "f-fastcall" "ffi_test_58" { int int int } f
680 ! Make sure that large longlong/ulonglong are correctly dealt with
681 FUNCTION: longlong ffi_test_59 ( longlong x )
682 FUNCTION: ulonglong ffi_test_60 ( ulonglong x )
684 [ t ] [ most-positive-fixnum 1 + [ ffi_test_59 ] keep = ] unit-test
685 [ t ] [ most-positive-fixnum 1 + [ ffi_test_60 ] keep = ] unit-test
687 [ -1 ] [ -1 ffi_test_59 ] unit-test
688 [ -1 ] [ 0xffffffffffffffff ffi_test_59 ] unit-test
689 [ 0xffffffffffffffff ] [ -1 ffi_test_60 ] unit-test
690 [ 0xffffffffffffffff ] [ 0xffffffffffffffff ffi_test_60 ] unit-test
694 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
696 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
699 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
701 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
703 : fastcall-ii-indirect ( x y ptr -- result )
704 int { int int } fastcall alien-indirect ;
706 : fastcall-iii-indirect ( x y z ptr -- result )
707 int { int int int } fastcall alien-indirect ;
709 : fastcall-ifi-indirect ( x y z ptr -- result )
710 int { int float int } fastcall alien-indirect ;
712 : fastcall-ifii-indirect ( x y z w ptr -- result )
713 int { int float int int } fastcall alien-indirect ;
715 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
716 test-struct-11 { int int } fastcall alien-indirect ;
718 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
719 test-struct-11 { int int int } fastcall alien-indirect ;
722 3 4 &: ffi_test_50 fastcall-ii-indirect
726 3 4 5 &: ffi_test_51 fastcall-iii-indirect
731 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect
735 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect
739 [ S{ test-struct-11 f 7 -1 } ]
741 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect
744 [ S{ test-struct-11 f 7 -3 } ]
746 3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect
749 : fastcall-ii-callback ( -- ptr )
750 int { int int } fastcall [ + 1 + ] alien-callback ;
752 : fastcall-iii-callback ( -- ptr )
753 int { int int int } fastcall [ + + 1 + ] alien-callback ;
755 : fastcall-ifi-callback ( -- ptr )
756 int { int float int } fastcall
757 [ [ >integer ] dip + + 1 + ] alien-callback ;
759 : fastcall-ifii-callback ( -- ptr )
760 int { int float int int } fastcall
761 [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
763 : fastcall-struct-return-ii-callback ( -- ptr )
764 test-struct-11 { int int } fastcall
765 [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
767 : fastcall-struct-return-iii-callback ( -- ptr )
768 test-struct-11 { int int int } fastcall
769 [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
772 3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback
776 3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback
780 3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback
784 3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback
787 [ S{ test-struct-11 f 7 -1 } ] [
788 3 4 fastcall-struct-return-ii-callback [
789 fastcall-struct-return-ii-indirect
793 [ S{ test-struct-11 f 7 -3 } ] [
794 3 4 7 fastcall-struct-return-iii-callback [
795 fastcall-struct-return-iii-indirect
799 : x64-regression-1 ( -- c )
800 int { int int int int int } cdecl [ + + + + ] alien-callback ;
802 : x64-regression-2 ( x x x x x c -- y )
803 int { int int int int int } cdecl alien-indirect ; inline
806 100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback
810 : blah ( -- x ) { RECT } [
811 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum
812 ] with-scoped-allocation ;
814 [ 3 ] [ blah ] unit-test
816 : out-param-test-1 ( -- b )
817 { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
819 [ 12 ] [ out-param-test-1 ] unit-test
821 : out-param-test-2 ( -- b )
822 { { int initial: 12 } } [ drop ] with-out-parameters ;
824 [ 12 ] [ out-param-test-2 ] unit-test
826 : out-param-test-3 ( -- x y )
827 { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
831 [ 3.0 4.0 ] [ out-param-test-3 ] unit-test
833 : out-param-callback ( -- a )
834 void { int pointer: int } cdecl
835 [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
837 : out-param-indirect ( a a -- b )
839 swap void { int pointer: int } cdecl
841 ] with-out-parameters ;
844 6 out-param-callback [ out-param-indirect ] with-callback
847 ! Alias analysis regression
848 : aa-callback-1 ( -- c )
849 double { } cdecl [ 5.0 ] alien-callback ;
851 : aa-indirect-1 ( c -- x )
852 double { } cdecl alien-indirect ; inline
854 TUPLE: some-tuple x ;
856 [ T{ some-tuple f 5.0 } ] [
866 : anton's-regression ( -- )
869 [ ] [ anton's-regression ] unit-test
877 FUNCTION: bool-and-ptr ffi_test_61 ( )
879 ! { S{ bool-and-ptr { b t } { ptr f } } } [ ffi_test_61 ] unit-test
880 { t } [ ffi_test_61 bool-and-ptr? ] unit-test
881 { { t f } } [ ffi_test_61 [ b>> ] [ ptr>> ] bi 2array ] unit-test
889 FUNCTION: uint-pair ffi_test_62 ( )
892 S{ uint-pair { a 0xabcdefab } { b 0x12345678 } }
893 } [ ffi_test_62 ] unit-test
895 STRUCT: ulonglong-pair
899 FUNCTION: ulonglong-pair ffi_test_63 ( )
902 S{ ulonglong-pair { a 0xabcdefabcdefabcd } { b 0x1234567891234567 } }
903 } [ ffi_test_63 ] unit-test
905 FUNCTION: void* bug1021_test_1 ( void* s, int x )
907 ! Sanity test the formula: x sq s +
909 10 [ [ 100 random ] twice 2array ] replicate
910 [ [ first2 [ <alien> ] dip bug1021_test_1 alien-address ] map ]
911 [ [ first2 sq + ] map ] bi =
914 : each-to100 ( ... quot: ( ... i -- ... ) i -- ... )
916 2dup swap (call) 1 + each-to100
917 ] [ 2drop ] if ; inline recursive
919 : run-test ( alien -- seq )
926 ] curry curry 0 each-to100 ;
931 ! If #1021 ever comes back it will blow up here because
932 ! alien-address wants an alien not a fixnum.
933 [ alien-address ] map drop
937 ! Varargs with non-float parameters works.
938 FUNCTION-ALIAS: do-sum-ints2 int ffi_test_64 ( int n, int a, int b )
939 FUNCTION-ALIAS: do-sum-ints3 int ffi_test_64 ( int n, int a, int b, int c )
943 3 10 20 30 do-sum-ints3
946 ! Varargs with non-floats doesn't work on windows
947 FUNCTION-ALIAS: do-sum-doubles2 double ffi_test_65 ( int n, double a, double b )
948 FUNCTION-ALIAS: do-sum-doubles3 double ffi_test_65 ( int n, double a, double b, double c )
952 2 7 20 do-sum-doubles2
953 3 5 10 7 do-sum-doubles3
957 FUNCTION: int bug1021_test_2 ( int a, char* b, void* c )
958 FUNCTION: void* bug1021_test_3 ( c-string a )
961 33 1byte-array "bar" bug1021_test_3 bug1021_test_2 ;
964 10000 [ 0 doit 33 assert= ] times
967 ! Tests for System V AMD64 ABI
968 STRUCT: test_struct_66 { mem1 ulong } { mem2 ulong } ;
969 STRUCT: test_struct_68 { mem1 ulong } { mem2 ulong } { mem3 ulong } ;
970 STRUCT: test_struct_69 { mem1 float } { mem2 ulong } { mem3 ulong } ;
971 FUNCTION: ulong ffi_test_66 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e )
972 FUNCTION: ulong ffi_test_67 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_66 e ulong _f )
973 FUNCTION: ulong ffi_test_68 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_68 e test_struct_66 _f )
974 FUNCTION: ulong ffi_test_69 ( ulong a, ulong b, ulong c, test_struct_66 d, test_struct_69 e test_struct_66 _f )
975 FUNCTION: ulong ffi_test_70 ( test_struct_68 a test_struct_68 b, test_struct_66 c )
977 { 28 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } ffi_test_66 ] unit-test
979 : callback-14 ( -- callback )
980 ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl
983 d [ mem1>> + ] [ mem2>> + ] bi
984 e [ mem1>> + ] [ mem2>> + ] bi
987 : callback-14-test ( a b c d e callback -- result )
988 ulong { ulong ulong ulong test_struct_66 test_struct_66 } cdecl alien-indirect ;
991 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } callback-14 [
996 { 44 } [ 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 ffi_test_67 ] unit-test
998 : callback-15 ( -- callback )
999 ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl
1002 d [ mem1>> + ] [ mem2>> + ] bi
1003 e [ mem1>> + ] [ mem2>> + ] bi
1007 : callback-15-test ( a b c d e _f callback -- result )
1008 ulong { ulong ulong ulong test_struct_66 test_struct_66 ulong } cdecl alien-indirect ;
1011 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_66 f 6 7 } 8 callback-15 [
1017 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } ffi_test_68
1020 : callback-16 ( -- callback )
1021 ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl
1024 d [ mem1>> + ] [ mem2>> + ] bi
1025 e [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
1026 _f [ mem1>> + ] [ mem2>> + ] bi
1029 : callback-16-test ( a b c d e _f callback -- result )
1030 ulong { ulong ulong ulong test_struct_66 test_struct_68 test_struct_66 } cdecl alien-indirect ;
1033 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_68 f 6 7 8 } S{ test_struct_66 f 9 10 } callback-16 [
1039 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } ffi_test_69
1042 : callback-17 ( -- callback )
1043 ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl
1046 d [ mem1>> + ] [ mem2>> + ] bi
1047 e [ mem1>> >integer + ] [ mem2>> + ] [ mem3>> + ] tri
1048 _f [ mem1>> + ] [ mem2>> + ] bi
1051 : callback-17-test ( a b c d e _f callback -- result )
1052 ulong { ulong ulong ulong test_struct_66 test_struct_69 test_struct_66 } cdecl alien-indirect ;
1055 1 2 3 S{ test_struct_66 f 4 5 } S{ test_struct_69 f 6.0 7 8 } S{ test_struct_66 f 9 10 } callback-17 [
1061 S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } ffi_test_70
1064 : callback-18 ( -- callback )
1065 ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl
1067 a [ mem1>> ] [ mem2>> + ] [ mem3>> + ] tri
1068 b [ mem1>> + ] [ mem2>> + ] [ mem3>> + ] tri
1069 c [ mem1>> + ] [ mem2>> + ] bi
1072 : callback-18-test ( a b c callback -- result )
1073 ulong { test_struct_68 test_struct_68 test_struct_66 } cdecl alien-indirect ;
1076 S{ test_struct_68 f 1 2 3 } S{ test_struct_68 f 4 5 6 } S{ test_struct_66 f 7 8 } callback-18 [