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 concurrency.promises ;
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
26 "f-fastcall" libfactor-ffi-tests-path fastcall add-library
31 FUNCTION: void ffi_test_0 ;
32 [ ] [ ffi_test_0 ] unit-test
34 FUNCTION: int ffi_test_1 ;
35 [ 3 ] [ ffi_test_1 ] unit-test
37 FUNCTION: int ffi_test_2 int x int y ;
38 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
39 [ "hi" 3 ffi_test_2 ] must-fail
41 FUNCTION: int ffi_test_3 int x int y int z int t ;
42 [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
44 FUNCTION: float ffi_test_4 ;
45 [ 1.5 ] [ ffi_test_4 ] unit-test
47 FUNCTION: double ffi_test_5 ;
48 [ 1.5 ] [ ffi_test_5 ] unit-test
50 FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
51 [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
52 [ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
53 [ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
55 STRUCT: FOO { x int } { y int } ;
57 : make-FOO ( x y -- FOO )
58 FOO <struct> swap >>y swap >>x ;
60 FUNCTION: int ffi_test_11 int a FOO b int c ;
62 [ 14 ] [ 1 2 3 make-FOO 4 ffi_test_11 ] unit-test
64 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 ;
66 [ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
68 FUNCTION: FOO ffi_test_14 int x int y ;
70 [ 11 6 ] [ 11 6 ffi_test_14 [ x>> ] [ y>> ] bi ] unit-test
72 FUNCTION: c-string ffi_test_15 c-string x c-string y ;
74 [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
75 [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
76 [ 1 2 ffi_test_15 ] must-fail
78 STRUCT: BAR { x long } { y long } { z long } ;
80 FUNCTION: BAR ffi_test_16 long x long y long z ;
83 11 6 -7 ffi_test_16 [ x>> ] [ y>> ] [ z>> ] tri
86 STRUCT: TINY { x int } ;
88 FUNCTION: TINY ffi_test_17 int x ;
90 [ 11 ] [ 11 ffi_test_17 x>> ] unit-test
92 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
94 : indirect-test-1 ( ptr -- result )
95 int { } cdecl alien-indirect ;
97 { 1 1 } [ indirect-test-1 ] must-infer-as
99 [ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
101 [ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
103 : indirect-test-1' ( ptr -- )
104 int { } cdecl alien-indirect drop ;
106 { 1 0 } [ indirect-test-1' ] must-infer-as
108 [ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
110 [ -1 indirect-test-1 ] must-fail
112 : indirect-test-2 ( x y ptr -- result )
113 int { int int } cdecl alien-indirect gc ;
115 { 3 1 } [ indirect-test-2 ] must-infer-as
118 [ 2 3 &: ffi_test_2 indirect-test-2 ]
121 : indirect-test-3 ( a b c d ptr -- result )
122 int { int int int int } stdcall alien-indirect
125 [ f ] [ "f-stdcall" load-library f = ] unit-test
126 [ stdcall ] [ "f-stdcall" library abi>> ] unit-test
128 : ffi_test_18 ( w x y z -- int )
129 int "f-stdcall" "ffi_test_18" { int int int int }
132 [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
134 : ffi_test_19 ( x y z -- BAR )
135 BAR "f-stdcall" "ffi_test_19" { long long long }
139 11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
142 FUNCTION: double ffi_test_6 float x float y ;
143 [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
144 [ "a" "b" ffi_test_6 ] must-fail
146 FUNCTION: double ffi_test_7 double x double y ;
147 [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
149 FUNCTION: double ffi_test_8 double x float y double z float t int w ;
150 [ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
152 FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
153 [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
155 FUNCTION: void ffi_test_20 double x1, double x2, double x3,
156 double y1, double y2, double y3,
157 double z1, double z2, double z3 ;
159 [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
161 ! Make sure XT doesn't get clobbered in stack frame
163 : 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 )
165 "f-cdecl" "ffi_test_31"
166 { 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 }
169 [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
171 : 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 )
173 "f-cdecl" "ffi_test_31_point_5"
174 { 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 }
177 [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
179 FUNCTION: longlong ffi_test_21 long x long y ;
181 [ 121932631112635269 ]
182 [ 123456789 987654321 ffi_test_21 ] unit-test
184 FUNCTION: long ffi_test_22 long x longlong y longlong z ;
187 [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
189 [ 1111 f 123456789 ffi_test_22 ] must-fail
192 { x float } { y float }
193 { w float } { h float } ;
195 : <RECT> ( x y w h -- rect )
202 FUNCTION: int ffi_test_12 int a int b RECT c int d int e int f ;
204 [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <RECT> 7 8 9 ffi_test_12 ] unit-test
206 [ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
208 FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
211 { 1.0 2.0 3.0 } >float-array
212 { 4.0 5.0 6.0 } >float-array
216 ! Test odd-size structs
217 STRUCT: test-struct-1 { x char[1] } ;
219 FUNCTION: test-struct-1 ffi_test_24 ;
221 [ S{ test-struct-1 { x char-array{ 1 } } } ] [ ffi_test_24 ] unit-test
223 STRUCT: test-struct-2 { x char[2] } ;
225 FUNCTION: test-struct-2 ffi_test_25 ;
227 [ S{ test-struct-2 { x char-array{ 1 2 } } } ] [ ffi_test_25 ] unit-test
229 STRUCT: test-struct-3 { x char[3] } ;
231 FUNCTION: test-struct-3 ffi_test_26 ;
233 [ S{ test-struct-3 { x char-array{ 1 2 3 } } } ] [ ffi_test_26 ] unit-test
235 STRUCT: test-struct-4 { x char[4] } ;
237 FUNCTION: test-struct-4 ffi_test_27 ;
239 [ S{ test-struct-4 { x char-array{ 1 2 3 4 } } } ] [ ffi_test_27 ] unit-test
241 STRUCT: test-struct-5 { x char[5] } ;
243 FUNCTION: test-struct-5 ffi_test_28 ;
245 [ S{ test-struct-5 { x char-array{ 1 2 3 4 5 } } } ] [ ffi_test_28 ] unit-test
247 STRUCT: test-struct-6 { x char[6] } ;
249 FUNCTION: test-struct-6 ffi_test_29 ;
251 [ S{ test-struct-6 { x char-array{ 1 2 3 4 5 6 } } } ] [ ffi_test_29 ] unit-test
253 STRUCT: test-struct-7 { x char[7] } ;
255 FUNCTION: test-struct-7 ffi_test_30 ;
257 [ S{ test-struct-7 { x char-array{ 1 2 3 4 5 6 7 } } } ] [ ffi_test_30 ] unit-test
259 STRUCT: test-struct-8 { x double } { y double } ;
261 FUNCTION: double ffi_test_32 test-struct-8 x int y ;
264 test-struct-8 <struct>
270 STRUCT: test-struct-9 { x float } { y float } ;
272 FUNCTION: double ffi_test_33 test-struct-9 x int y ;
275 test-struct-9 <struct>
281 STRUCT: test-struct-10 { x float } { y int } ;
283 FUNCTION: double ffi_test_34 test-struct-10 x int y ;
286 test-struct-10 <struct>
292 STRUCT: test-struct-11 { x int } { y int } ;
294 FUNCTION: double ffi_test_35 test-struct-11 x int y ;
297 test-struct-11 <struct>
303 STRUCT: test-struct-12 { a int } { x double } ;
305 : make-struct-12 ( x -- alien )
306 test-struct-12 <struct>
309 FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
311 [ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
313 FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
315 [ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
319 : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
321 [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
323 [ t ] [ callback-1 alien? ] unit-test
325 : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
327 [ ] [ callback-1 callback_test_1 ] unit-test
329 : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
331 [ ] [ callback-2 callback_test_1 ] unit-test
333 : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
338 3 "x" set callback-3 callback_test_1
340 "x" get "x" get-global
344 : callback-5 ( -- callback )
345 void { } cdecl [ gc ] alien-callback ;
348 "testing" callback-5 callback_test_1
351 : callback-5b ( -- callback )
352 void { } cdecl [ compact-gc ] alien-callback ;
355 "testing" callback-5b callback_test_1
358 : callback-6 ( -- callback )
359 void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
361 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
363 : callback-7 ( -- callback )
364 void { } cdecl [ 1000000 sleep ] alien-callback ;
366 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
368 [ f ] [ namespace global eq? ] unit-test
370 : callback-8 ( -- callback )
371 void { } cdecl [ [ ] in-thread yield ] alien-callback ;
373 [ ] [ callback-8 callback_test_1 ] unit-test
375 : callback-9 ( -- callback )
376 int { int int int } cdecl [
380 FUNCTION: void ffi_test_36_point_5 ( ) ;
382 [ ] [ ffi_test_36_point_5 ] unit-test
384 FUNCTION: int ffi_test_37 ( void* func ) ;
386 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
388 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
390 STRUCT: test_struct_13
398 : make-test-struct-13 ( -- alien )
399 test_struct_13 <struct>
407 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
409 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
411 ! Joe Groff found this problem
418 : <double-rect> ( a b c d -- foo )
425 : >double-rect< ( foo -- a b c d )
433 : double-rect-callback ( -- alien )
434 void { void* void* double-rect } cdecl
435 [ "example" set-global 2drop ] alien-callback ;
437 : double-rect-test ( arg -- arg' )
440 void { void* void* double-rect } cdecl alien-indirect
441 "example" get-global ;
444 [ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
446 STRUCT: test_struct_14
450 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
453 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
456 : callback-10 ( -- callback )
457 test_struct_14 { double double } cdecl
459 test_struct_14 <struct>
464 : callback-10-test ( x1 x2 callback -- result )
465 test_struct_14 { double double } cdecl alien-indirect ;
468 1.0 2.0 callback-10 callback-10-test
472 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
479 : callback-11 ( -- callback )
480 test-struct-12 { int double } cdecl
482 test-struct-12 <struct>
487 : callback-11-test ( x1 x2 callback -- result )
488 test-struct-12 { int double } cdecl alien-indirect ;
491 1 2.0 callback-11 callback-11-test
495 STRUCT: test_struct_15
499 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
501 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
503 : callback-12 ( -- callback )
504 test_struct_15 { float float } cdecl
506 test_struct_15 <struct>
511 : callback-12-test ( x1 x2 callback -- result )
512 test_struct_15 { float float } cdecl alien-indirect ;
515 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
518 STRUCT: test_struct_16
522 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
524 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
526 : callback-13 ( -- callback )
527 test_struct_16 { float int } cdecl
529 test_struct_16 <struct>
534 : callback-13-test ( x1 x2 callback -- result )
535 test_struct_16 { float int } cdecl alien-indirect ;
538 1.0 2 callback-13 callback-13-test
542 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
544 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
546 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
548 [ ] [ stack-frame-bustage 2drop ] unit-test
553 FUNCTION: complex-float ffi_test_45 ( int x ) ;
555 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
557 FUNCTION: complex-double ffi_test_46 ( int x ) ;
559 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
561 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
565 C{ 1.5 1.0 } ffi_test_47
569 STRUCT: bool-field-test
574 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
577 bool-field-test <struct>
584 ! Test interaction between threads and callbacks
585 : thread-callback-1 ( -- callback )
586 int { } cdecl [ yield 100 ] alien-callback ;
588 : thread-callback-2 ( -- callback )
589 int { } cdecl [ yield 200 ] alien-callback ;
591 : thread-callback-invoker ( callback -- n )
592 int { } cdecl alien-indirect ;
595 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
596 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
597 [ 100 ] [ "p" get ?promise ] unit-test
599 ! Regression: calling an undefined function would raise a protection fault
600 FUNCTION: void this_does_not_exist ( ) ;
602 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
604 ! More alien-assembly tests are in cpu.* vocabs
605 : assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
607 [ ] [ assembly-test-1 ] unit-test
611 FUNCTION: int ffi_test_49 ( int x ) ;
612 FUNCTION: int ffi_test_50 ( int x, int y ) ;
613 FUNCTION: int ffi_test_51 ( int x, int y, int z ) ;
614 FUNCTION: int ffi_test_52 ( int x, float y, int z ) ;
615 FUNCTION: int ffi_test_53 ( int x, float y, int z, int w ) ;
616 FUNCTION: int ffi_test_54 ( test-struct-11 x, int y ) ;
617 FUNCTION: int ffi_test_55 ( int x, int y, int z ) ;
618 FUNCTION: int ffi_test_56 ( int x, int y, int z ) ;
620 [ 4 ] [ 3 ffi_test_49 ] unit-test
621 [ 8 ] [ 3 4 ffi_test_50 ] unit-test
622 [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
623 [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
624 [ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
625 [ 13 ] [ 3 4 test-struct-11 <struct> 5 ffi_test_54 ] unit-test
626 [ 19 ] [ 3 4 test-struct-11 <struct> 5 6 ffi_test_55 ] unit-test
627 [ 26 ] [ 3 4 test-struct-11 <struct> 5 6 7 ffi_test_56 ] unit-test