USING: accessors alien alien.c-types alien.libraries
alien.syntax arrays classes.struct combinators
-compiler continuations effects io io.backend io.pathnames
-io.streams.string kernel math memory namespaces
-namespaces.private parser quotations sequences
-specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words alien.complex concurrency.promises ;
+compiler continuations effects generalizations io
+io.backend io.pathnames io.streams.string kernel
+math memory namespaces namespaces.private parser
+quotations sequences specialized-arrays stack-checker
+stack-checker.errors system threads tools.test words
+alien.complex concurrency.promises ;
FROM: alien.c-types => float short ;
+FROM: alien.private => fastcall ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
-"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+"f-cdecl" libfactor-ffi-tests-path cdecl add-library
-"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+"f-stdcall" libfactor-ffi-tests-path stdcall add-library
+
+"f-fastcall" libfactor-ffi-tests-path fastcall add-library
>>
LIBRARY: f-cdecl
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result )
- int { } "cdecl" alien-indirect ;
+ int { } cdecl alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
- int { } "cdecl" alien-indirect drop ;
+ int { } cdecl alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
- int { int int } "cdecl" alien-indirect gc ;
+ int { int int } cdecl alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
unit-test
: indirect-test-3 ( a b c d ptr -- result )
- int { int int int int } "stdcall" alien-indirect
+ int { int int int int } stdcall alien-indirect
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
-[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
+[ stdcall ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
int "f-stdcall" "ffi_test_18" { int int int int }
11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
+: multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
+ [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
+ 4 ndip
+ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
+ gc ;
+
+[ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
+
FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail
! Test callbacks
-: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
[ t 3 5 ] [
[
] unit-test
: callback-5 ( -- callback )
- void { } "cdecl" [ gc ] alien-callback ;
+ void { } cdecl [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5b ( -- callback )
- void { } "cdecl" [ compact-gc ] alien-callback ;
+ void { } cdecl [ compact-gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5b callback_test_1
] unit-test
: callback-6 ( -- callback )
- void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+ void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
- void { } "cdecl" [ 1000000 sleep ] alien-callback ;
+ void { } cdecl [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
- void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
+ void { } cdecl [ [ ] in-thread yield ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback )
- int { int int int } "cdecl" [
+ int { int int int } cdecl [
+ + 1 +
] alien-callback ;
} cleave ;
: double-rect-callback ( -- alien )
- void { void* void* double-rect } "cdecl"
+ void { void* void* double-rect } cdecl
[ "example" set-global 2drop ] alien-callback ;
-: double-rect-test ( arg callback -- arg' )
+: double-rect-test ( arg -- arg' )
[ f f ] 2dip
- void { void* void* double-rect } "cdecl" alien-indirect
+ double-rect-callback
+ void { void* void* double-rect } cdecl alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
] unit-test
: callback-10 ( -- callback )
- test_struct_14 { double double } "cdecl"
+ test_struct_14 { double double } cdecl
[
test_struct_14 <struct>
swap >>x2
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
- test_struct_14 { double double } "cdecl" alien-indirect ;
+ test_struct_14 { double double } cdecl alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
] unit-test
: callback-11 ( -- callback )
- test-struct-12 { int double } "cdecl"
+ test-struct-12 { int double } cdecl
[
test-struct-12 <struct>
swap >>x
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
- test-struct-12 { int double } "cdecl" alien-indirect ;
+ test-struct-12 { int double } cdecl alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
- test_struct_15 { float float } "cdecl"
+ test_struct_15 { float float } cdecl
[
test_struct_15 <struct>
swap >>y
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
- test_struct_15 { float float } "cdecl" alien-indirect ;
+ test_struct_15 { float float } cdecl alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
- test_struct_16 { float int } "cdecl"
+ test_struct_16 { float int } cdecl
[
test_struct_16 <struct>
swap >>a
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
- test_struct_16 { float int } "cdecl" alien-indirect ;
+ test_struct_16 { float int } cdecl alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
! Test interaction between threads and callbacks
: thread-callback-1 ( -- callback )
- int { } "cdecl" [ yield 100 ] alien-callback ;
+ int { } cdecl [ yield 100 ] alien-callback ;
: thread-callback-2 ( -- callback )
- int { } "cdecl" [ yield 200 ] alien-callback ;
+ int { } cdecl [ yield 200 ] alien-callback ;
: thread-callback-invoker ( callback -- n )
- int { } "cdecl" alien-indirect ;
+ int { } cdecl alien-indirect ;
<promise> "p" set
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
! More alien-assembly tests are in cpu.* vocabs
-: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
+: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
[ ] [ assembly-test-1 ] unit-test
+
+[ f ] [ "f-fastcall" load-library f = ] unit-test
+[ fastcall ] [ "f-fastcall" library abi>> ] unit-test
+
+: ffi_test_49 ( x -- int )
+ int "f-fastcall" "ffi_test_49" { int }
+ alien-invoke gc ;
+: ffi_test_50 ( x y -- int )
+ int "f-fastcall" "ffi_test_50" { int int }
+ alien-invoke gc ;
+: ffi_test_51 ( x y z -- int )
+ int "f-fastcall" "ffi_test_51" { int int int }
+ alien-invoke gc ;
+: multi_ffi_test_51 ( x y z x' y' z' -- int int )
+ [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
+ 3dip
+ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
+
+[ 4 ] [ 3 ffi_test_49 ] unit-test
+[ 8 ] [ 3 4 ffi_test_50 ] unit-test
+[ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
+[ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
+
+: ffi_test_52 ( x y z -- int )
+ int "f-fastcall" "ffi_test_52" { int float int }
+ alien-invoke gc ;
+: ffi_test_53 ( x y z w -- int )
+ int "f-fastcall" "ffi_test_53" { int float int int }
+ alien-invoke gc ;
+: ffi_test_57 ( x y -- test-struct-11 )
+ test-struct-11 "f-fastcall" "ffi_test_57" { int int }
+ alien-invoke gc ;
+: ffi_test_58 ( x y z -- test-struct-11 )
+ test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
+ alien-invoke gc ;
+
+[ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
+[ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
+[ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
+[ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
+
+: fastcall-ii-indirect ( x y ptr -- result )
+ int { int int } fastcall alien-indirect ;
+: fastcall-iii-indirect ( x y z ptr -- result )
+ int { int int int } fastcall alien-indirect ;
+: fastcall-ifi-indirect ( x y z ptr -- result )
+ int { int float int } fastcall alien-indirect ;
+: fastcall-ifii-indirect ( x y z w ptr -- result )
+ int { int float int int } fastcall alien-indirect ;
+: fastcall-struct-return-ii-indirect ( x y ptr -- result )
+ test-struct-11 { int int } fastcall alien-indirect ;
+: fastcall-struct-return-iii-indirect ( x y z ptr -- result )
+ test-struct-11 { int int int } fastcall alien-indirect ;
+
+[ 8 ] [ 3 4 &: ffi_test_50 fastcall-ii-indirect ] unit-test
+[ 13 ] [ 3 4 5 &: ffi_test_51 fastcall-iii-indirect ] unit-test
+[ 13 ] [ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect ] unit-test
+[ 19 ] [ 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -1 } ]
+[ 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -3 } ]
+[ 3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect ] unit-test
+
+: fastcall-ii-callback ( -- ptr )
+ int { int int } fastcall [ + 1 + ] alien-callback ;
+: fastcall-iii-callback ( -- ptr )
+ int { int int int } fastcall [ + + 1 + ] alien-callback ;
+: fastcall-ifi-callback ( -- ptr )
+ int { int float int } fastcall
+ [ [ >integer ] dip + + 1 + ] alien-callback ;
+: fastcall-ifii-callback ( -- ptr )
+ int { int float int int } fastcall
+ [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
+: fastcall-struct-return-ii-callback ( -- ptr )
+ test-struct-11 { int int } fastcall
+ [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
+: fastcall-struct-return-iii-callback ( -- ptr )
+ test-struct-11 { int int int } fastcall
+ [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
+
+[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
+[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
+[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
+[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -1 } ]
+[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -3 } ]
+[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test