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
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 ;
336 3 "x" set callback-3 callback_test_1
338 "x" get "x" get-global
342 : callback-5 ( -- callback )
343 void { } "cdecl" [ gc ] alien-callback ;
346 "testing" callback-5 callback_test_1
349 : callback-5b ( -- callback )
350 void { } "cdecl" [ compact-gc ] alien-callback ;
353 "testing" callback-5b callback_test_1
356 : callback-6 ( -- callback )
357 void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
359 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
361 : callback-7 ( -- callback )
362 void { } "cdecl" [ 1000000 sleep ] alien-callback ;
364 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
366 [ f ] [ namespace global eq? ] unit-test
368 : callback-8 ( -- callback )
369 void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
371 [ ] [ callback-8 callback_test_1 ] unit-test
373 : callback-9 ( -- callback )
374 int { int int int } "cdecl" [
378 FUNCTION: void ffi_test_36_point_5 ( ) ;
380 [ ] [ ffi_test_36_point_5 ] unit-test
382 FUNCTION: int ffi_test_37 ( void* func ) ;
384 [ 1 ] [ callback-9 ffi_test_37 ] unit-test
386 [ 7 ] [ callback-9 ffi_test_37 ] unit-test
388 STRUCT: test_struct_13
396 : make-test-struct-13 ( -- alien )
397 test_struct_13 <struct>
405 FUNCTION: int ffi_test_39 ( long a, long b, test_struct_13 s ) ;
407 [ 21 ] [ 12347 12347 make-test-struct-13 ffi_test_39 ] unit-test
409 ! Joe Groff found this problem
416 : <double-rect> ( a b c d -- foo )
423 : >double-rect< ( foo -- a b c d )
431 : double-rect-callback ( -- alien )
432 void { void* void* double-rect } "cdecl"
433 [ "example" set-global 2drop ] alien-callback ;
435 : double-rect-test ( arg callback -- arg' )
437 void { void* void* double-rect } "cdecl" alien-indirect
438 "example" get-global ;
442 1.0 2.0 3.0 4.0 <double-rect>
443 double-rect-callback double-rect-test
447 STRUCT: test_struct_14
451 FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
454 1.0 2.0 ffi_test_40 [ x1>> ] [ x2>> ] bi
457 : callback-10 ( -- callback )
458 test_struct_14 { double double } "cdecl"
460 test_struct_14 <struct>
465 : callback-10-test ( x1 x2 callback -- result )
466 test_struct_14 { double double } "cdecl" alien-indirect ;
469 1.0 2.0 callback-10 callback-10-test
473 FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
480 : callback-11 ( -- callback )
481 test-struct-12 { int double } "cdecl"
483 test-struct-12 <struct>
488 : callback-11-test ( x1 x2 callback -- result )
489 test-struct-12 { int double } "cdecl" alien-indirect ;
492 1 2.0 callback-11 callback-11-test
496 STRUCT: test_struct_15
500 FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
502 [ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
504 : callback-12 ( -- callback )
505 test_struct_15 { float float } "cdecl"
507 test_struct_15 <struct>
512 : callback-12-test ( x1 x2 callback -- result )
513 test_struct_15 { float float } "cdecl" alien-indirect ;
516 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
519 STRUCT: test_struct_16
523 FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
525 [ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
527 : callback-13 ( -- callback )
528 test_struct_16 { float int } "cdecl"
530 test_struct_16 <struct>
535 : callback-13-test ( x1 x2 callback -- result )
536 test_struct_16 { float int } "cdecl" alien-indirect ;
539 1.0 2 callback-13 callback-13-test
543 FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
545 [ 1.0 2.0 ] [ ffi_test_44 [ x1>> ] [ x2>> ] bi ] unit-test
547 : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
549 [ ] [ stack-frame-bustage 2drop ] unit-test
554 FUNCTION: complex-float ffi_test_45 ( int x ) ;
556 [ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
558 FUNCTION: complex-double ffi_test_46 ( int x ) ;
560 [ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
562 FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
566 C{ 1.5 1.0 } ffi_test_47
570 STRUCT: bool-field-test
575 FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
578 bool-field-test <struct>
585 ! Test interaction between threads and callbacks
586 : thread-callback-1 ( -- callback )
587 int { } "cdecl" [ yield 100 ] alien-callback ;
589 : thread-callback-2 ( -- callback )
590 int { } "cdecl" [ yield 200 ] alien-callback ;
592 : thread-callback-invoker ( callback -- n )
593 int { } "cdecl" alien-indirect ;
596 [ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
597 [ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
598 [ 100 ] [ "p" get ?promise ] unit-test
600 ! Regression: calling an undefined function would raise a protection fault
601 FUNCTION: void this_does_not_exist ( ) ;
603 [ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
605 ! More alien-assembly tests are in cpu.* vocabs
606 : assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
608 [ ] [ assembly-test-1 ] unit-test