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 ;
8 SPECIALIZED-ARRAY: float
9 SPECIALIZED-ARRAY: char
10 IN: compiler.tests.alien
13 : libfactor-ffi-tests-path ( -- string )
14 "resource:" (normalize-path)
16 { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
17 { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
18 { [ os unix? ] [ "libfactor-ffi-test.so" ] }
21 "f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
23 "f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
28 FUNCTION: void ffi_test_0 ;
29 [ ] [ ffi_test_0 ] unit-test
31 FUNCTION: int ffi_test_1 ;
32 [ 3 ] [ ffi_test_1 ] unit-test
34 FUNCTION: int ffi_test_2 int x int y ;
35 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
36 [ "hi" 3 ffi_test_2 ] must-fail
38 FUNCTION: int ffi_test_3 int x int y int z int t ;
39 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
41 FUNCTION: float ffi_test_4 ;
42 [ 1.5 ] [ ffi_test_4 ] unit-test
44 FUNCTION: double ffi_test_5 ;
45 [ 1.5 ] [ ffi_test_5 ] unit-test
47 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
48 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
49 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
50 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
52 STRUCT: FOO { x int } { y int } ;
54 : make-FOO ( x y -- FOO )
55 FOO <struct> swap >>y swap >>x ;
57 FUNCTION: int ffi_test_11 int a FOO b int c ;
59 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
61 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 ;
63 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
65 FUNCTION: FOO ffi_test_14 int x int y ;
67 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
69 FUNCTION: char* ffi_test_15 char* x char* y ;
71 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
72 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
73 [ 1 2 ffi_test_15 ] must-fail
75 STRUCT: BAR { x long } { y long } { z long } ;
77 FUNCTION: BAR ffi_test_16 long x long y long z ;
80 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
83 STRUCT: TINY { x int } ;
85 FUNCTION: TINY ffi_test_17 int x ;
87 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
89 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
91 : indirect-test-1 ( ptr -- result )
92 "int" { } "cdecl" alien-indirect ;
94 { 1 1 } [ indirect-test-1 ] must-infer-as
96 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
98 : indirect-test-1' ( ptr -- )
99 "int" { } "cdecl" alien-indirect drop ;
101 { 1 0 } [ indirect-test-1' ] must-infer-as
103 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
105 [ -1 indirect-test-1 ] must-fail
107 : indirect-test-2 ( x y ptr -- result )
108 "int" { "int" "int" } "cdecl" alien-indirect gc ;
110 { 3 1 } [ indirect-test-2 ] must-infer-as
113 [ 2 3 &: ffi_test_2 indirect-test-2 ]
116 : indirect-test-3 ( a b c d ptr -- result )
117 "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
120 [ f ] [ "f-stdcall" load-library f = ] unit-test
121 [ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
123 : ffi_test_18 ( w x y z -- int )
124 "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
127 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
129 : ffi_test_19 ( x y z -- BAR )
130 "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
134 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
137 FUNCTION: double ffi_test_6 float x float y ;
138 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
139 [ "a" "b" ffi_test_6 ] must-fail
141 FUNCTION: double ffi_test_7 double x double y ;
142 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
144 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
145 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
147 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
148 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
150 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
151 double y1, double y2, double y3,
152 double z1, double z2, double z3 ;
154 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
156 ! Make sure XT doesn't get clobbered in stack frame
158 : 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 )
160 "f-cdecl" "ffi_test_31"
161 { "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" }
164 [ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
166 : 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 )
168 "f-cdecl" "ffi_test_31_point_5"
169 { "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" }
172 [ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
174 FUNCTION: longlong ffi_test_21 long x long y ;
176 [ 121932631112635269 ]
177 [ 123456789 987654321 ffi_test_21 ] unit-test
179 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
182 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
184 [ 1111 f 123456789 ffi_test_22 ] must-fail
187 { x float } { y float }
188 { w float } { h float } ;
190 : <RECT> ( x y w h -- rect )
197 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
199 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
201 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
203 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
206 { 1.0 2.0 3.0 } >float-array
207 { 4.0 5.0 6.0 } >float-array
211 ! Test odd-size structs
212 STRUCT: test-struct-1 { x char[1] } ;
214 FUNCTION: test-struct-1 ffi_test_24 ;
216 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
218 STRUCT: test-struct-2 { x char[2] } ;
220 FUNCTION: test-struct-2 ffi_test_25 ;
222 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
224 STRUCT: test-struct-3 { x char[3] } ;
226 FUNCTION: test-struct-3 ffi_test_26 ;
228 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
230 STRUCT: test-struct-4 { x char[4] } ;
232 FUNCTION: test-struct-4 ffi_test_27 ;
234 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
236 STRUCT: test-struct-5 { x char[5] } ;
238 FUNCTION: test-struct-5 ffi_test_28 ;
240 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
242 STRUCT: test-struct-6 { x char[6] } ;
244 FUNCTION: test-struct-6 ffi_test_29 ;
246 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
248 STRUCT: test-struct-7 { x char[7] } ;
250 FUNCTION: test-struct-7 ffi_test_30 ;
252 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
254 STRUCT: test-struct-8 { x double } { y double } ;
256 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
259 test-struct-8 <struct>
265 STRUCT: test-struct-9 { x float } { y float } ;
267 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
270 test-struct-9 <struct>
276 STRUCT: test-struct-10 { x float } { y int } ;
278 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
281 test-struct-10 <struct>
287 STRUCT: test-struct-11 { x int } { y int } ;
289 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
292 test-struct-11 <struct>
298 STRUCT: test-struct-12 { a int } { x double } ;
300 : make-struct-12 ( x -- alien )
301 test-struct-12 <struct>
304 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
306 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
308 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
310 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
314 : callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
316 [ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
318 [ t ] [ callback-1 alien? ] unit-test
320 : callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
322 [ ] [ callback-1 callback_test_1 ] unit-test
324 : callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
326 [ ] [ callback-2 callback_test_1 ] unit-test
328 : callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
332 3 "x" set callback-3 callback_test_1
338 3 "x" set callback-3 callback_test_1 "x" get
342 : callback-4 ( -- callback )
343 "void" { } "cdecl" [ "Hello world" write ] alien-callback
347 [ callback-4 callback_test_1 ] with-string-writer
350 : callback-5 ( -- callback )
351 "void" { } "cdecl" [ gc ] alien-callback ;
354 "testing" callback-5 callback_test_1
357 : callback-5a ( -- callback )
358 "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
360 ! Hack; if we're on ARM, we probably don't have much RAM, so
364 ! "testing" callback-5a callback_test_1
368 : callback-6 ( -- callback )
369 "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
371 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
373 : callback-7 ( -- callback )
374 "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
376 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
378 [ f ] [ namespace global eq? ] unit-test
380 : callback-8 ( -- callback )
385 [ ] [ callback-8 callback_test_1 ] unit-test
387 : callback-9 ( -- callback )
388 "int" { "int" "int" "int" } "cdecl" [
392 FUNCTION: void ffi_test_36_point_5 ( ) ;
394 [ ] [ ffi_test_36_point_5 ] unit-test
396 FUNCTION: int ffi_test_37 ( void* func ) ;
398 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
400 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
402 STRUCT: test_struct_13
410 : make-test-struct-13 ( -- alien )
411 test_struct_13 <struct>
419 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
421 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
423 ! Joe Groff found this problem
430 : <double-rect> ( a b c d -- foo )
437 : >double-rect< ( foo -- a b c d )
445 : double-rect-callback ( -- alien )
446 "void" { "void*" "void*" "double-rect" } "cdecl"
447 [ "example" set-global 2drop ] alien-callback ;
449 : double-rect-test ( arg -- arg' )
452 "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
453 "example" get-global ;
456 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-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
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>