1 USING: accessors alien alien.c-types alien.libraries
2 alien.syntax arrays classes.struct combinators
3 compiler continuations effects io io.backend io.pathnames
4 io.streams.string kernel math memory namespaces
5 namespaces.private parser quotations sequences
6 specialized-arrays stack-checker stack-checker.errors
7 system threads tools.test words alien.complex ;
8 FROM: alien.c-types => float short ;
9 SPECIALIZED-ARRAY: float
10 SPECIALIZED-ARRAY: char
11 IN: compiler.tests.alien
14 : libfactor-ffi-tests-path ( -- string )
15 "resource:" absolute-path
17 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
18 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
19 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
22 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
24 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
29 FUNCTION: void ffi_test_0 ;
30 [ ] [ ffi_test_0 ] unit-test
32 FUNCTION: int ffi_test_1 ;
33 [ 3 ] [ ffi_test_1 ] unit-test
35 FUNCTION: int ffi_test_2 int x int y ;
36 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
37 [ "hi" 3 ffi_test_2 ] must-fail
39 FUNCTION: int ffi_test_3 int x int y int z int t ;
40 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
42 FUNCTION: float ffi_test_4 ;
43 [ 1.5 ] [ ffi_test_4 ] unit-test
45 FUNCTION: double ffi_test_5 ;
46 [ 1.5 ] [ ffi_test_5 ] unit-test
48 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
49 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
50 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
51 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
53 STRUCT: FOO { x int } { y int } ;
55 : make-FOO ( x y -- FOO )
56 FOO <struct> swap >>y swap >>x ;
58 FUNCTION: int ffi_test_11 int a FOO b int c ;
60 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
62 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 ;
64 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
66 FUNCTION: FOO ffi_test_14 int x int y ;
68 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
70 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
72 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
73 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
74 [ 1 2 ffi_test_15 ] must-fail
76 STRUCT: BAR { x long } { y long } { z long } ;
78 FUNCTION: BAR ffi_test_16 long x long y long z ;
81 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
84 STRUCT: TINY { x int } ;
86 FUNCTION: TINY ffi_test_17 int x ;
88 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
90 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
92 : indirect-test-1 ( ptr -- result )
93 int { } "cdecl" alien-indirect ;
95 { 1 1 } [ indirect-test-1 ] must-infer-as
97 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
99 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
101 : indirect-test-1' ( ptr -- )
102 int { } "cdecl" alien-indirect drop ;
104 { 1 0 } [ indirect-test-1' ] must-infer-as
106 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
108 [ -1 indirect-test-1 ] must-fail
110 : indirect-test-2 ( x y ptr -- result )
111 int { int int } "cdecl" alien-indirect gc ;
113 { 3 1 } [ indirect-test-2 ] must-infer-as
116 [ 2 3 &: ffi_test_2 indirect-test-2 ]
119 : indirect-test-3 ( a b c d ptr -- result )
120 int { int int int int } "stdcall" alien-indirect
123 [ f ] [ "f-stdcall" load-library f = ] unit-test
124 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
126 : ffi_test_18 ( w x y z -- int )
127 int "f-stdcall" "ffi_test_18" { int int int int }
130 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
132 : ffi_test_19 ( x y z -- BAR )
133 BAR "f-stdcall" "ffi_test_19" { long long long }
137 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
140 FUNCTION: double ffi_test_6 float x float y ;
141 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
142 [ "a" "b" ffi_test_6 ] must-fail
144 FUNCTION: double ffi_test_7 double x double y ;
145 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
147 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
148 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
150 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
151 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
153 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
154 double y1, double y2, double y3,
155 double z1, double z2, double z3 ;
157 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
159 ! Make sure XT doesn't get clobbered in stack frame
161 : 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 )
163 "f-cdecl" "ffi_test_31"
164 { 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 }
167 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
169 : 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 )
171 "f-cdecl" "ffi_test_31_point_5"
172 { 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 }
175 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
177 FUNCTION: longlong ffi_test_21 long x long y ;
179 [ 121932631112635269 ]
180 [ 123456789 987654321 ffi_test_21 ] unit-test
182 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
185 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
187 [ 1111 f 123456789 ffi_test_22 ] must-fail
190 { x float } { y float }
191 { w float } { h float } ;
193 : <RECT> ( x y w h -- rect )
200 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
202 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
204 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
206 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
209 { 1.0 2.0 3.0 } >float-array
210 { 4.0 5.0 6.0 } >float-array
214 ! Test odd-size structs
215 STRUCT: test-struct-1 { x char[1] } ;
217 FUNCTION: test-struct-1 ffi_test_24 ;
219 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
221 STRUCT: test-struct-2 { x char[2] } ;
223 FUNCTION: test-struct-2 ffi_test_25 ;
225 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
227 STRUCT: test-struct-3 { x char[3] } ;
229 FUNCTION: test-struct-3 ffi_test_26 ;
231 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
233 STRUCT: test-struct-4 { x char[4] } ;
235 FUNCTION: test-struct-4 ffi_test_27 ;
237 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
239 STRUCT: test-struct-5 { x char[5] } ;
241 FUNCTION: test-struct-5 ffi_test_28 ;
243 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
245 STRUCT: test-struct-6 { x char[6] } ;
247 FUNCTION: test-struct-6 ffi_test_29 ;
249 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
251 STRUCT: test-struct-7 { x char[7] } ;
253 FUNCTION: test-struct-7 ffi_test_30 ;
255 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
257 STRUCT: test-struct-8 { x double } { y double } ;
259 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
262 test-struct-8 <struct>
268 STRUCT: test-struct-9 { x float } { y float } ;
270 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
273 test-struct-9 <struct>
279 STRUCT: test-struct-10 { x float } { y int } ;
281 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
284 test-struct-10 <struct>
290 STRUCT: test-struct-11 { x int } { y int } ;
292 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
295 test-struct-11 <struct>
301 STRUCT: test-struct-12 { a int } { x double } ;
303 : make-struct-12 ( x -- alien )
304 test-struct-12 <struct>
307 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
309 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
311 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
313 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
317 : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
319 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
321 [ t ] [ callback-1 alien? ] unit-test
323 : callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
325 [ ] [ callback-1 callback_test_1 ] unit-test
327 : callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
329 [ ] [ callback-2 callback_test_1 ] unit-test
331 : callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
335 3 "x" set callback-3 callback_test_1
341 3 "x" set callback-3 callback_test_1 "x" get
345 : callback-4 ( -- callback )
346 void { } "cdecl" [ "Hello world" write ] alien-callback
350 [ callback-4 callback_test_1 ] with-string-writer
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 -- arg' )
449 void { void* void* double-rect } "cdecl" alien-indirect
450 "example" get-global ;
453 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
455 STRUCT: test_struct_14
459 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
462 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
465 : callback-10 ( -- callback )
466 test_struct_14 { double double } "cdecl"
468 test_struct_14 <struct>
473 : callback-10-test ( x1 x2 callback -- result )
474 test_struct_14 { double double } "cdecl" alien-indirect ;
477 1.0 2.0 callback-10 callback-10-test
481 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
488 : callback-11 ( -- callback )
489 test-struct-12 { int double } "cdecl"
491 test-struct-12 <struct>
496 : callback-11-test ( x1 x2 callback -- result )
497 test-struct-12 { int double } "cdecl" alien-indirect ;
500 1 2.0 callback-11 callback-11-test
504 STRUCT: test_struct_15
508 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
510 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
512 : callback-12 ( -- callback )
513 test_struct_15 { float float } "cdecl"
515 test_struct_15 <struct>
520 : callback-12-test ( x1 x2 callback -- result )
521 test_struct_15 { float float } "cdecl" alien-indirect ;
524 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
527 STRUCT: test_struct_16
531 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
533 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
535 : callback-13 ( -- callback )
536 test_struct_16 { float int } "cdecl"
538 test_struct_16 <struct>
543 : callback-13-test ( x1 x2 callback -- result )
544 test_struct_16 { float int } "cdecl" alien-indirect ;
547 1.0 2 callback-13 callback-13-test
551 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
553 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
555 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
557 [ ] [ stack-frame-bustage 2drop ] unit-test
562 FUNCTION: complex-float ffi_test_45 ( int x ) ;
564 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
566 FUNCTION: complex-double ffi_test_46 ( int x ) ;
568 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
570 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
574 C{ 1.5 1.0 } ffi_test_47
578 STRUCT: bool-field-test
583 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
586 bool-field-test <struct>
593 ! Regression: calling an undefined function would raise a protection fault
594 FUNCTION: void this_does_not_exist ( ) ;
596 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
598 ! More alien-assembly tests are in cpu.* vocabs
599 : assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
601 [ ] [ assembly-test-1 ] unit-test