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 ;
9 FROM: alien.c-types => float short ;
10 SPECIALIZED-ARRAY: float
11 SPECIALIZED-ARRAY: char
12 IN: compiler.tests.alien
15 : libfactor-ffi-tests-path ( -- string )
16 "resource:" absolute-path
18 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
19 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
20 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
23 : mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
25 "f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
27 "f-stdcall" libfactor-ffi-tests-path stdcall add-library
29 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
34 FUNCTION: void ffi_test_0 ;
35 [ ] [ ffi_test_0 ] unit-test
37 FUNCTION: int ffi_test_1 ;
38 [ 3 ] [ ffi_test_1 ] unit-test
40 FUNCTION: int ffi_test_2 int x int y ;
41 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
42 [ "hi" 3 ffi_test_2 ] must-fail
44 FUNCTION: int ffi_test_3 int x int y int z int t ;
45 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
47 FUNCTION: float ffi_test_4 ;
48 [ 1.5 ] [ ffi_test_4 ] unit-test
50 FUNCTION: double ffi_test_5 ;
51 [ 1.5 ] [ ffi_test_5 ] unit-test
53 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
54 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
55 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
56 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
58 STRUCT: FOO { x int } { y int } ;
60 : make-FOO ( x y -- FOO )
61 FOO <struct> swap >>y swap >>x ;
63 FUNCTION: int ffi_test_11 int a FOO b int c ;
65 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
67 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 ;
69 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
71 FUNCTION: FOO ffi_test_14 int x int y ;
73 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
75 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
77 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
78 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
79 [ 1 2 ffi_test_15 ] must-fail
81 STRUCT: BAR { x long } { y long } { z long } ;
83 FUNCTION: BAR ffi_test_16 long x long y long z ;
86 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
89 STRUCT: TINY { x int } ;
91 FUNCTION: TINY ffi_test_17 int x ;
93 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
95 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
97 : indirect-test-1 ( ptr -- result )
98 int { } cdecl alien-indirect ;
100 { 1 1 } [ indirect-test-1 ] must-infer-as
102 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
104 : indirect-test-1' ( ptr -- )
105 int { } cdecl alien-indirect drop ;
107 { 1 0 } [ indirect-test-1' ] must-infer-as
109 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
111 [ -1 indirect-test-1 ] must-fail
113 : indirect-test-2 ( x y ptr -- result )
114 int { int int } cdecl alien-indirect gc ;
116 { 3 1 } [ indirect-test-2 ] must-infer-as
119 [ 2 3 &: ffi_test_2 indirect-test-2 ]
122 : indirect-test-3 ( a b c d ptr -- result )
123 int { int int int int } stdcall alien-indirect
126 [ f ] [ "f-stdcall" load-library f = ] unit-test
127 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
129 : ffi_test_18 ( w x y z -- int )
130 int "f-stdcall" "ffi_test_18" { int int int int }
133 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
135 : ffi_test_19 ( x y z -- BAR )
136 BAR "f-stdcall" "ffi_test_19" { long long long }
140 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
143 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
144 [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
146 int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
149 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
151 FUNCTION: double ffi_test_6 float x float y ;
152 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
153 [ "a" "b" ffi_test_6 ] must-fail
155 FUNCTION: double ffi_test_7 double x double y ;
156 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
158 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
159 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
161 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
162 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
164 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
165 double y1, double y2, double y3,
166 double z1, double z2, double z3 ;
168 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
170 ! Make sure XT doesn't get clobbered in stack frame
172 : 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 )
174 "f-cdecl" "ffi_test_31"
175 { 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 }
178 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
180 : 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 )
182 "f-cdecl" "ffi_test_31_point_5"
183 { 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 }
186 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
188 FUNCTION: longlong ffi_test_21 long x long y ;
190 [ 121932631112635269 ]
191 [ 123456789 987654321 ffi_test_21 ] unit-test
193 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
196 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
198 [ 1111 f 123456789 ffi_test_22 ] must-fail
201 { x float } { y float }
202 { w float } { h float } ;
204 : <RECT> ( x y w h -- rect )
211 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
213 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
215 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
217 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
220 { 1.0 2.0 3.0 } >float-array
221 { 4.0 5.0 6.0 } >float-array
225 ! Test odd-size structs
226 STRUCT: test-struct-1 { x char[1] } ;
228 FUNCTION: test-struct-1 ffi_test_24 ;
230 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
232 STRUCT: test-struct-2 { x char[2] } ;
234 FUNCTION: test-struct-2 ffi_test_25 ;
236 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
238 STRUCT: test-struct-3 { x char[3] } ;
240 FUNCTION: test-struct-3 ffi_test_26 ;
242 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
244 STRUCT: test-struct-4 { x char[4] } ;
246 FUNCTION: test-struct-4 ffi_test_27 ;
248 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
250 STRUCT: test-struct-5 { x char[5] } ;
252 FUNCTION: test-struct-5 ffi_test_28 ;
254 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
256 STRUCT: test-struct-6 { x char[6] } ;
258 FUNCTION: test-struct-6 ffi_test_29 ;
260 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
262 STRUCT: test-struct-7 { x char[7] } ;
264 FUNCTION: test-struct-7 ffi_test_30 ;
266 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
268 STRUCT: test-struct-8 { x double } { y double } ;
270 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
273 test-struct-8 <struct>
279 STRUCT: test-struct-9 { x float } { y float } ;
281 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
284 test-struct-9 <struct>
290 STRUCT: test-struct-10 { x float } { y int } ;
292 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
295 test-struct-10 <struct>
301 STRUCT: test-struct-11 { x int } { y int } ;
303 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
306 test-struct-11 <struct>
312 STRUCT: test-struct-12 { a int } { x double } ;
314 : make-struct-12 ( x -- alien )
315 test-struct-12 <struct>
318 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
320 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
322 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
324 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
328 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
330 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
332 [ t ] [ callback-1 alien? ] unit-test
334 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
336 [ ] [ callback-1 callback_test_1 ] unit-test
338 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
340 [ ] [ callback-2 callback_test_1 ] unit-test
342 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
347 3 "x" set callback-3 callback_test_1
349 "x" get "x" get-global
353 : callback-5 ( -- callback )
354 void { } cdecl [ gc ] alien-callback ;
357 "testing" callback-5 callback_test_1
360 : callback-5b ( -- callback )
361 void { } cdecl [ compact-gc ] alien-callback ;
364 "testing" callback-5b callback_test_1
367 : callback-6 ( -- callback )
368 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
370 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
372 : callback-7 ( -- callback )
373 void { } cdecl [ 1000000 sleep ] alien-callback ;
375 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
377 [ f ] [ namespace global eq? ] unit-test
379 : callback-8 ( -- callback )
380 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
382 [ ] [ callback-8 callback_test_1 ] unit-test
384 : callback-9 ( -- callback )
385 int { int int int } cdecl [
389 FUNCTION: void ffi_test_36_point_5 ( ) ;
391 [ ] [ ffi_test_36_point_5 ] unit-test
393 FUNCTION: int ffi_test_37 ( void* func ) ;
395 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
397 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
399 STRUCT: test_struct_13
407 : make-test-struct-13 ( -- alien )
408 test_struct_13 <struct>
416 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
418 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
420 ! Joe Groff found this problem
427 : <double-rect> ( a b c d -- foo )
434 : >double-rect< ( foo -- a b c d )
442 : double-rect-callback ( -- alien )
443 void { void* void* double-rect } cdecl
444 [ "example" set-global 2drop ] alien-callback ;
446 : double-rect-test ( arg callback -- arg' )
448 void { void* void* double-rect } cdecl alien-indirect
449 "example" get-global ;
453 1.0 2.0 3.0 4.0 <double-rect>
454 double-rect-callback double-rect-test
458 STRUCT: test_struct_14
462 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
465 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
468 : callback-10 ( -- callback )
469 test_struct_14 { double double } cdecl
471 test_struct_14 <struct>
476 : callback-10-test ( x1 x2 callback -- result )
477 test_struct_14 { double double } cdecl alien-indirect ;
480 1.0 2.0 callback-10 callback-10-test
484 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
491 : callback-11 ( -- callback )
492 test-struct-12 { int double } cdecl
494 test-struct-12 <struct>
499 : callback-11-test ( x1 x2 callback -- result )
500 test-struct-12 { int double } cdecl alien-indirect ;
503 1 2.0 callback-11 callback-11-test
507 STRUCT: test_struct_15
511 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
513 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
515 : callback-12 ( -- callback )
516 test_struct_15 { float float } cdecl
518 test_struct_15 <struct>
523 : callback-12-test ( x1 x2 callback -- result )
524 test_struct_15 { float float } cdecl alien-indirect ;
527 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
530 STRUCT: test_struct_16
534 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
536 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
538 : callback-13 ( -- callback )
539 test_struct_16 { float int } cdecl
541 test_struct_16 <struct>
546 : callback-13-test ( x1 x2 callback -- result )
547 test_struct_16 { float int } cdecl alien-indirect ;
550 1.0 2 callback-13 callback-13-test
554 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
556 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
558 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
560 [ ] [ stack-frame-bustage 2drop ] unit-test
565 FUNCTION: complex-float ffi_test_45 ( int x ) ;
567 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
569 FUNCTION: complex-double ffi_test_46 ( int x ) ;
571 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
573 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
577 C{ 1.5 1.0 } ffi_test_47
581 STRUCT: bool-field-test
586 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
589 bool-field-test <struct>
596 ! Test interaction between threads and callbacks
597 : thread-callback-1 ( -- callback )
598 int { } cdecl [ yield 100 ] alien-callback ;
600 : thread-callback-2 ( -- callback )
601 int { } cdecl [ yield 200 ] alien-callback ;
603 : thread-callback-invoker ( callback -- n )
604 int { } cdecl alien-indirect ;
607 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
608 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
609 [ 100 ] [ "p" get ?promise ] unit-test
611 ! More alien-assembly tests are in cpu.* vocabs
612 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
614 [ ] [ assembly-test-1 ] unit-test
616 [ f ] [ "f-fastcall" load-library f = ] unit-test
617 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
619 : ffi_test_49 ( x -- int )
620 int "f-fastcall" "ffi_test_49" { int }
622 : ffi_test_50 ( x y -- int )
623 int "f-fastcall" "ffi_test_50" { int int }
625 : ffi_test_51 ( x y z -- int )
626 int "f-fastcall" "ffi_test_51" { int int int }
628 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
629 [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
631 int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
633 [ 4 ] [ 3 ffi_test_49 ] unit-test
634 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
635 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
636 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
638 : ffi_test_52 ( x y z -- int )
639 int "f-fastcall" "ffi_test_52" { int float int }
641 : ffi_test_53 ( x y z w -- int )
642 int "f-fastcall" "ffi_test_53" { int float int int }
644 : ffi_test_57 ( x y -- test-struct-11 )
645 test-struct-11 "f-fastcall" "ffi_test_57" { int int }
647 : ffi_test_58 ( x y z -- test-struct-11 )
648 test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
653 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
655 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
658 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
660 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
662 : fastcall-ii-indirect ( x y ptr -- result )
663 int { int int } fastcall alien-indirect ;
665 : fastcall-iii-indirect ( x y z ptr -- result )
666 int { int int int } fastcall alien-indirect ;
668 : fastcall-ifi-indirect ( x y z ptr -- result )
669 int { int float int } fastcall alien-indirect ;
671 : fastcall-ifii-indirect ( x y z w ptr -- result )
672 int { int float int int } fastcall alien-indirect ;
674 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
675 test-struct-11 { int int } fastcall alien-indirect ;
677 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
678 test-struct-11 { int int int } fastcall alien-indirect ;
680 : win32? ( -- ? ) os windows? cpu x86.32? and ;
684 win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
690 win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
691 fastcall-iii-indirect
697 win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
698 fastcall-ifi-indirect
703 win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
704 fastcall-ifii-indirect
708 [ S{ test-struct-11 f 7 -1 } ]
711 win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
712 fastcall-struct-return-ii-indirect
715 [ S{ test-struct-11 f 7 -3 } ]
718 win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
719 fastcall-struct-return-iii-indirect
722 : fastcall-ii-callback ( -- ptr )
723 int { int int } fastcall [ + 1 + ] alien-callback ;
725 : fastcall-iii-callback ( -- ptr )
726 int { int int int } fastcall [ + + 1 + ] alien-callback ;
728 : fastcall-ifi-callback ( -- ptr )
729 int { int float int } fastcall
730 [ [ >integer ] dip + + 1 + ] alien-callback ;
732 : fastcall-ifii-callback ( -- ptr )
733 int { int float int int } fastcall
734 [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
736 : fastcall-struct-return-ii-callback ( -- ptr )
737 test-struct-11 { int int } fastcall
738 [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
740 : fastcall-struct-return-iii-callback ( -- ptr )
741 test-struct-11 { int int int } fastcall
742 [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
744 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
746 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
748 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
750 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
752 [ S{ test-struct-11 f 7 -1 } ]
753 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
755 [ S{ test-struct-11 f 7 -3 } ]
756 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test