FFI now supports passing structs by value
So far, this is only supported on PowerPC.
slava
parent
b39984aaa6
commit
ac68a16492
|
|
@ -7,10 +7,10 @@ sequences sequences-internals strings words ;
|
|||
|
||||
: <c-type> ( -- type )
|
||||
H{
|
||||
{ "setter" [ "No setter" throw ] }
|
||||
{ "getter" [ "No getter" throw ] }
|
||||
{ "boxer" "no boxer" }
|
||||
{ "unboxer" "no unboxer" }
|
||||
{ "setter" [ "Cannot read struct fields with type" throw ] }
|
||||
{ "getter" [ "Cannot write struct fields with type" throw ] }
|
||||
{ "boxer" [ "Cannot use type as a return value" throw ] }
|
||||
{ "unboxer" [ "Cannot use type as a parameter" throw ] }
|
||||
{ "reg-class" T{ int-regs f } }
|
||||
{ "width" 0 }
|
||||
} clone ;
|
||||
|
|
@ -23,6 +23,8 @@ SYMBOL: c-types
|
|||
|
||||
: c-size ( name -- size ) "width" swap c-type hash ;
|
||||
|
||||
: c-align ( name -- align ) "align" swap c-type hash ;
|
||||
|
||||
: c-getter ( name -- quot ) "getter" swap c-type hash ;
|
||||
|
||||
: c-setter ( name -- quot ) "setter" swap c-type hash ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: alien
|
||||
USING: assembler compiler compiler-backend compiler-frontend
|
||||
errors generic hashtables inference inspector io kernel
|
||||
kernel-internals lists math namespaces parser prettyprint
|
||||
sequences strings words ;
|
||||
USING: arrays assembler compiler compiler-backend
|
||||
compiler-frontend errors generic hashtables inference inspector
|
||||
io kernel kernel-internals lists math namespaces parser
|
||||
prettyprint sequences strings words ;
|
||||
|
||||
! USAGE:
|
||||
!
|
||||
|
|
@ -56,32 +56,25 @@ C: alien-node make-node ;
|
|||
[ set-alien-return ] keep
|
||||
node, ;
|
||||
|
||||
: parameters alien-node-parameters reverse ;
|
||||
|
||||
: c-aligned c-size cell align ;
|
||||
: parameter-size c-size cell align ;
|
||||
|
||||
: stack-space ( parameters -- n )
|
||||
0 [ c-aligned + ] reduce ;
|
||||
0 [ parameter-size + ] reduce ;
|
||||
|
||||
: unbox-parameter ( stack# type -- node )
|
||||
c-type [ "unboxer" get "reg-class" get ] bind %unbox ;
|
||||
c-type [ "reg-class" get "unboxer" get ] bind call ;
|
||||
|
||||
: unbox-parameters ( params -- )
|
||||
reverse
|
||||
[ stack-space ] keep
|
||||
[ [ c-aligned - dup ] keep unbox-parameter , ] each drop ;
|
||||
[ [ parameter-size - dup ] keep unbox-parameter , ] each
|
||||
drop ;
|
||||
|
||||
: reg-class-full? ( class -- ? )
|
||||
dup class get swap fastcall-regs length >= ;
|
||||
|
||||
: spill-param ( reg-class -- n reg-class )
|
||||
reg-size stack-params [ tuck + ] change
|
||||
T{ stack-params } ;
|
||||
|
||||
: inc-reg-class ( reg-class -- )
|
||||
#! On Mac OS X, float parameters 'shadow' integer registers.
|
||||
dup class inc dup float-regs? dual-fp/int-regs? and [
|
||||
int-regs [ over reg-size 4 / + ] change
|
||||
] when drop ;
|
||||
reg-size stack-params dup get -rot +@ T{ stack-params } ;
|
||||
|
||||
: fastcall-param ( reg-class -- n reg-class )
|
||||
[ dup class get swap inc-reg-class ] keep ;
|
||||
|
|
@ -92,13 +85,18 @@ C: alien-node make-node ;
|
|||
c-type "reg-class" swap hash dup reg-class-full?
|
||||
[ spill-param ] [ fastcall-param ] if %parameter ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
dup c-struct?
|
||||
[ c-size cell / "void*" <array> ] [ 1array ] if
|
||||
] map concat ;
|
||||
|
||||
: load-parameters ( params -- )
|
||||
[
|
||||
reverse
|
||||
0 int-regs set
|
||||
0 float-regs set
|
||||
0 stack-params set
|
||||
0 [ 2dup load-parameter , c-aligned + ] reduce drop
|
||||
flatten-value-types
|
||||
0 { int-regs float-regs stack-params } [ set ] each-with
|
||||
0 [ 2dup load-parameter , parameter-size + ] reduce drop
|
||||
] with-scope ;
|
||||
|
||||
: linearize-parameters ( parameters -- )
|
||||
|
|
@ -113,15 +111,16 @@ C: alien-node make-node ;
|
|||
alien-node-return dup "void" = [
|
||||
drop
|
||||
] [
|
||||
c-type [ "boxer" get "reg-class" get ] bind %box ,
|
||||
c-type [ "reg-class" get "boxer" get ] bind call ,
|
||||
] if ;
|
||||
|
||||
: linearize-cleanup ( node -- )
|
||||
node-param cdr library-abi "stdcall" =
|
||||
[ dup parameters stack-space %cleanup , ] unless ;
|
||||
node-param cdr library-abi "stdcall" = [
|
||||
dup alien-node-parameters stack-space %cleanup ,
|
||||
] unless ;
|
||||
|
||||
M: alien-node linearize* ( node -- )
|
||||
dup parameters linearize-parameters
|
||||
dup alien-node-parameters linearize-parameters
|
||||
dup node-param uncons %alien-invoke ,
|
||||
dup linearize-cleanup
|
||||
dup linearize-return
|
||||
|
|
@ -140,7 +139,7 @@ M: alien-node linearize* ( node -- )
|
|||
: define-c-word ( type lib func function-args -- )
|
||||
[ "()" subseq? not ] subset parse-arglist (define-c-word) ;
|
||||
|
||||
\ alien-invoke [ [ string object string general-list ] [ ] ]
|
||||
\ alien-invoke [ [ string object string object ] [ ] ]
|
||||
"infer-effect" set-word-prop
|
||||
|
||||
\ alien-invoke [
|
||||
|
|
@ -151,9 +150,7 @@ M: alien-node linearize* ( node -- )
|
|||
r> swap alien-node
|
||||
] "infer" set-word-prop
|
||||
|
||||
global [
|
||||
"libraries" get [ H{ } clone "libraries" set ] unless
|
||||
] bind
|
||||
global [ "libraries" nest drop ] bind
|
||||
|
||||
M: compound (uncrossref)
|
||||
dup word-def \ alien-invoke swap member?
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ math namespaces ;
|
|||
] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_alien" "boxer" set
|
||||
"unbox_alien" "unboxer" set
|
||||
[ "box_alien" %box ] "boxer" set
|
||||
[ "unbox_alien" %unbox ] "unboxer" set
|
||||
] "void*" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -17,8 +17,8 @@ math namespaces ;
|
|||
[ set-alien-signed-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_signed_8" "boxer" set
|
||||
"unbox_signed_8" "unboxer" set
|
||||
[ "box_signed_8" %box ] "boxer" set
|
||||
[ "unbox_signed_8" %unbox ] "unboxer" set
|
||||
] "longlong" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -26,8 +26,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-8 ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_unsinged_8" "boxer" set
|
||||
"unbox_unsigned_8" "unboxer" set
|
||||
[ "box_unsinged_8" %box ] "boxer" set
|
||||
[ "unbox_unsigned_8" %unbox ] "unboxer" set
|
||||
] "ulonglong" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -35,8 +35,8 @@ math namespaces ;
|
|||
[ set-alien-signed-cell ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_signed_cell" "boxer" set
|
||||
"unbox_signed_cell" "unboxer" set
|
||||
[ "box_signed_cell" %box ] "boxer" set
|
||||
[ "unbox_signed_cell" %unbox ] "unboxer" set
|
||||
] "long" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -44,8 +44,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-cell ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_unsigned_cell" "boxer" set
|
||||
"unbox_unsigned_cell" "unboxer" set
|
||||
[ "box_unsigned_cell" %box ] "boxer" set
|
||||
[ "unbox_unsigned_cell" %unbox ] "unboxer" set
|
||||
] "ulong" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -53,8 +53,8 @@ math namespaces ;
|
|||
[ set-alien-signed-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_signed_4" "boxer" set
|
||||
"unbox_signed_4" "unboxer" set
|
||||
[ "box_signed_4" %box ] "boxer" set
|
||||
[ "unbox_signed_4" %unbox ] "unboxer" set
|
||||
] "int" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -62,8 +62,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-4 ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_unsigned_4" "boxer" set
|
||||
"unbox_unsigned_4" "unboxer" set
|
||||
[ "box_unsigned_4" %box ] "boxer" set
|
||||
[ "unbox_unsigned_4" %unbox ] "unboxer" set
|
||||
] "uint" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -71,8 +71,8 @@ math namespaces ;
|
|||
[ set-alien-signed-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_signed_2" "boxer" set
|
||||
"unbox_signed_2" "unboxer" set
|
||||
[ "box_signed_2" %box ] "boxer" set
|
||||
[ "unbox_signed_2" %unbox ] "unboxer" set
|
||||
] "short" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -80,8 +80,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-2 ] "setter" set
|
||||
2 "width" set
|
||||
2 "align" set
|
||||
"box_unsigned_2" "boxer" set
|
||||
"unbox_unsigned_2" "unboxer" set
|
||||
[ "box_unsigned_2" %box ] "boxer" set
|
||||
[ "unbox_unsigned_2" %unbox ] "unboxer" set
|
||||
] "ushort" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -89,8 +89,8 @@ math namespaces ;
|
|||
[ set-alien-signed-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_signed_1" "boxer" set
|
||||
"unbox_signed_1" "unboxer" set
|
||||
[ "box_signed_1" %box ] "boxer" set
|
||||
[ "unbox_signed_1" %unbox ] "unboxer" set
|
||||
] "char" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -98,8 +98,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-1 ] "setter" set
|
||||
1 "width" set
|
||||
1 "align" set
|
||||
"box_unsigned_1" "boxer" set
|
||||
"unbox_unsigned_1" "unboxer" set
|
||||
[ "box_unsigned_1" %box ] "boxer" set
|
||||
[ "unbox_unsigned_1" %unbox ] "unboxer" set
|
||||
] "uchar" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -110,8 +110,8 @@ math namespaces ;
|
|||
] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_c_string" "boxer" set
|
||||
"unbox_c_string" "unboxer" set
|
||||
[ "box_c_string" %box ] "boxer" set
|
||||
[ "unbox_c_string" %unbox ] "unboxer" set
|
||||
] "char*" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -119,8 +119,8 @@ math namespaces ;
|
|||
[ set-alien-unsigned-4 ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_utf16_string" "boxer" set
|
||||
"unbox_utf16_string" "unboxer" set
|
||||
[ "box_utf16_string" %box ] "boxer" set
|
||||
[ "unbox_utf16_string" %unbox ] "unboxer" set
|
||||
] "ushort*" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -128,8 +128,8 @@ math namespaces ;
|
|||
[ 1 0 ? set-alien-unsigned-4 ] "setter" set
|
||||
bootstrap-cell "width" set
|
||||
bootstrap-cell "align" set
|
||||
"box_boolean" "boxer" set
|
||||
"unbox_boolean" "unboxer" set
|
||||
[ "box_boolean" %box ] "boxer" set
|
||||
[ "unbox_boolean" %unbox ] "unboxer" set
|
||||
] "bool" define-primitive-type
|
||||
|
||||
[
|
||||
|
|
@ -137,8 +137,8 @@ math namespaces ;
|
|||
[ set-alien-float ] "setter" set
|
||||
4 "width" set
|
||||
4 "align" set
|
||||
"box_float" "boxer" set
|
||||
"unbox_float" "unboxer" set
|
||||
[ "box_float" %box ] "boxer" set
|
||||
[ "unbox_float" %unbox ] "unboxer" set
|
||||
T{ float-regs f 4 } "reg-class" set
|
||||
] "float" define-primitive-type
|
||||
|
||||
|
|
@ -147,7 +147,7 @@ math namespaces ;
|
|||
[ set-alien-double ] "setter" set
|
||||
8 "width" set
|
||||
8 "align" set
|
||||
"box_double" "boxer" set
|
||||
"unbox_double" "unboxer" set
|
||||
[ "box_double" %box ] "boxer" set
|
||||
[ "unbox_double" %unbox ] "unboxer" set
|
||||
T{ float-regs f 8 } "reg-class" set
|
||||
] "double" define-primitive-type
|
||||
|
|
|
|||
|
|
@ -18,8 +18,6 @@ sequences strings words ;
|
|||
"set-" swap append create-in >r c-setter cons r>
|
||||
swap define-compound ;
|
||||
|
||||
: c-align c-type [ "align" get ] bind ;
|
||||
|
||||
: define-field ( offset type name -- offset )
|
||||
>r dup >r c-align align r> r>
|
||||
"struct-name" get swap "-" swap append3
|
||||
|
|
@ -37,5 +35,9 @@ sequences strings words ;
|
|||
"width" set
|
||||
bootstrap-cell "align" set
|
||||
[ swap <displaced-alien> ] "getter" set
|
||||
"width" get [ %unbox-struct ] curry "unboxer" set
|
||||
"struct" on
|
||||
] "struct-name" get define-c-type
|
||||
"struct-name" get in get init-c-type ;
|
||||
|
||||
: c-struct? ( type -- ? ) "struct" swap c-type hash ;
|
||||
|
|
|
|||
|
|
@ -30,9 +30,9 @@ M: stack-params load-insn
|
|||
M: %unbox generate-node ( vop -- )
|
||||
drop
|
||||
! Call the unboxer
|
||||
1 input f compile-c-call
|
||||
2 input f compile-c-call
|
||||
! Store the return value on the C stack
|
||||
0 input 2 input store-insn ;
|
||||
0 input 1 input store-insn ;
|
||||
|
||||
M: %parameter generate-node ( vop -- )
|
||||
! Move a value from the C stack into the fastcall register
|
||||
|
|
@ -49,6 +49,6 @@ M: %alien-invoke generate-node
|
|||
2dup eq? [ 2drop ] [ MOV ] if ;
|
||||
|
||||
M: %box generate-node ( vop -- )
|
||||
drop 1 input load-return-value 0 input f compile-c-call ;
|
||||
drop 0 input load-return-value 1 input f compile-c-call ;
|
||||
|
||||
M: %cleanup generate-node ( vop -- ) drop ;
|
||||
|
|
|
|||
|
|
@ -36,8 +36,6 @@ M: float-regs return-reg drop XMM0 ;
|
|||
M: float-regs fastcall-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
: dual-fp/int-regs? f ;
|
||||
|
||||
: address-operand ( address -- operand )
|
||||
#! On AMD64, we have to load 64-bit addresses into a
|
||||
#! scratch register first. The usage of R11 here is a hack.
|
||||
|
|
|
|||
|
|
@ -7,8 +7,4 @@ DEFER: fixnum-imm? ( -- ? )
|
|||
|
||||
DEFER: vregs ( -- regs )
|
||||
|
||||
DEFER: dual-fp/int-regs? ( -- ? )
|
||||
#! Should fp parameters to fastcalls be loaded in integer
|
||||
#! registers too? Only for PowerPC.
|
||||
|
||||
DEFER: compile-c-call ( library function -- )
|
||||
|
|
|
|||
|
|
@ -25,14 +25,23 @@ M: stack-params load-insn
|
|||
M: %unbox generate-node ( vop -- )
|
||||
drop
|
||||
! Call the unboxer
|
||||
1 input f compile-c-call
|
||||
2 input f compile-c-call
|
||||
! Store the return value on the C stack
|
||||
0 input 2 input store-insn ;
|
||||
0 input 1 input store-insn ;
|
||||
|
||||
M: %unbox-struct generate-node ( vop -- )
|
||||
drop
|
||||
! Load destination address
|
||||
3 1 0 input stack@ ADDI
|
||||
! Load struct size
|
||||
2 input 4 LI
|
||||
! Copy the struct to the stack
|
||||
"unbox_value_struct" f compile-c-call ;
|
||||
|
||||
M: %parameter generate-node ( vop -- )
|
||||
! Move a value from the C stack into the fastcall register
|
||||
drop 0 input 1 input 2 input load-insn ;
|
||||
|
||||
M: %box generate-node ( vop -- ) drop 0 input f compile-c-call ;
|
||||
M: %box generate-node ( vop -- ) drop 1 input f compile-c-call ;
|
||||
|
||||
M: %cleanup generate-node ( vop -- ) drop ;
|
||||
|
|
|
|||
|
|
@ -21,4 +21,3 @@ M: float-regs fastcall-regs drop 8 ;
|
|||
! Mach-O -vs- Linux/PPC
|
||||
: stack@ os "macosx" = 24 8 ? + ;
|
||||
: lr@ os "macosx" = 8 4 ? + ;
|
||||
: dual-fp/int-regs? os "macosx" = ;
|
||||
|
|
|
|||
|
|
@ -31,10 +31,18 @@ GENERIC: fastcall-regs ( register-class -- regs )
|
|||
|
||||
GENERIC: reg-size ( register-class -- n )
|
||||
|
||||
GENERIC: inc-reg-class ( register-class -- )
|
||||
|
||||
M: int-regs reg-size drop cell ;
|
||||
|
||||
M: int-regs inc-reg-class class inc ;
|
||||
|
||||
M: float-regs reg-size float-regs-size ;
|
||||
|
||||
M: float-regs inc-reg-class
|
||||
dup class inc
|
||||
os "macosx" = [ reg-size 4 / int-regs +@ ] [ drop ] if ;
|
||||
|
||||
! A data stack location.
|
||||
TUPLE: ds-loc n ;
|
||||
|
||||
|
|
@ -355,11 +363,16 @@ C: %cleanup make-vop ;
|
|||
|
||||
TUPLE: %unbox ;
|
||||
C: %unbox make-vop ;
|
||||
: %unbox ( n func reg-class -- vop ) 3-in-vop <%unbox> ;
|
||||
: %unbox ( n reg-class func -- vop ) 3-in-vop <%unbox> ;
|
||||
|
||||
TUPLE: %unbox-struct ;
|
||||
C: %unbox-struct make-vop ;
|
||||
: %unbox-struct ( n reg-class size -- vop )
|
||||
3-in-vop <%unbox-struct> ;
|
||||
|
||||
TUPLE: %box ;
|
||||
C: %box make-vop ;
|
||||
: %box ( func reg-class -- vop ) 2-in-vop <%box> ;
|
||||
: %box ( reg-class func -- vop ) 2-in-vop <%box> ;
|
||||
|
||||
TUPLE: %alien-invoke ;
|
||||
C: %alien-invoke make-vop ;
|
||||
|
|
|
|||
|
|
@ -13,13 +13,13 @@ M: float-regs push-reg
|
|||
4 = [ FSTPS ] [ FSTPL ] if ;
|
||||
|
||||
M: %unbox generate-node
|
||||
drop 1 input f compile-c-call 2 input push-reg ;
|
||||
drop 2 input f compile-c-call 1 input push-reg ;
|
||||
|
||||
M: %box generate-node
|
||||
drop
|
||||
1 input push-reg
|
||||
0 input f compile-c-call
|
||||
ESP 1 input reg-size ADD ;
|
||||
0 input push-reg
|
||||
1 input f compile-c-call
|
||||
ESP 0 input reg-size ADD ;
|
||||
|
||||
M: %cleanup generate-node
|
||||
drop 0 input dup zero? [ drop ] [ ESP swap ADD ] if ;
|
||||
|
|
|
|||
|
|
@ -31,8 +31,6 @@ M: int-regs fastcall-regs drop { } ;
|
|||
|
||||
M: float-regs fastcall-regs drop { } ;
|
||||
|
||||
: dual-fp/int-regs? f ;
|
||||
|
||||
: address-operand ( address -- operand )
|
||||
#! On x86, we can always use an address as an operand
|
||||
#! directly.
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: compiler test ;
|
||||
USING: alien compiler kernel test ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ; compiled
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
|
@ -33,3 +33,32 @@ FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; compiled
|
|||
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; compiled
|
||||
[ -34 ] [ 1 2 3 4 5 6 7 8 ffi_test_10 ] unit-test
|
||||
|
||||
BEGIN-STRUCT: foo
|
||||
FIELD: int x
|
||||
FIELD: int y
|
||||
END-STRUCT
|
||||
|
||||
: make-foo ( x y -- foo )
|
||||
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
|
||||
|
||||
FUNCTION: int ffi_test_11 int a foo b int c ; compiled
|
||||
|
||||
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
|
||||
|
||||
BEGIN-STRUCT: rect
|
||||
FIELD: float x
|
||||
FIELD: float y
|
||||
FIELD: float w
|
||||
FIELD: float h
|
||||
END-STRUCT
|
||||
|
||||
: <rect>
|
||||
"rect" <c-object>
|
||||
[ set-rect-h ] keep
|
||||
[ set-rect-w ] keep
|
||||
[ set-rect-y ] keep
|
||||
[ set-rect-x ] keep ;
|
||||
|
||||
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; compiled
|
||||
|
||||
[ 45 ] [ 1 2 3 4 5 6 <rect> 7 8 9 ffi_test_12 ] unit-test
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ void primitive_expired(void)
|
|||
drepl(F);
|
||||
}
|
||||
|
||||
void* alien_offset(CELL object)
|
||||
void *alien_offset(CELL object)
|
||||
{
|
||||
ALIEN *alien;
|
||||
F_ARRAY *array;
|
||||
|
|
@ -40,18 +40,18 @@ void* alien_offset(CELL object)
|
|||
}
|
||||
}
|
||||
|
||||
INLINE void* alien_pointer(void)
|
||||
INLINE void *alien_pointer(void)
|
||||
{
|
||||
F_FIXNUM offset = unbox_signed_cell();
|
||||
return alien_offset(dpop()) + offset;
|
||||
}
|
||||
|
||||
void* unbox_alien(void)
|
||||
void *unbox_alien(void)
|
||||
{
|
||||
return alien_offset(dpop());
|
||||
}
|
||||
|
||||
ALIEN* alien(void* ptr)
|
||||
ALIEN *alien(void* ptr)
|
||||
{
|
||||
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
|
||||
alien->ptr = ptr;
|
||||
|
|
@ -105,17 +105,17 @@ void primitive_string_to_alien(void)
|
|||
drepl(tag_object(string_to_alien(untag_string(dpeek()),true)));
|
||||
}
|
||||
|
||||
void fixup_alien(ALIEN* alien)
|
||||
void fixup_alien(ALIEN *alien)
|
||||
{
|
||||
alien->expired = true;
|
||||
}
|
||||
|
||||
void fixup_displaced_alien(DISPLACED_ALIEN* d)
|
||||
void fixup_displaced_alien(DISPLACED_ALIEN *d)
|
||||
{
|
||||
data_fixup(&d->alien);
|
||||
}
|
||||
|
||||
void collect_displaced_alien(DISPLACED_ALIEN* d)
|
||||
void collect_displaced_alien(DISPLACED_ALIEN *d)
|
||||
{
|
||||
copy_handle(&d->alien);
|
||||
}
|
||||
|
|
@ -128,7 +128,7 @@ void primitive_alien_##name (void) \
|
|||
void primitive_set_alien_##name (void) \
|
||||
{ \
|
||||
type* ptr = alien_pointer(); \
|
||||
type value = unbox_##boxer (); \
|
||||
type value = unbox_##boxer(); \
|
||||
*ptr = value; \
|
||||
}
|
||||
|
||||
|
|
@ -144,3 +144,9 @@ DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
|
|||
DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
|
||||
DEF_ALIEN_SLOT(float,float,float)
|
||||
DEF_ALIEN_SLOT(double,double,double)
|
||||
|
||||
/* for FFI calls passing structs by value */
|
||||
void unbox_value_struct(void *dest, CELL size)
|
||||
{
|
||||
memcpy(dest,unbox_alien(),size);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -62,3 +62,5 @@ void primitive_alien_float(void);
|
|||
void primitive_set_alien_float(void);
|
||||
void primitive_alien_double(void);
|
||||
void primitive_set_alien_double(void);
|
||||
|
||||
void unbox_value_struct(void *dest, CELL size);
|
||||
|
|
|
|||
|
|
@ -66,3 +66,19 @@ int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h)
|
|||
printf("ffi_test_10(%d,%d,%f,%d,%f,%d,%d,%d)\n",a,b,c,d,e,f,g,h);
|
||||
return a - b - c - d - e - f - g - h;
|
||||
}
|
||||
|
||||
struct foo { int x, y; };
|
||||
|
||||
int ffi_test_11(int a, struct foo b, int c)
|
||||
{
|
||||
printf("ffi_test_11(%d,{%d,%d},%d)\n",a,b.x,b.y,c);
|
||||
return a * b.x + c * b.y;
|
||||
}
|
||||
|
||||
struct rect { float x, y, w, h; };
|
||||
|
||||
int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
|
||||
{
|
||||
printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f);
|
||||
return a + b + c.x + c.y + c.w + c.h + d + e + f;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue