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: char* ffi_test_15 char* x char* 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 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
99 : indirect-test-1' ( ptr -- )
100 int { } "cdecl" alien-indirect drop ;
102 { 1 0 } [ indirect-test-1' ] must-infer-as
104 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
106 [ -1 indirect-test-1 ] must-fail
108 : indirect-test-2 ( x y ptr -- result )
109 int { int int } "cdecl" alien-indirect gc ;
111 { 3 1 } [ indirect-test-2 ] must-infer-as
114 [ 2 3 &: ffi_test_2 indirect-test-2 ]
117 : indirect-test-3 ( a b c d ptr -- result )
118 int { int int int int } "stdcall" alien-indirect
121 [ f ] [ "f-stdcall" load-library f = ] unit-test
122 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
124 : ffi_test_18 ( w x y z -- int )
125 int "f-stdcall" "ffi_test_18" { int int int int }
128 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
130 : ffi_test_19 ( x y z -- BAR )
131 BAR "f-stdcall" "ffi_test_19" { long long long }
135 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
138 FUNCTION: double ffi_test_6 float x float y ;
139 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
140 [ "a" "b" ffi_test_6 ] must-fail
142 FUNCTION: double ffi_test_7 double x double y ;
143 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
145 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
146 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
148 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
149 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
151 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
152 double y1, double y2, double y3,
153 double z1, double z2, double z3 ;
155 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
157 ! Make sure XT doesn't get clobbered in stack frame
159 : 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 )
161 "f-cdecl" "ffi_test_31"
162 { 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 }
165 [ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
167 : 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 )
169 "f-cdecl" "ffi_test_31_point_5"
170 { 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 }
173 [ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
175 FUNCTION: longlong ffi_test_21 long x long y ;
177 [ 121932631112635269 ]
178 [ 123456789 987654321 ffi_test_21 ] unit-test
180 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
183 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
185 [ 1111 f 123456789 ffi_test_22 ] must-fail
188 { x float } { y float }
189 { w float } { h float } ;
191 : <RECT> ( x y w h -- rect )
198 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
200 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
202 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
204 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
207 { 1.0 2.0 3.0 } >float-array
208 { 4.0 5.0 6.0 } >float-array
212 ! Test odd-size structs
213 STRUCT: test-struct-1 { x char[1] } ;
215 FUNCTION: test-struct-1 ffi_test_24 ;
217 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
219 STRUCT: test-struct-2 { x char[2] } ;
221 FUNCTION: test-struct-2 ffi_test_25 ;
223 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
225 STRUCT: test-struct-3 { x char[3] } ;
227 FUNCTION: test-struct-3 ffi_test_26 ;
229 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
231 STRUCT: test-struct-4 { x char[4] } ;
233 FUNCTION: test-struct-4 ffi_test_27 ;
235 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
237 STRUCT: test-struct-5 { x char[5] } ;
239 FUNCTION: test-struct-5 ffi_test_28 ;
241 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
243 STRUCT: test-struct-6 { x char[6] } ;
245 FUNCTION: test-struct-6 ffi_test_29 ;
247 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
249 STRUCT: test-struct-7 { x char[7] } ;
251 FUNCTION: test-struct-7 ffi_test_30 ;
253 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
255 STRUCT: test-struct-8 { x double } { y double } ;
257 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
260 test-struct-8 <struct>
266 STRUCT: test-struct-9 { x float } { y float } ;
268 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
271 test-struct-9 <struct>
277 STRUCT: test-struct-10 { x float } { y int } ;
279 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
282 test-struct-10 <struct>
288 STRUCT: test-struct-11 { x int } { y int } ;
290 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
293 test-struct-11 <struct>
299 STRUCT: test-struct-12 { a int } { x double } ;
301 : make-struct-12 ( x -- alien )
302 test-struct-12 <struct>
305 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
307 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
309 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
311 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
315 : callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
317 [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
319 [ t ] [ callback-1 alien? ] unit-test
321 : callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
323 [ ] [ callback-1 callback_test_1 ] unit-test
325 : callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
327 [ ] [ callback-2 callback_test_1 ] unit-test
329 : callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
333 3 "x" set callback-3 callback_test_1
339 3 "x" set callback-3 callback_test_1 "x" get
343 : callback-4 ( -- callback )
344 void { } "cdecl" [ "Hello world" write ] alien-callback
348 [ callback-4 callback_test_1 ] with-string-writer
351 : callback-5 ( -- callback )
352 void { } "cdecl" [ gc ] alien-callback ;
355 "testing" callback-5 callback_test_1
358 : callback-5b ( -- callback )
359 void { } "cdecl" [ compact-gc ] alien-callback ;
362 "testing" callback-5b callback_test_1
365 : callback-6 ( -- callback )
366 void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
368 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
370 : callback-7 ( -- callback )
371 void { } "cdecl" [ 1000000 sleep ] alien-callback ;
373 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
375 [ f ] [ namespace global eq? ] unit-test
377 : callback-8 ( -- 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
559 FUNCTION: complex-float ffi_test_45 ( int x ) ;
561 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
563 FUNCTION: complex-double ffi_test_46 ( int x ) ;
565 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
567 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
571 C{ 1.5 1.0 } ffi_test_47
575 STRUCT: bool-field-test
580 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
583 bool-field-test <struct>
588 ! Regression: calling an undefined function would raise a protection fault
589 FUNCTION: void this_does_not_exist ( ) ;
591 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with