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 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 winnt? ] [ "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 FUNCTION: int ffi_test_2 int x int y ;
48 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
49 [ "hi" 3 ffi_test_2 ] must-fail
51 FUNCTION: int ffi_test_3 int x int y int z int t ;
52 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
54 FUNCTION: float ffi_test_4 ;
55 [ 1.5 ] [ ffi_test_4 ] unit-test
57 FUNCTION: double ffi_test_5 ;
58 [ 1.5 ] [ ffi_test_5 ] unit-test
60 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
61 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
62 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
63 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
65 STRUCT: FOO { x int } { y int } ;
67 : make-FOO ( x y -- FOO )
68 FOO <struct> swap >>y swap >>x ;
70 FUNCTION: int ffi_test_11 int a FOO b int c ;
72 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
74 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 ;
76 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
78 FUNCTION: FOO ffi_test_14 int x int y ;
80 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
82 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
84 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
85 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
86 [ 1 2 ffi_test_15 ] must-fail
88 STRUCT: BAR { x long } { y long } { z long } ;
90 FUNCTION: BAR ffi_test_16 long x long y long z ;
93 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
96 STRUCT: TINY { x int } ;
98 FUNCTION: TINY ffi_test_17 int x ;
100 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
102 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
104 : indirect-test-1 ( ptr -- result )
105 int { } cdecl alien-indirect ;
107 { 1 1 } [ indirect-test-1 ] must-infer-as
109 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
111 : indirect-test-1' ( ptr -- )
112 int { } cdecl alien-indirect drop ;
114 { 1 0 } [ indirect-test-1' ] must-infer-as
116 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
118 [ -1 indirect-test-1 ] must-fail
120 : indirect-test-2 ( x y ptr -- result )
121 int { int int } cdecl alien-indirect gc ;
123 { 3 1 } [ indirect-test-2 ] must-infer-as
126 [ 2 3 &: ffi_test_2 indirect-test-2 ]
129 : indirect-test-3 ( a b c d ptr -- result )
130 int { int int int int } stdcall alien-indirect
133 [ f ] [ "f-stdcall" load-library f = ] unit-test
134 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
136 : ffi_test_18 ( w x y z -- int )
137 int "f-stdcall" "ffi_test_18" { int int int int }
140 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
142 : ffi_test_19 ( x y z -- BAR )
143 BAR "f-stdcall" "ffi_test_19" { long long long }
147 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
150 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
151 [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
153 int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
156 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
158 FUNCTION: double ffi_test_6 float x float y ;
159 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
160 [ "a" "b" ffi_test_6 ] must-fail
162 FUNCTION: double ffi_test_7 double x double y ;
163 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
165 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
166 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
168 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
169 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
171 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
172 double y1, double y2, double y3,
173 double z1, double z2, double z3 ;
175 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
177 ! Make sure XT doesn't get clobbered in stack frame
179 : 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 )
181 "f-cdecl" "ffi_test_31"
182 { 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 }
185 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
187 : 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 )
189 "f-cdecl" "ffi_test_31_point_5"
190 { 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 }
193 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
195 FUNCTION: longlong ffi_test_21 long x long y ;
197 [ 121932631112635269 ]
198 [ 123456789 987654321 ffi_test_21 ] unit-test
200 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
203 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
205 [ 1111 f 123456789 ffi_test_22 ] must-fail
208 { x float } { y float }
209 { w float } { h float } ;
211 : <RECT> ( x y w h -- rect )
218 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
220 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
222 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
224 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
227 { 1.0 2.0 3.0 } >float-array
228 { 4.0 5.0 6.0 } >float-array
232 ! Test odd-size structs
233 STRUCT: test-struct-1 { x char[1] } ;
235 FUNCTION: test-struct-1 ffi_test_24 ;
237 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
239 STRUCT: test-struct-2 { x char[2] } ;
241 FUNCTION: test-struct-2 ffi_test_25 ;
243 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
245 STRUCT: test-struct-3 { x char[3] } ;
247 FUNCTION: test-struct-3 ffi_test_26 ;
249 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
251 STRUCT: test-struct-4 { x char[4] } ;
253 FUNCTION: test-struct-4 ffi_test_27 ;
255 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
257 STRUCT: test-struct-5 { x char[5] } ;
259 FUNCTION: test-struct-5 ffi_test_28 ;
261 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
263 STRUCT: test-struct-6 { x char[6] } ;
265 FUNCTION: test-struct-6 ffi_test_29 ;
267 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
269 STRUCT: test-struct-7 { x char[7] } ;
271 FUNCTION: test-struct-7 ffi_test_30 ;
273 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
275 STRUCT: test-struct-8 { x double } { y double } ;
277 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
280 test-struct-8 <struct>
286 STRUCT: test-struct-9 { x float } { y float } ;
288 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
291 test-struct-9 <struct>
297 STRUCT: test-struct-10 { x float } { y int } ;
299 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
302 test-struct-10 <struct>
308 STRUCT: test-struct-11 { x int } { y int } ;
310 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
313 test-struct-11 <struct>
319 STRUCT: test-struct-12 { a int } { x double } ;
321 : make-struct-12 ( x -- alien )
322 test-struct-12 <struct>
325 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
327 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
329 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
331 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
335 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
337 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
339 [ t ] [ callback-1 alien? ] unit-test
341 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
343 [ ] [ callback-1 callback_test_1 ] unit-test
345 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
347 [ ] [ callback-2 callback_test_1 ] unit-test
349 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
354 3 "x" set callback-3 callback_test_1
356 "x" get "x" get-global
360 : callback-5 ( -- callback )
361 void { } cdecl [ gc ] alien-callback ;
364 "testing" callback-5 callback_test_1
367 : callback-5b ( -- callback )
368 void { } cdecl [ compact-gc ] alien-callback ;
371 "testing" callback-5b callback_test_1
374 : callback-6 ( -- callback )
375 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
377 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
379 : callback-7 ( -- callback )
380 void { } cdecl [ 1000000 sleep ] alien-callback ;
382 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
384 [ f ] [ namespace global eq? ] unit-test
386 : callback-8 ( -- callback )
387 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
389 [ ] [ callback-8 callback_test_1 ] unit-test
391 : callback-9 ( -- callback )
392 int { int int int } cdecl [
396 FUNCTION: void ffi_test_36_point_5 ( ) ;
398 [ ] [ ffi_test_36_point_5 ] unit-test
400 FUNCTION: int ffi_test_37 ( void* func ) ;
402 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
404 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
406 STRUCT: test_struct_13
414 : make-test-struct-13 ( -- alien )
415 test_struct_13 <struct>
423 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
425 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
427 ! Joe Groff found this problem
434 : <double-rect> ( a b c d -- foo )
441 : >double-rect< ( foo -- a b c d )
449 : double-rect-callback ( -- alien )
450 void { void* void* double-rect } cdecl
451 [ "example" set-global 2drop ] alien-callback ;
453 : double-rect-test ( arg callback -- arg' )
455 void { void* void* double-rect } cdecl alien-indirect
456 "example" get-global ;
460 1.0 2.0 3.0 4.0 <double-rect>
461 double-rect-callback double-rect-test
465 STRUCT: test_struct_14
469 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
472 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
475 : callback-10 ( -- callback )
476 test_struct_14 { double double } cdecl
478 test_struct_14 <struct>
483 : callback-10-test ( x1 x2 callback -- result )
484 test_struct_14 { double double } cdecl alien-indirect ;
487 1.0 2.0 callback-10 callback-10-test
491 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
498 : callback-11 ( -- callback )
499 test-struct-12 { int double } cdecl
501 test-struct-12 <struct>
506 : callback-11-test ( x1 x2 callback -- result )
507 test-struct-12 { int double } cdecl alien-indirect ;
510 1 2.0 callback-11 callback-11-test
514 STRUCT: test_struct_15
518 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
520 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
522 : callback-12 ( -- callback )
523 test_struct_15 { float float } cdecl
525 test_struct_15 <struct>
530 : callback-12-test ( x1 x2 callback -- result )
531 test_struct_15 { float float } cdecl alien-indirect ;
534 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
537 STRUCT: test_struct_16
541 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
543 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
545 : callback-13 ( -- callback )
546 test_struct_16 { float int } cdecl
548 test_struct_16 <struct>
553 : callback-13-test ( x1 x2 callback -- result )
554 test_struct_16 { float int } cdecl alien-indirect ;
557 1.0 2 callback-13 callback-13-test
561 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
563 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
565 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
567 [ ] [ stack-frame-bustage 2drop ] unit-test
572 FUNCTION: complex-float ffi_test_45 ( int x ) ;
574 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
576 FUNCTION: complex-double ffi_test_46 ( int x ) ;
578 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
580 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
584 C{ 1.5 1.0 } ffi_test_47
588 STRUCT: bool-field-test
593 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
596 bool-field-test <struct>
603 ! Test interaction between threads and callbacks
604 : thread-callback-1 ( -- callback )
605 int { } cdecl [ yield 100 ] alien-callback ;
607 : thread-callback-2 ( -- callback )
608 int { } cdecl [ yield 200 ] alien-callback ;
610 : thread-callback-invoker ( callback -- n )
611 int { } cdecl alien-indirect ;
614 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
615 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
616 [ 100 ] [ "p" get ?promise ] unit-test
618 ! More alien-assembly tests are in cpu.* vocabs
619 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
621 [ ] [ assembly-test-1 ] unit-test
623 [ f ] [ "f-fastcall" load-library f = ] unit-test
624 [ fastcall ] [ "f-fastcall" library abi>> ] unit-test
626 : ffi_test_49 ( x -- int )
627 int "f-fastcall" "ffi_test_49" { int }
629 : ffi_test_50 ( x y -- int )
630 int "f-fastcall" "ffi_test_50" { int int }
632 : ffi_test_51 ( x y z -- int )
633 int "f-fastcall" "ffi_test_51" { int int int }
635 : multi_ffi_test_51 ( x y z x' y' z' -- int int )
636 [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
638 int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
640 [ 4 ] [ 3 ffi_test_49 ] unit-test
641 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
642 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
643 [ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
645 : ffi_test_52 ( x y z -- int )
646 int "f-fastcall" "ffi_test_52" { int float int }
648 : ffi_test_53 ( x y z w -- int )
649 int "f-fastcall" "ffi_test_53" { int float int int }
651 : ffi_test_57 ( x y -- test-struct-11 )
652 test-struct-11 "f-fastcall" "ffi_test_57" { int int }
654 : ffi_test_58 ( x y z -- test-struct-11 )
655 test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
660 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
662 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
665 [ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
667 [ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
669 : fastcall-ii-indirect ( x y ptr -- result )
670 int { int int } fastcall alien-indirect ;
672 : fastcall-iii-indirect ( x y z ptr -- result )
673 int { int int int } fastcall alien-indirect ;
675 : fastcall-ifi-indirect ( x y z ptr -- result )
676 int { int float int } fastcall alien-indirect ;
678 : fastcall-ifii-indirect ( x y z w ptr -- result )
679 int { int float int int } fastcall alien-indirect ;
681 : fastcall-struct-return-ii-indirect ( x y ptr -- result )
682 test-struct-11 { int int } fastcall alien-indirect ;
684 : fastcall-struct-return-iii-indirect ( x y z ptr -- result )
685 test-struct-11 { int int int } fastcall alien-indirect ;
687 : win32? ( -- ? ) os windows? cpu x86.32? and ;
691 win32? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
697 win32? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
698 fastcall-iii-indirect
704 win32? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
705 fastcall-ifi-indirect
710 win32? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
711 fastcall-ifii-indirect
715 [ S{ test-struct-11 f 7 -1 } ]
718 win32? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
719 fastcall-struct-return-ii-indirect
722 [ S{ test-struct-11 f 7 -3 } ]
725 win32? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
726 fastcall-struct-return-iii-indirect
729 : fastcall-ii-callback ( -- ptr )
730 int { int int } fastcall [ + 1 + ] alien-callback ;
732 : fastcall-iii-callback ( -- ptr )
733 int { int int int } fastcall [ + + 1 + ] alien-callback ;
735 : fastcall-ifi-callback ( -- ptr )
736 int { int float int } fastcall
737 [ [ >integer ] dip + + 1 + ] alien-callback ;
739 : fastcall-ifii-callback ( -- ptr )
740 int { int float int int } fastcall
741 [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
743 : fastcall-struct-return-ii-callback ( -- ptr )
744 test-struct-11 { int int } fastcall
745 [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
747 : fastcall-struct-return-iii-callback ( -- ptr )
748 test-struct-11 { int int int } fastcall
749 [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
751 [ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
753 [ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
755 [ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
757 [ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
759 [ S{ test-struct-11 f 7 -1 } ]
760 [ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
762 [ S{ test-struct-11 f 7 -3 } ]
763 [ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
766 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
768 [ 3 ] [ blah ] unit-test