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 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
104 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
106 : indirect-test-1' ( ptr -- )
107 int { } cdecl alien-indirect drop ;
109 { 1 0 } [ indirect-test-1' ] must-infer-as
111 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
113 [ -1 indirect-test-1 ] must-fail
115 : indirect-test-2 ( x y ptr -- result )
116 int { int int } cdecl alien-indirect gc ;
118 { 3 1 } [ indirect-test-2 ] must-infer-as
121 [ 2 3 &: ffi_test_2 indirect-test-2 ]
124 : indirect-test-3 ( a b c d ptr -- result )
125 int { int int int int } stdcall alien-indirect
128 [ f ] [ "f-stdcall" load-library f = ] unit-test
129 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
131 : ffi_test_18 ( w x y z -- int )
132 int "f-stdcall" "ffi_test_18" { int int int int }
135 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
137 : ffi_test_19 ( x y z -- BAR )
138 BAR "f-stdcall" "ffi_test_19" { long long long }
142 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
145 : multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
146 [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
148 int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
151 [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
153 FUNCTION: double ffi_test_6 float x float y ;
154 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
155 [ "a" "b" ffi_test_6 ] must-fail
157 FUNCTION: double ffi_test_7 double x double y ;
158 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
160 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
161 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
163 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
164 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
166 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
167 double y1, double y2, double y3,
168 double z1, double z2, double z3 ;
170 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
172 ! Make sure XT doesn't get clobbered in stack frame
174 : 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 )
176 "f-cdecl" "ffi_test_31"
177 { 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 }
180 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
182 : 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 )
184 "f-cdecl" "ffi_test_31_point_5"
185 { 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 }
188 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
190 FUNCTION: longlong ffi_test_21 long x long y ;
192 [ 121932631112635269 ]
193 [ 123456789 987654321 ffi_test_21 ] unit-test
195 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
198 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
200 [ 1111 f 123456789 ffi_test_22 ] must-fail
203 { x float } { y float }
204 { w float } { h float } ;
206 : <RECT> ( x y w h -- rect )
213 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
215 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
217 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
219 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
222 { 1.0 2.0 3.0 } >float-array
223 { 4.0 5.0 6.0 } >float-array
227 ! Test odd-size structs
228 STRUCT: test-struct-1 { x char[1] } ;
230 FUNCTION: test-struct-1 ffi_test_24 ;
232 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
234 STRUCT: test-struct-2 { x char[2] } ;
236 FUNCTION: test-struct-2 ffi_test_25 ;
238 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
240 STRUCT: test-struct-3 { x char[3] } ;
242 FUNCTION: test-struct-3 ffi_test_26 ;
244 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
246 STRUCT: test-struct-4 { x char[4] } ;
248 FUNCTION: test-struct-4 ffi_test_27 ;
250 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
252 STRUCT: test-struct-5 { x char[5] } ;
254 FUNCTION: test-struct-5 ffi_test_28 ;
256 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
258 STRUCT: test-struct-6 { x char[6] } ;
260 FUNCTION: test-struct-6 ffi_test_29 ;
262 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
264 STRUCT: test-struct-7 { x char[7] } ;
266 FUNCTION: test-struct-7 ffi_test_30 ;
268 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
270 STRUCT: test-struct-8 { x double } { y double } ;
272 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
275 test-struct-8 <struct>
281 STRUCT: test-struct-9 { x float } { y float } ;
283 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
286 test-struct-9 <struct>
292 STRUCT: test-struct-10 { x float } { y int } ;
294 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
297 test-struct-10 <struct>
303 STRUCT: test-struct-11 { x int } { y int } ;
305 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
308 test-struct-11 <struct>
314 STRUCT: test-struct-12 { a int } { x double } ;
316 : make-struct-12 ( x -- alien )
317 test-struct-12 <struct>
320 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
322 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
324 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
326 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
330 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
332 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
334 [ t ] [ callback-1 alien? ] unit-test
336 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
338 [ ] [ callback-1 callback_test_1 ] unit-test
340 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
342 [ ] [ callback-2 callback_test_1 ] unit-test
344 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
349 3 "x" set callback-3 callback_test_1
351 "x" get "x" get-global
355 : callback-5 ( -- callback )
356 void { } cdecl [ gc ] alien-callback ;
359 "testing" callback-5 callback_test_1
362 : callback-5b ( -- callback )
363 void { } cdecl [ compact-gc ] alien-callback ;
366 "testing" callback-5b callback_test_1
369 : callback-6 ( -- callback )
370 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
372 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
374 : callback-7 ( -- callback )
375 void { } cdecl [ 1000000 sleep ] alien-callback ;
377 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
379 [ f ] [ namespace global eq? ] unit-test
381 : callback-8 ( -- callback )
382 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
384 [ ] [ callback-8 callback_test_1 ] unit-test
386 : callback-9 ( -- callback )
387 int { int int int } cdecl [
391 FUNCTION: void ffi_test_36_point_5 ( ) ;
393 [ ] [ ffi_test_36_point_5 ] unit-test
395 FUNCTION: int ffi_test_37 ( void* func ) ;
397 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
399 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
401 STRUCT: test_struct_13
409 : make-test-struct-13 ( -- alien )
410 test_struct_13 <struct>
418 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
420 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
422 ! Joe Groff found this problem
429 : <double-rect> ( a b c d -- foo )
436 : >double-rect< ( foo -- a b c d )
444 : double-rect-callback ( -- alien )
445 void { void* void* double-rect } cdecl
446 [ "example" set-global 2drop ] alien-callback ;
448 : double-rect-test ( arg callback -- arg' )
450 void { void* void* double-rect } cdecl alien-indirect
451 "example" get-global ;
455 1.0 2.0 3.0 4.0 <double-rect>
456 double-rect-callback double-rect-test
460 STRUCT: test_struct_14
464 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
467 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
470 : callback-10 ( -- callback )
471 test_struct_14 { double double } cdecl
473 test_struct_14 <struct>
478 : callback-10-test ( x1 x2 callback -- result )
479 test_struct_14 { double double } cdecl alien-indirect ;
482 1.0 2.0 callback-10 callback-10-test
486 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
493 : callback-11 ( -- callback )
494 test-struct-12 { int double } cdecl
496 test-struct-12 <struct>
501 : callback-11-test ( x1 x2 callback -- result )
502 test-struct-12 { int double } cdecl alien-indirect ;
505 1 2.0 callback-11 callback-11-test
509 STRUCT: test_struct_15
513 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
515 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
517 : callback-12 ( -- callback )
518 test_struct_15 { float float } cdecl
520 test_struct_15 <struct>
525 : callback-12-test ( x1 x2 callback -- result )
526 test_struct_15 { float float } cdecl alien-indirect ;
529 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
532 STRUCT: test_struct_16
536 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
538 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
540 : callback-13 ( -- callback )
541 test_struct_16 { float int } cdecl
543 test_struct_16 <struct>
548 : callback-13-test ( x1 x2 callback -- result )
549 test_struct_16 { float int } cdecl alien-indirect ;
552 1.0 2 callback-13 callback-13-test
556 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
558 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
560 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
562 [ ] [ stack-frame-bustage 2drop ] unit-test
567 FUNCTION: complex-float ffi_test_45 ( int x ) ;
569 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
571 FUNCTION: complex-double ffi_test_46 ( int x ) ;
573 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
575 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
579 C{ 1.5 1.0 } ffi_test_47
583 STRUCT: bool-field-test
588 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
591 bool-field-test <struct>
598 ! Test interaction between threads and callbacks
599 : thread-callback-1 ( -- callback )
600 int { } cdecl [ yield 100 ] alien-callback ;
602 : thread-callback-2 ( -- callback )
603 int { } cdecl [ yield 200 ] alien-callback ;
605 : thread-callback-invoker ( callback -- n )
606 int { } cdecl alien-indirect ;
609 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
610 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
611 [ 100 ] [ "p" get ?promise ] unit-test
613 ! Regression: calling an undefined function would raise a protection fault
614 FUNCTION: void this_does_not_exist ( ) ;
616 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
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