<<
: add-f2c-libraries ( -- )
- "I77" "libI77.so" "cdecl" add-library
- "F77" "libF77.so" "cdecl" add-library ;
+ "I77" "libI77.so" cdecl add-library
+ "F77" "libF77.so" cdecl add-library ;
os netbsd? [ add-f2c-libraries ] when
>>
[ "__" append ] [ "_" append ] if ;
HOOK: fortran-c-abi fortran-abi ( -- abi )
-M: f2c-abi fortran-c-abi "cdecl" ;
-M: g95-abi fortran-c-abi "cdecl" ;
-M: gfortran-abi fortran-c-abi "cdecl" ;
-M: intel-unix-abi fortran-c-abi "cdecl" ;
-M: intel-windows-abi fortran-c-abi "cdecl" ;
+M: f2c-abi fortran-c-abi cdecl ;
+M: g95-abi fortran-c-abi cdecl ;
+M: gfortran-abi fortran-c-abi cdecl ;
+M: intel-unix-abi fortran-c-abi cdecl ;
+M: intel-windows-abi fortran-c-abi cdecl ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
HELP: <library>
{ $values
- { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+ { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
{ "library" library } }
{ $description "Opens a C library using the path and ABI parameters and outputs a library tuple." }
{ $notes "User code should use " { $link add-library } " so that the opened library is added to a global hashtable, " { $link libraries } "." } ;
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
- { { $snippet "abi" } " - the ABI used by the library, either " { $snippet "cdecl" } " or " { $snippet "stdcall" } }
+ { { $snippet "abi" } " - the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } }
{ { $snippet "dll" } " - an instance of the " { $link dll } " class; only set if the library is loaded" }
}
} ;
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
-{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $values { "name" string } { "path" string } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } " and the specified ABI. The logical library name can then be used by a " { $link POSTPONE: LIBRARY: } " form to specify the logical library for subsequent " { $link POSTPONE: FUNCTION: } " definitions." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " must be placed within a " { $snippet "<< ... >>" } " parse-time evaluation block."
$nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
- " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
- " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+ " { [ os macosx? ] [ \"libfreetype.6.dylib\" cdecl add-library ] }"
+ " { [ os windows? ] [ \"freetype6.dll\" cdecl add-library ] }"
" [ drop ]"
"} cond >>"
}
[ <library> swap libraries get set-at ] 3bi ;
: library-abi ( library -- abi )
- library [ abi>> ] [ "cdecl" ] if* ;
+ library [ abi>> ] [ cdecl ] if* ;
SYMBOL: deploy-libraries
IN: alien.remote-control
: eval-callback ( -- callback )
- void* { c-string } "cdecl"
+ void* { c-string } cdecl
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback ( -- callback )
- void { } "cdecl" [ yield ] alien-callback ;
+ void { } cdecl [ yield ] alien-callback ;
: sleep-callback ( -- callback )
- void { long } "cdecl" [ sleep ] alien-callback ;
+ void { long } cdecl [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup optimized? [ execute ] [ drop f ] if ; inline
IN: cairo.ffi
<< {
- { [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
+ { [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond >>
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
- [ void { pointer: void } "cdecl" ] dip alien-callback ; inline
+ [ void { pointer: void } cdecl ] dip alien-callback ; inline
! See cairo.h for details
STRUCT: cairo_user_data_key_t
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
- [ cairo_status_t { pointer: void c-string int } "cdecl" ] dip alien-callback ; inline
+ [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
- [ cairo_status_t { pointer: void c-string int } "cdecl" ] dip alien-callback ; inline
+ [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
: prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip
- '[ _ _ "cdecl" _ alien-callback ]
+ '[ _ _ cdecl _ alien-callback ]
(( -- callback )) define-temp ;
: prepare-methods ( methods -- methods )
: alien-parameters ( params -- seq )
dup parameters>>
- swap return>> large-struct? [ void* prefix ] when ;
+ swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
: alien-return ( params -- type )
return>> dup large-struct? [ drop void ] when ;
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
[ int f "malloc" { int } alien-invoke ]
- [ int { int } "cdecl" alien-indirect ]
- [ int { int } "cdecl" [ ] alien-callback ]
+ [ int { int } cdecl alien-indirect ]
+ [ int { int } cdecl [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-GENERIC: reg-class-full? ( reg-class -- ? )
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-M: stack-params reg-class-full? drop t ;
+M: stack-params reg-class-full? 2drop t ;
M: reg-class reg-class-full?
- [ get ] [ param-regs length ] bi >= ;
+ [ get ] swap '[ _ param-regs length ] bi >= ;
: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
: alloc-fastcall-param ( rep -- n reg-class rep )
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-: alloc-parameter ( parameter -- reg rep )
- c-type-rep dup reg-class-of reg-class-full?
+:: alloc-parameter ( parameter abi -- reg rep )
+ parameter c-type-rep dup reg-class-of abi reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
- [ param-reg ] dip ;
+ [ abi param-reg ] dip ;
+
+SYMBOL: (stack-value)
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
+
+: ((flatten-type)) ( type to-type -- seq )
+ [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
: (flatten-int-type) ( type -- seq )
- stack-size cell align cell /i void* c-type <repetition> ;
+ void* ((flatten-type)) ;
+: (flatten-stack-type) ( type -- seq )
+ (stack-value) ((flatten-type)) ;
GENERIC: flatten-value-type ( type -- types )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
- [ alien-parameters flatten-value-types ]
- [ '[ alloc-parameter _ execute ] ]
+ [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+ [ '[ _ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
: reverse-each-parameter ( parameters quot -- )
3array ;
: alien-invoke-dlsym ( params -- symbols dll )
- [ dup abi>> "stdcall" = [ stdcall-mangle ] [ function>> ] if ]
+ [ dup abi>> stdcall = [ stdcall-mangle ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
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 ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
{ [ 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' )
[ f f ] 2dip
- void { void* void* double-rect } "cdecl" alien-indirect
+ 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
TYPEDEF: alien.c-types:int type-3
: callback ( -- ptr )
- type-3 { type-1 type-1 } "cdecl" [ + >integer ] alien-callback ;
+ type-3 { type-1 type-1 } cdecl [ + >integer ] alien-callback ;
TYPEDEF: alien.c-types:float type-2
: indirect ( x y ptr -- z )
- type-3 { type-2 type-2 } "cdecl" alien-indirect ;
+ type-3 { type-2 type-2 } cdecl alien-indirect ;
[ ] [
"USING: alien.c-types alien.syntax ;
{ [ os winnt? ] [ "zlib1.dll" ] }
{ [ os macosx? ] [ "libz.dylib" ] }
{ [ os unix? ] [ "libz.so" ] }
-} cond "cdecl" add-library >>
+} cond cdecl add-library >>
LIBRARY: zlib
[ fds>> [ enable-all-callbacks ] each ] bi ;
: timer-callback ( -- callback )
- void { CFRunLoopTimerRef void* } "cdecl"
+ void { CFRunLoopTimerRef void* } cdecl
[ 2drop reset-run-loop yield ] alien-callback ;
: init-thread-timer ( -- )
GENERIC: return-reg ( reg-class -- reg )
! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( reg-class -- regs )
+GENERIC# param-regs 1 ( reg-class abi -- regs )
-M: stack-params param-regs drop f ;
+M: stack-params param-regs 2drop f ;
-GENERIC: param-reg ( n reg-class -- reg )
+GENERIC# param-reg 1 ( n reg-class abi -- reg )
M: reg-class param-reg param-regs nth ;
-M: stack-params param-reg drop ;
+M: stack-params param-reg 2drop ;
! Is this integer small enough to be an immediate operand for
! %add-imm, %sub-imm, and %mul-imm?
! %and-imm, %or-imm, and %xor-imm?
HOOK: immediate-bitwise? cpu ( n -- ? )
+! What c-type describes the implicit struct return pointer for large structs?
+HOOK: struct-return-pointer-type cpu ( -- c-type )
+
! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
HOOK: %end-callback-value cpu ( c-type -- )
-HOOK: callback-return-rewind cpu ( params -- n )
+HOOK: stack-cleanup cpu ( params -- n )
-M: object callback-return-rewind drop 0 ;
+M: object stack-cleanup drop 0 ;
M: linux lr-save 1 cells ;
-M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
+M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ;
M: ppc value-struct? drop f ;
M: macosx lr-save 2 cells ;
-M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
+M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: ppc value-struct? drop t ;
M: integer float-function-param* FMR ;
: float-function-param ( i src -- )
- [ float-regs param-regs nth ] dip float-function-param* ;
+ [ float-regs cdecl param-regs nth ] dip float-function-param* ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
-M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M:: ppc %save-param-reg ( stack reg rep -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- n [ 0 rep reg-class-of param-reg rep %load-param-reg ] when*
+ n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
func f %alien-invoke ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
+M: ppc struct-return-pointer-type void* ;
+
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
USING: alien alien.c-types tools.test cpu.x86.assembler
cpu.x86.assembler.operands ;
-: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ;
+: assembly-test-1 ( -- x ) int { } cdecl [ EAX 3 MOV ] alien-assembly ;
[ 3 ] [ assembly-test-1 ] unit-test
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.libraries alien.syntax arrays
-kernel fry math namespaces sequences system layouts io
-vocabs.loader accessors init combinators command-line make
-compiler compiler.units compiler.constants compiler.alien
+USING: locals alien alien.c-types alien.libraries alien.syntax
+arrays kernel fry math namespaces sequences system layouts io
+vocabs.loader accessors init classes.struct combinators command-line
+make compiler compiler.units compiler.constants compiler.alien
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
[ align-code ]
bi ;
-M: x86.32 pic-tail-reg EBX ;
+M: x86.32 pic-tail-reg EDX ;
-M: x86.32 reserved-stack-space 4 cells ;
+M: x86.32 reserved-stack-space 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
-! On x86, parameters are never passed in registers.
+! On x86, parameters are usually never passed in registers, except with Microsoft's
+! "thiscall" and "fastcall" abis
M: int-regs return-reg drop EAX ;
-M: int-regs param-regs drop { } ;
-M: float-regs param-regs drop { } ;
+M: float-regs param-regs 2drop { } ;
+
+M: int-regs param-regs
+ nip {
+ { thiscall [ { ECX } ] }
+ { fastcall [ { ECX EDX } ] }
+ [ drop { } ]
+ } case ;
GENERIC: load-return-reg ( src rep -- )
GENERIC: store-return-reg ( dst rep -- )
+M: stack-params load-return-reg drop EAX swap MOV ;
+M: stack-params store-return-reg drop EAX MOV ;
+
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
-M: x86.32 %load-param-reg
- stack-params assert=
- [ [ EAX ] dip local@ MOV ] dip
- stack@ EAX MOV ;
+M: stack-params copy-register*
+ drop
+ {
+ { [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
+ { [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
+ } cond ;
-M: x86.32 %save-param-reg 3drop ;
+M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
+
+M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
- over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
+ over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( n rep func -- )
n rep (%box)
func "libm" load-library %alien-invoke
dst float-function-return ;
-: stdcall? ( params -- ? )
- abi>> "stdcall" = ;
-
: funny-large-struct-return? ( params -- ? )
#! MINGW ABI incompatibility disaster
[ return>> large-struct? ]
- [ abi>> "mingw" = os windows? not or ]
+ [ abi>> mingw = os windows? not or ]
bi and ;
-M: x86.32 %cleanup ( params -- )
- #! a) If we just called an stdcall function in Windows, it
- #! cleaned up the stack frame for us. But we don't want that
- #! so we 'undo' the cleanup since we do that in %epilogue.
- #! b) If we just called a function returning a struct, we
- #! have to fix ESP.
+: callee-cleanup? ( abi -- ? )
+ { stdcall fastcall thiscall } member? ;
+
+: stack-arg-size ( params -- n )
+ dup abi>> '[
+ alien-parameters flatten-value-types
+ [ _ alloc-parameter 2drop ] each
+ stack-params get
+ ] with-param-regs ;
+
+M: x86.32 stack-cleanup ( params -- n )
+ #! a) Functions which are stdcall/fastcall/thiscall have to
+ #! clean up the caller's stack frame.
+ #! b) Functions returning large structs on MINGW have to
+ #! fix ESP.
{
- { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
- { [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
- [ drop ]
+ { [ dup abi>> callee-cleanup? ] [ stack-arg-size ] }
+ { [ dup funny-large-struct-return? ] [ drop 4 ] }
+ [ drop 0 ]
} cond ;
+M: x86.32 %cleanup ( params -- )
+ stack-cleanup [ ESP swap SUB ] unless-zero ;
+
M:: x86.32 %call-gc ( gc-root-count temp -- )
temp gc-root-base special@ LEA
8 save-vm-ptr
M: x86.32 dummy-fp-params? f ;
-M: x86.32 callback-return-rewind ( params -- n )
- #! a) If the callback is stdcall, we have to clean up the
- #! caller's stack frame.
- #! b) If the callback is returning a large struct, we have
- #! to fix ESP.
- {
- { [ dup stdcall? ] [ <alien-stack-frame> [ params>> ] [ return>> ] bi + ] }
- { [ dup funny-large-struct-return? ] [ drop 4 ] }
- [ drop 0 ]
- } cond ;
-
! Dreadful
-M: object flatten-value-type (flatten-int-type) ;
+M: object flatten-value-type (flatten-stack-type) ;
+M: struct-c-type flatten-value-type (flatten-stack-type) ;
+M: long-long-type flatten-value-type (flatten-stack-type) ;
+M: c-type flatten-value-type
+ dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
+
+M: x86.32 struct-return-pointer-type (stack-value) ;
check-sse
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
: temp0 ( -- reg ) EAX ;
-: temp1 ( -- reg ) EDX ;
-: temp2 ( -- reg ) ECX ;
-: temp3 ( -- reg ) EBX ;
+: temp1 ( -- reg ) ECX ;
+: temp2 ( -- reg ) EBX ;
+: temp3 ( -- reg ) EDX ;
+: pic-tail-reg ( -- reg ) EDX ;
: stack-reg ( -- reg ) ESP ;
: frame-reg ( -- reg ) EBP ;
-: vm-reg ( -- reg ) ECX ;
+: vm-reg ( -- reg ) EBX ;
: ctx-reg ( -- reg ) EBP ;
: nv-regs ( -- seq ) { ESI EDI EBX } ;
-: nv-reg ( -- reg ) EBX ;
+: nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
] jit-prolog jit-define
[
- temp3 0 MOV rc-absolute-cell rt-here jit-rel
+ pic-tail-reg 0 MOV rc-absolute-cell rt-here jit-rel
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define
: jit-save-context ( -- )
jit-load-context
- EDX ESP -4 [+] LEA
- ctx-reg context-callstack-top-offset [+] EDX MOV
+ ECX ESP -4 [+] LEA
+ ctx-reg context-callstack-top-offset [+] ECX MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
[
! Load callstack object
- EBX ds-reg [] MOV
+ temp3 ds-reg [] MOV
ds-reg bootstrap-cell SUB
! Get ctx->callstack_bottom
jit-load-vm
jit-load-context
- EAX ctx-reg context-callstack-bottom-offset [+] MOV
+ temp0 ctx-reg context-callstack-bottom-offset [+] MOV
! Get top of callstack object -- 'src' for memcpy
- EBP EBX callstack-top-offset [+] LEA
+ temp1 temp3 callstack-top-offset [+] LEA
! Get callstack length, in bytes --- 'len' for memcpy
- EDX EBX callstack-length-offset [+] MOV
- EDX tag-bits get SHR
+ temp2 temp3 callstack-length-offset [+] MOV
+ temp2 tag-bits get SHR
! Compute new stack pointer -- 'dst' for memcpy
- EAX EDX SUB
+ temp0 temp2 SUB
! Install new stack pointer
- ESP EAX MOV
+ ESP temp0 MOV
! Call memcpy
- EDX PUSH
- EBP PUSH
- EAX PUSH
+ temp2 PUSH
+ temp1 PUSH
+ temp0 PUSH
"factor_memcpy" jit-call
ESP 12 ADD
! Return with new callstack
! Inline cache miss entry points
: jit-load-return-address ( -- )
- EBX ESP stack-frame-size bootstrap-cell - [+] MOV ;
+ pic-tail-reg ESP stack-frame-size bootstrap-cell - [+] MOV ;
! These are always in tail position with an existing stack
! frame, and the stack. The frame setup takes this into account.
jit-load-vm
jit-save-context
ESP 4 [+] vm-reg MOV
- ESP [] EBX MOV
+ ESP [] pic-tail-reg MOV
"inline_cache_miss" jit-call
jit-restore-context ;
[
ESP [] EAX MOV
ESP 4 [+] EDX MOV
+ jit-load-vm
ESP 8 [+] vm-reg MOV
jit-call
]
EBX tag-bits get SAR
ESP [] EBX MOV
ESP 4 [+] EBP MOV
+ jit-load-vm
ESP 8 [+] vm-reg MOV
"overflow_fixnum_multiply" jit-call
]
! Load context and parameter from datastack
EAX ds-reg [] MOV
EAX EAX alien-offset [+] MOV
- EBX ds-reg -4 [+] MOV
+ EDX ds-reg -4 [+] MOV
ds-reg 8 SUB
! Make the new context active
! Store parameter to datastack
ds-reg 4 ADD
- ds-reg [] EBX MOV ;
+ ds-reg [] EDX MOV ;
[ jit-set-context ] \ (set-context) define-sub-primitive
"new_context" jit-call
! Save pointer to quotation and parameter
- EBX ds-reg MOV
+ EDX ds-reg MOV
ds-reg 8 SUB
! Make the new context active
EAX jit-switch-context
! Push parameter
- EAX EBX -4 [+] MOV
+ EAX EDX -4 [+] MOV
ds-reg 4 ADD
ds-reg [] EAX MOV
0 PUSH
! Jump to initial quotation
- EAX EBX [] MOV
+ EAX EDX [] MOV
jit-jump-quot ;
[ jit-start-context ] \ (start-context) define-sub-primitive
cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
IN: cpu.x86.64.tests
-: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ;
+: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
[ 3 ] [ assembly-test-1 ] unit-test
: assembly-test-2 ( a b -- x )
- int { int int } "cdecl" [
+ int { int int } cdecl [
param-reg-0 param-reg-1 ADD
int-regs return-reg param-reg-0 MOV
] alien-assembly ;
FROM: layouts => cell cells ;
IN: cpu.x86.64
-: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
-: param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
-: param-reg-2 ( -- reg ) 2 int-regs param-reg ; inline
-: param-reg-3 ( -- reg ) 3 int-regs param-reg ; inline
+: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
+: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
+: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
+: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
M: x86.64 pic-tail-reg RBX ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ;
-: param@ ( n -- op ) reserved-stack-space + stack@ ;
-
M: x86.64 %prologue ( n -- )
temp-reg -7 [RIP+] LEA
dup PUSH
"to_value_struct" f %alien-invoke ;
: load-return-value ( rep -- )
- [ [ 0 ] dip reg-class-of param-reg ]
+ [ [ 0 ] dip reg-class-of cdecl param-reg ]
[ reg-class-of return-reg ]
[ ]
tri %copy ;
M:: x86.64 %box ( n rep func -- )
n [
n
- 0 rep reg-class-of param-reg
+ 0 rep reg-class-of cdecl param-reg
rep %load-param-reg
] [
rep load-return-value
unbox-return ;
: float-function-param ( i src -- )
- [ float-regs param-regs nth ] dip double-rep %copy ;
+ [ float-regs cdecl param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
! Call GC
"inline_gc" f %alien-invoke ;
+M: x86.64 struct-return-pointer-type void* ;
+
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
: shift-arg ( -- reg ) RCX ;
: div-arg ( -- reg ) RAX ;
: mod-arg ( -- reg ) RDX ;
-: temp0 ( -- reg ) RDI ;
-: temp1 ( -- reg ) RSI ;
+: temp0 ( -- reg ) RAX ;
+: temp1 ( -- reg ) RCX ;
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
+: pic-tail-reg ( -- reg ) RBX ;
: return-reg ( -- reg ) RAX ;
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
] jit-prolog jit-define
[
- temp3 5 [RIP+] LEA
+ pic-tail-reg 5 [RIP+] LEA
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define
IN: cpu.x86.64.unix
M: int-regs param-regs
- drop { RDI RSI RDX RCX R8 R9 } ;
+ 2drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs param-regs
- drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+ 2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: x86.64 reserved-stack-space 0 ;
-SYMBOL: (stack-value)
-! The ABI for passing structs by value is pretty great
-<< void* c-type clone \ (stack-value) define-primitive-type
-stack-params \ (stack-value) c-type (>>rep) >>
-
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: flatten-large-struct ( c-type -- seq )
- heap-size cell align
- cell /i \ (stack-value) c-type <repetition> ;
+ (flatten-stack-type) ;
: flatten-struct ( c-type -- seq )
dup heap-size 16 > [
cpu.x86.assembler.operands ;
IN: cpu.x86.64.winnt
-M: int-regs param-regs drop { RCX RDX R8 R9 } ;
+M: int-regs param-regs 2drop { RCX RDX R8 R9 } ;
-M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
+M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-stack-space 4 cells ;
[
! Optimizing compiler's side of callback accesses
! arguments that are on the stack via the frame pointer.
- ! On x86-64, some arguments are passed in registers, and
- ! so the only register that is safe for use here is nv-reg.
+ ! On x86-32 fastcall, and x86-64, some arguments are passed
+ ! in registers, and so the only registers that are safe for
+ ! use here are frame-reg, nv-reg and vm-reg.
frame-reg PUSH
frame-reg stack-reg MOV
frame-reg POP
- ! Callbacks which return structs, or use stdcall, need a
- ! parameter here. See the comment in callback-return-rewind
- ! in cpu.x86.32
+ ! Callbacks which return structs, or use stdcall/fastcall/thiscall,
+ ! need a parameter here.
+
+ ! See the comment for M\ x86.32 stack-cleanup in cpu.x86.32
HEX: ffff RET rc-absolute-2 rt-untagged jit-rel
] callback-stub jit-define
[
! Load word
- nv-reg 0 MOV rc-absolute-cell rt-literal jit-rel
+ temp0 0 MOV rc-absolute-cell rt-literal jit-rel
! Bump profiling counter
- nv-reg profile-count-offset [+] 1 tag-fixnum ADD
+ temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
- nv-reg nv-reg word-code-offset [+] MOV
+ temp0 temp0 word-code-offset [+] MOV
! Compute word entry point
- nv-reg compiled-header-size ADD
+ temp0 compiled-header-size ADD
! Jump to entry point
- nv-reg JMP
+ temp0 JMP
] jit-profiling jit-define
[
! ! ! Polymorphic inline caches
-! The PIC stubs are not permitted to touch temp3.
+! The PIC stubs are not permitted to touch pic-tail-reg.
! Load a value from a stack position
[
! load value
temp3 ds-reg [] MOV
! make a copy
- temp1 temp3 MOV
- ! compute positive shift value in temp1
- temp1 CL SHL
+ temp2 temp3 MOV
+ ! compute positive shift value in temp2
+ temp2 CL SHL
shift-arg NEG
! compute negative shift value in temp3
temp3 CL SAR
temp3 tag-mask get bitnot AND
shift-arg 0 CMP
- ! if shift count was negative, move temp0 to temp1
- temp1 temp3 CMOVGE
+ ! if shift count was negative, move temp0 to temp2
+ temp2 temp3 CMOVGE
! push to stack
- ds-reg [] temp1 MOV
+ ds-reg [] temp2 MOV
] \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
! load second parameter
- temp3 ds-reg [] MOV
+ temp1 ds-reg [] MOV
! load first parameter
div-arg ds-reg bootstrap-cell neg [+] MOV
! make a copy
! sign-extend
mod-arg bootstrap-cell-bits 1 - SAR
! divide
- temp3 IDIV ;
+ temp1 IDIV ;
[
jit-fixnum-/mod
<PRIVATE
: (sse-version) ( -- n )
- int { } "cdecl" [
+ int { } cdecl [
"sse-42" define-label
"sse-41" define-label
"ssse-3" define-label
HOOK: instruction-count cpu ( -- n )
M: x86.32 instruction-count
- longlong { } "cdecl" [
+ longlong { } cdecl [
RDTSC
] alien-assembly ;
M: x86.64 instruction-count
- longlong { } "cdecl" [
+ longlong { } cdecl [
RAX 0 MOV
RDTSC
RDX 32 SHL
: gc-root@ ( n -- op ) gc-root-offset special@ ;
+: param@ ( n -- op ) reserved-stack-space + stack@ ;
+
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
{ [ os winnt? ] [ "libpq.dll" ] }
{ [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
-} cond "cdecl" add-library >>
+} cond cdecl add-library >>
! ConnSatusType
CONSTANT: CONNECTION_OK HEX: 0
{ [ os winnt? ] [ "sqlite3.dll" ] }
{ [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
{ [ os unix? ] [ "libsqlite3.so" ] }
- } cond "cdecl" add-library >>
+ } cond cdecl add-library >>
! Return values from sqlite functions
CONSTANT: SQLITE_OK 0 ! Successful result
<<
{
- { [ os winnt? ] [ "glib" "libglib-2.0-0.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "glib" "/opt/local/lib/libglib-2.0.0.dylib" "cdecl" add-library ] }
+ { [ os winnt? ] [ "glib" "libglib-2.0-0.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "glib" "/opt/local/lib/libglib-2.0.0.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond
{
- { [ os winnt? ] [ "gobject" "libgobject-2.0-0.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "gobject" "/opt/local/lib/libgobject-2.0.0.dylib" "cdecl" add-library ] }
+ { [ os winnt? ] [ "gobject" "libgobject-2.0-0.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "gobject" "/opt/local/lib/libgobject-2.0.0.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond
: file-descriptor-callback ( -- callback )
void { CFFileDescriptorRef CFOptionFlags void* }
- "cdecl" [
+ cdecl [
3drop
0 mx get kqueue-mx>> wait-for-events
reset-run-loop
] [ drop ] if ;
: password-callback ( -- alien )
- int { void* int bool void* } "cdecl"
+ int { void* int bool void* } cdecl
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
} cleave
int
{ SOCKET void* int PVOID DWORD LPDWORD void* }
- "stdcall" alien-indirect drop
+ stdcall alien-indirect drop
winsock-error-string [ throw ] when* ; inline
M: object establish-connection ( client-out remote -- )
IN: math.floats.env.x86.32
M: x86.32 get-sse-env
- void { void* } "cdecl" [
+ void { void* } cdecl [
EAX ESP [] MOV
EAX [] STMXCSR
] alien-assembly ;
M: x86.32 set-sse-env
- void { void* } "cdecl" [
+ void { void* } cdecl [
EAX ESP [] MOV
EAX [] LDMXCSR
] alien-assembly ;
M: x86.32 get-x87-env
- void { void* } "cdecl" [
+ void { void* } cdecl [
EAX ESP [] MOV
EAX [] FNSTSW
EAX 2 [+] FNSTCW
] alien-assembly ;
M: x86.32 set-x87-env
- void { void* } "cdecl" [
+ void { void* } cdecl [
EAX ESP [] MOV
FNCLEX
EAX 2 [+] FLDCW
IN: math.floats.env.x86.64
M: x86.64 get-sse-env
- void { void* } "cdecl" [
- int-regs param-regs first [] STMXCSR
+ void { void* } cdecl [
+ int-regs cdecl param-regs first [] STMXCSR
] alien-assembly ;
M: x86.64 set-sse-env
- void { void* } "cdecl" [
- int-regs param-regs first [] LDMXCSR
+ void { void* } cdecl [
+ int-regs cdecl param-regs first [] LDMXCSR
] alien-assembly ;
M: x86.64 get-x87-env
- void { void* } "cdecl" [
- int-regs param-regs first [] FNSTSW
- int-regs param-regs first 2 [+] FNSTCW
+ void { void* } cdecl [
+ int-regs cdecl param-regs first [] FNSTSW
+ int-regs cdecl param-regs first 2 [+] FNSTCW
] alien-assembly ;
M: x86.64 set-x87-env
- void { void* } "cdecl" [
+ void { void* } cdecl [
FNCLEX
- int-regs param-regs first 2 [+] FLDCW
+ int-regs cdecl param-regs first 2 [+] FLDCW
] alien-assembly ;
: gl-function-context ( -- context ) 0 ; inline
: gl-function-address ( name -- address ) f dlsym ; inline
-: gl-function-calling-convention ( -- str ) "cdecl" ; inline
+: gl-function-calling-convention ( -- str ) cdecl ; inline
-USING: kernel x11.glx ;
+USING: alien kernel x11.glx ;
IN: opengl.gl.unix
: gl-function-context ( -- context ) glXGetCurrentContext ; inline
: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline
-: gl-function-calling-convention ( -- str ) "cdecl" ; inline
+: gl-function-calling-convention ( -- str ) cdecl ; inline
-USING: alien.c-types alien.syntax kernel windows.types ;
+USING: alien alien.c-types alien.syntax kernel windows.types ;
IN: opengl.gl.windows
LIBRARY: gl
: gl-function-context ( -- context ) wglGetCurrentContext ; inline
: gl-function-address ( name -- address ) wglGetProcAddress ; inline
-: gl-function-calling-convention ( -- str ) "stdcall" ; inline
+: gl-function-calling-convention ( -- str ) stdcall ; inline
{
{ [ os openbsd? ] [ ] } ! VM is linked with it
{ [ os netbsd? ] [ ] }
- { [ os winnt? ] [ "libcrypto" "libeay32.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "libcrypto" "libcrypto.dylib" "cdecl" add-library ] }
- { [ os unix? ] [ "libcrypto" "libcrypto.so" "cdecl" add-library ] }
+ { [ os winnt? ] [ "libcrypto" "libeay32.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "libcrypto" "libcrypto.dylib" cdecl add-library ] }
+ { [ os unix? ] [ "libcrypto" "libcrypto.so" cdecl add-library ] }
} cond
>>
<< {
{ [ os openbsd? ] [ ] } ! VM is linked with it
{ [ os netbsd? ] [ ] }
- { [ os winnt? ] [ "libssl" "ssleay32.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "libssl" "libssl.dylib" "cdecl" add-library ] }
- { [ os unix? ] [ "libssl" "libssl.so" "cdecl" add-library ] }
+ { [ os winnt? ] [ "libssl" "ssleay32.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "libssl" "libssl.dylib" cdecl add-library ] }
+ { [ os unix? ] [ "libssl" "libssl.so" cdecl add-library ] }
} cond >>
CONSTANT: X509_FILETYPE_PEM 1
IN: pango.cairo
<< {
- { [ os winnt? ] [ "pangocairo" "libpangocairo-1.0-0.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "pangocairo" "/opt/local/lib/libpangocairo-1.0.0.dylib" "cdecl" add-library ] }
+ { [ os winnt? ] [ "pangocairo" "libpangocairo-1.0-0.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "pangocairo" "/opt/local/lib/libpangocairo-1.0.0.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond >>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<< {
- { [ os winnt? ] [ "pango" "libpango-1.0-0.dll" "cdecl" add-library ] }
- { [ os macosx? ] [ "pango" "/opt/local/lib/libpango-1.0.0.dylib" "cdecl" add-library ] }
+ { [ os winnt? ] [ "pango" "libpango-1.0-0.dll" cdecl add-library ] }
+ { [ os macosx? ] [ "pango" "/opt/local/lib/libpango-1.0.0.dylib" cdecl add-library ] }
{ [ os unix? ] [ ] }
} cond >>
[ callbacks get ] dip '[ _ <callback> ] cache ;
: callback-bottom ( params -- )
- [ xt>> ] [ callback-return-rewind ] bi
- '[ _ _ callback-xt ] infer-quot-here ;
+ [ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ;
: infer-alien-callback ( -- )
alien-callback-params new
IN: tools.deploy.test.9
: callback-test ( -- callback )
- int { int } "cdecl" [ 1 + ] alien-callback ;
+ int { int } cdecl [ 1 + ] alien-callback ;
: indirect-test ( -- )
- 10 callback-test int { int } "cdecl" alien-indirect 11 assert= ;
+ 10 callback-test int { int } cdecl alien-indirect 11 assert= ;
MAIN: indirect-test
TR: tabs>spaces "\t" "\s" ;
+GENERIC: (>address) ( object -- n )
+
+M: integer (>address) ;
+M: alien (>address) alien-address ;
+
PRIVATE>
M: byte-array disassemble
2array disassemble
] with-destructors ;
-M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
+M: pair disassemble first2 [ (>address) ] bi@ disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-code 2array disassemble ;
{ [ os macosx? ] [ "libudis86.0.dylib" ] }
{ [ os unix? ] [ "libudis86.so.0" ] }
{ [ os winnt? ] [ "libudis86.dll" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
>>
LIBRARY: libudis86
[ ] [ \ + usage-profile. ] unit-test
-: callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ;
+: callback-test ( -- callback ) void { } cdecl [ ] alien-callback ;
-: indirect-test ( callback -- ) void { } "cdecl" alien-indirect ;
+: indirect-test ( callback -- ) void { } cdecl alien-indirect ;
: foobar ( -- ) ;
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
- uint { void* uint long long } "stdcall" [
+ uint { void* uint long long } stdcall [
pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
FUNCTION: int utimes ( c-string path, timeval[2] times ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
-"librt" "librt.so" "cdecl" add-library
+"librt" "librt.so" cdecl add-library
USING: alien sequences alien.libraries ;
{
- { "advapi32" "\\windows\\coredll.dll" "stdcall" }
- { "gdi32" "\\windows\\coredll.dll" "stdcall" }
- { "user32" "\\windows\\coredll.dll" "stdcall" }
- { "kernel32" "\\windows\\coredll.dll" "stdcall" }
- { "winsock" "\\windows\\ws2.dll" "stdcall" }
- { "mswsock" "\\windows\\ws2.dll" "stdcall" }
- { "libc" "\\windows\\coredll.dll" "stdcall" }
- { "libm" "\\windows\\coredll.dll" "stdcall" }
- ! { "gl" "libGLES_CM.dll" "stdcall" }
- ! { "glu" "libGLES_CM.dll" "stdcall" }
- { "ole32" "ole32.dll" "stdcall" }
+ { "advapi32" "\\windows\\coredll.dll" stdcall }
+ { "gdi32" "\\windows\\coredll.dll" stdcall }
+ { "user32" "\\windows\\coredll.dll" stdcall }
+ { "kernel32" "\\windows\\coredll.dll" stdcall }
+ { "winsock" "\\windows\\ws2.dll" stdcall }
+ { "mswsock" "\\windows\\ws2.dll" stdcall }
+ { "libc" "\\windows\\coredll.dll" stdcall }
+ { "libm" "\\windows\\coredll.dll" stdcall }
+ ! { "gl" "libGLES_CM.dll" stdcall }
+ ! { "glu" "libGLES_CM.dll" stdcall }
+ { "ole32" "ole32.dll" stdcall }
} [ first3 add-library ] each
[ 2nip length ] 3keep
'[
_ npick *void* _ cell * alien-cell _ _
- "stdcall" alien-indirect
+ stdcall alien-indirect
] ;
TUPLE: com-interface-definition word parent iid functions ;
] [
first2 (finish-thunk)
] bi*
- "stdcall" swap compile-alien-callback
+ stdcall swap compile-alien-callback
] 2map ;
: (make-callbacks) ( implementations -- sequence )
kernel math windows.types windows.ole32 ;
IN: windows.ddk.hid
-<< "hid" "hid.dll" "stdcall" add-library >>
+<< "hid" "hid.dll" stdcall add-library >>
LIBRARY: hid
TYPEDEF: LONG NTSTATUS
alien.c-types windows.errors windows.ole32 windows.advapi32 alien.libraries ;
IN: windows.ddk.setupapi
-<< "setupapi" "setupapi.dll" "stdcall" add-library >>
+<< "setupapi" "setupapi.dll" stdcall add-library >>
LIBRARY: setupapi
TYPEDEF: DWORDLONG SP_LOG_TOKEN
windows.types alien.libraries ;
IN: windows.ddk.winusb
-<< "winusb" "winusb.dll" "stdcall" add-library >>
+<< "winusb" "winusb.dll" stdcall add-library >>
LIBRARY: winusb
TYPEDEF: PVOID WINUSB_INTERFACE_HANDLE
: full-window-margins ( -- MARGINS )
-1 -1 -1 -1 <MARGINS> ; inline
-<< "dwmapi" "dwmapi.dll" "stdcall" add-library >>
+<< "dwmapi" "dwmapi.dll" stdcall add-library >>
LIBRARY: dwmapi
USING: alien sequences alien.libraries ;
{
- { "advapi32" "advapi32.dll" "stdcall" }
- { "dinput" "dinput8.dll" "stdcall" }
- { "gdi32" "gdi32.dll" "stdcall" }
- { "user32" "user32.dll" "stdcall" }
- { "kernel32" "kernel32.dll" "stdcall" }
- { "winsock" "ws2_32.dll" "stdcall" }
- { "mswsock" "mswsock.dll" "stdcall" }
- { "shell32" "shell32.dll" "stdcall" }
- { "libc" "msvcrt.dll" "cdecl" }
- { "libm" "msvcrt.dll" "cdecl" }
- { "gl" "opengl32.dll" "stdcall" }
- { "glu" "glu32.dll" "stdcall" }
- { "ole32" "ole32.dll" "stdcall" }
- { "usp10" "usp10.dll" "stdcall" }
- { "psapi" "psapi.dll" "stdcall" }
- { "xinput" "xinput1_3.dll" "stdcall" }
- { "dxgi" "dxgi.dll" "stdcall" }
- { "d2d1" "d2d1.dll" "stdcall" }
- { "d3d9" "d3d9.dll" "stdcall" }
- { "d3d10" "d3d10.dll" "stdcall" }
- { "d3d10_1" "d3d10_1.dll" "stdcall" }
- { "d3d11" "d3d11.dll" "stdcall" }
- { "d3dcompiler" "d3dcompiler_42.dll" "stdcall" }
- { "d3dcsx" "d3dcsx_42.dll" "stdcall" }
- { "d3dx9" "d3dx9_42.dll" "stdcall" }
- { "d3dx10" "d3dx10_42.dll" "stdcall" }
- { "d3dx11" "d3dx11_42.dll" "stdcall" }
- { "dwrite" "dwrite.dll" "stdcall" }
- { "x3daudio" "x3daudio1_6.dll" "stdcall" }
- { "xactengine" "xactengine3_5.dll" "stdcall" }
- { "xapofx" "xapofx1_3.dll" "stdcall" }
- { "xaudio2" "xaudio2_5.dll" "stdcall" }
+ { "advapi32" "advapi32.dll" stdcall }
+ { "dinput" "dinput8.dll" stdcall }
+ { "gdi32" "gdi32.dll" stdcall }
+ { "user32" "user32.dll" stdcall }
+ { "kernel32" "kernel32.dll" stdcall }
+ { "winsock" "ws2_32.dll" stdcall }
+ { "mswsock" "mswsock.dll" stdcall }
+ { "shell32" "shell32.dll" stdcall }
+ { "libc" "msvcrt.dll" cdecl }
+ { "libm" "msvcrt.dll" cdecl }
+ { "gl" "opengl32.dll" stdcall }
+ { "glu" "glu32.dll" stdcall }
+ { "ole32" "ole32.dll" stdcall }
+ { "usp10" "usp10.dll" stdcall }
+ { "psapi" "psapi.dll" stdcall }
+ { "xinput" "xinput1_3.dll" stdcall }
+ { "dxgi" "dxgi.dll" stdcall }
+ { "d2d1" "d2d1.dll" stdcall }
+ { "d3d9" "d3d9.dll" stdcall }
+ { "d3d10" "d3d10.dll" stdcall }
+ { "d3d10_1" "d3d10_1.dll" stdcall }
+ { "d3d11" "d3d11.dll" stdcall }
+ { "d3dcompiler" "d3dcompiler_42.dll" stdcall }
+ { "d3dcsx" "d3dcsx_42.dll" stdcall }
+ { "d3dx9" "d3dx9_42.dll" stdcall }
+ { "d3dx10" "d3dx10_42.dll" stdcall }
+ { "d3dx11" "d3dx11_42.dll" stdcall }
+ { "dwrite" "dwrite.dll" stdcall }
+ { "x3daudio" "x3daudio1_6.dll" stdcall }
+ { "xactengine" "xactengine3_5.dll" stdcall }
+ { "xapofx" "xapofx1_3.dll" stdcall }
+ { "xaudio2" "xaudio2_5.dll" stdcall }
} [ first3 add-library ] each
sequences ;
IN: alien
+HELP: cdecl
+{ $description "This symbol is passed as the " { $snippet "abi" } " argument to " { $link alien-indirect } ", " { $link alien-callback } ", " { $link alien-assembly } ", and " { $link add-library } " to indicate that the standard C calling convention should be used, where the caller cleans up the stack frame after calling the function. This symbol only has meaning on 32-bit x86 platforms." } ;
+
+HELP: stdcall
+{ $description "This symbol is passed as the " { $snippet "abi" } " argument to " { $link alien-indirect } ", " { $link alien-callback } ", " { $link alien-assembly } ", and " { $link add-library } " to indicate that the Windows API calling convention should be used, where the called function cleans up its own stack frame before returning to the caller. This symbol only has meaning on 32-bit x86 platforms." } ;
+
+HELP: fastcall
+{ $warning "In the current implementation this ABI only works for functions that take only integer and pointer arguments." }
+{ $description "This symbol is passed as the " { $snippet "abi" } " argument to " { $link alien-indirect } ", " { $link alien-callback } ", " { $link alien-assembly } ", and " { $link add-library } " to indicate that the \"fast call\" calling convention should be used, where the first two integer or pointer arguments are passed in registers and the function cleans up its own stack frame before returning to the caller. This symbol only has meaning on 32-bit x86 platforms." } ;
+
+HELP: thiscall
+{ $description "This symbol is passed as the " { $snippet "abi" } " argument to " { $link alien-indirect } ", " { $link alien-callback } ", " { $link alien-assembly } ", and " { $link add-library } " to indicate that Microsoft Visual C++ calling convention should be used, where the first argument (which must be a \"this\" pointer) is passed in a register and the function cleans up its own stack frame before returning to the caller. This symbol only has meaning on 32-bit x86 platforms." } ;
+
+{ cdecl stdcall fastcall thiscall } related-words
+
HELP: >c-ptr
{ $values { "obj" object } { "c-ptr" c-ptr } }
{ $contract "Outputs a pointer to the binary data of this object." } ;
} ;
HELP: alien-indirect
-{ $values { "args..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "return..." "the return value of the function, if not " { $link void } } }
+{ $values { "args..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}
} ;
HELP: alien-callback
-{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "alien" alien } }
+{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } { "quot" quotation } { "alien" alien } }
{ $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl
"A simple example, showing a C function which returns the difference of two given integers:"
{ $code
": difference-callback ( -- alien )"
- " int { int int } \"cdecl\" [ - ] alien-callback ;"
+ " int { int int } cdecl [ - ] alien-callback ;"
}
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
} ;
HELP: alien-assembly
-{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "return..." "the return value of the function, if not " { $link void } } }
+{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $link cdecl } " or " { $link stdcall } } { "quot" quotation } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes arbitrary machine code, generated at compile-time by the quotation. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}
M: pinned-alien hashcode*
nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+SINGLETONS: stdcall thiscall fastcall cdecl mingw ;
+
+UNION: abi stdcall thiscall fastcall cdecl mingw ;
+
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
- int { int } "cdecl" [\r
+ int { int } cdecl [\r
dup 1 <= [ drop 1 ] [\r
1 - dup fib swap 1 - fib +\r
] if\r
] alien-callback\r
- int { int } "cdecl" alien-indirect ;\r
+ int { int } cdecl alien-indirect ;\r
\r
: fib-main ( -- ) 32 fib drop ;\r
\r
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax classes.struct combinators
-combinators.short-circuit kernel math math.order sequences
-typed specialized-arrays locals system alien.libraries ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax classes.struct combinators combinators.short-circuit
+kernel math math.order sequences typed specialized-arrays locals
+system ;
SPECIALIZED-ARRAY: void*
IN: chipmunk.ffi
{ [ os windows? ] [ "chipmunk.dll" ] }
{ [ os macosx? ] [ "libchipmunk.dylib" ] }
{ [ os unix? ] [ "libchipmunk.so" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
"chipmunk" deploy-library
>>
{ [ os winnt? ] [ "libcurses.dll" ] }
{ [ os macosx? ] [ "libcurses.dylib" ] }
{ [ os unix? ] [ "libcurses.so" ] }
-} cond "cdecl" add-library >>
+} cond cdecl add-library >>
C-TYPE: WINDOW
C-TYPE: SCREEN
! (c)2010 Joe Groff bsd license
-USING: accessors cursors make math sequences sorting tools.test ;
+USING: accessors cursors kernel make math sequences sorting tools.test ;
FROM: cursors => each map assoc-each assoc>map ;
IN: cursors.tests
T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 3 mod zero? ] -find
] unit-test
+[ T{ linear-cursor f 5 1 } ] [
+ T{ linear-cursor f 1 1 } T{ linear-cursor f 5 1 } [ value>> 6 = ] -find
+] unit-test
+
[ { 1 3 } ] [
[ T{ linear-cursor f 1 2 } T{ linear-cursor f 5 2 } [ value>> , ] -each ]
{ } make
IN: freetype
<< "freetype" {
- { [ os macosx? ] [ "/usr/X11R6/lib/libfreetype.6.dylib" "cdecl" add-library ] }
- { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "/usr/X11R6/lib/libfreetype.6.dylib" cdecl add-library ] }
+ { [ os windows? ] [ "freetype6.dll" cdecl add-library ] }
{ [ t ] [ drop ] }
} cond >>
{ [ os windows? ] [ "libusb-1.0.dll" ] }
{ [ os macosx? ] [ "libusb-1.0.dylib" ] }
{ [ os unix? ] [ "libusb-1.0.so" ] }
- } cond "cdecl" add-library >>
+ } cond cdecl add-library >>
LIBRARY: libusb
: libusb_cpu_to_le16 ( x -- y )
{ [ os macosx? ] [ "/usr/local/lib/lib" ".dylib" surround ] }
{ [ os windows? ] [ ".dll" append ] }
{ [ os unix? ] [ "lib" ".so" surround ] }
- } cond "cdecl" add-library ;
+ } cond cdecl add-library ;
"LLVMSystem" add-llvm-library
"LLVMSupport" add-llvm-library
dup name>> function-pointer ,
dup return>> c-type ,
dup params>> [ second c-type ] map ,
- "cdecl" , \ alien-indirect ,
+ cdecl , \ alien-indirect ,
] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
: install-module ( name -- )
{ [ os winnt? ] [ "ogg.dll" ] }
{ [ os macosx? ] [ "libogg.0.dylib" ] }
{ [ os unix? ] [ "libogg.so" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
"ogg" deploy-library
>>
{ [ os winnt? ] [ "theoradec.dll" ] }
{ [ os macosx? ] [ "libtheoradec.0.dylib" ] }
{ [ os unix? ] [ "libtheoradec.so" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
"theoraenc" {
{ [ os winnt? ] [ "theoraenc.dll" ] }
{ [ os macosx? ] [ "libtheoraenc.0.dylib" ] }
{ [ os unix? ] [ "libtheoraenc.so" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
>>
CONSTANT: TH-EFAULT -1
{ [ os winnt? ] [ "vorbis.dll" ] }
{ [ os macosx? ] [ "libvorbis.0.dylib" ] }
{ [ os unix? ] [ "libvorbis.so" ] }
-} cond "cdecl" add-library
+} cond cdecl add-library
"vorbis" deploy-library
>>
"/System/Library/Frameworks/OpenAL.framework/OpenAL"
] }
{ [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
+ } cond cdecl add-library >>
<< os macosx? [ "alut" deploy-library ] unless >>
"/System/Library/Frameworks/OpenAL.framework/OpenAL"
] }
{ [ os unix? ] [ "libopenal.so" ] }
- } cond "cdecl" add-library >>
+ } cond cdecl add-library >>
<< os macosx? [ "openal" deploy-library ] unless >>
{ [ os windows? ] [ "OpenCL.dll" ] }
{ [ os macosx? ] [ "/System/Library/Frameworks/OpenCL.framework/OpenCL" ] }
{ [ os unix? ] [ "libOpenCL.so" ] }
- } cond "stdcall" add-library >>
+ } cond stdcall add-library >>
LIBRARY: opencl
! cl_platform.h
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
- { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
+ { [ dup unix? ] [ drop "glu" "libGLU.so.1" cdecl add-library ] }
} cond
>>
{ [ os macosx? ] [ "/opt/local/lib/libtokyotyrant.dylib" ] }
{ [ os unix? ] [ "libtokyotyrant.so" ] }
{ [ os windows? ] [ "tokyotyrant.dll" ] }
-} cond "cdecl" add-library >>
+} cond cdecl add-library >>
LIBRARY: tokyotyrant
{ [ os macosx? ] [ "/opt/local/lib/libtokyocabinet.dylib" ] }
{ [ os unix? ] [ "libtokyocabinet.so" ] }
{ [ os windows? ] [ "tokyocabinet.dll" ] }
-} cond "cdecl" add-library >>
+} cond cdecl add-library >>
LIBRARY: tokyocabinet
: compile-c-library ( -- )
compile-library? [ compile-library ] when
- c-library get dup library-path "cdecl" add-library ;
+ c-library get dup library-path cdecl add-library ;
: define-c-function ( function types effect body -- )
[
IN: cryptlib.libcl
<< "libcl" {
- { [ win32? ] [ "cl32.dll" "stdcall" ] }
- { [ macosx? ] [ "libcl.dylib" "cdecl" ] }
- { [ unix? ] [ "libcl.so" "cdecl" ] }
+ { [ win32? ] [ "cl32.dll" stdcall ] }
+ { [ macosx? ] [ "libcl.dylib" cdecl ] }
+ { [ unix? ] [ "libcl.so" cdecl ] }
} cond add-library >>
! ===============================================
IN: db.mysql.ffi
<< "mysql" {
- { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
- { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
- { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+ { [ os winnt? ] [ "libmySQL.dll" stdcall ] }
+ { [ os macosx? ] [ "libmysqlclient.14.dylib" cdecl ] }
+ { [ os unix? ] [ "libmysqlclient.so.14" cdecl ] }
} cond add-library >>
LIBRARY: mysql
] when ;
: (destroy-java-vm)
- "int" { "void*" } "cdecl" alien-indirect ;
+ "int" { "void*" } cdecl alien-indirect ;
: (attach-current-thread)
- "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ;
+ "int" { "void*" "void*" "void*" } cdecl alien-indirect ;
: (detach-current-thread)
- "int" { "void*" } "cdecl" alien-indirect ;
+ "int" { "void*" } cdecl alien-indirect ;
: (get-env)
- "int" { "void*" "void*" "int" } "cdecl" alien-indirect ;
+ "int" { "void*" "void*" "int" } cdecl alien-indirect ;
: (attach-current-thread-as-daemon)
- "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ;
+ "int" { "void*" "void*" "void*" } cdecl alien-indirect ;
: destroy-java-vm ( javavm -- int )
dup JavaVM-functions JNIInvokeInterface-DestroyJavaVM (destroy-java-vm) ;
: (get-version)
- "jint" { "JNIEnv*" } "cdecl" alien-indirect ;
+ "jint" { "JNIEnv*" } cdecl alien-indirect ;
: get-version ( jnienv -- int )
dup JNIEnv-functions JNINativeInterface-GetVersion (get-version) ;
: (find-class)
- "void*" { "JNINativeInterface*" "char*" } "cdecl" alien-indirect ;
+ "void*" { "JNINativeInterface*" "char*" } cdecl alien-indirect ;
: find-class ( name jnienv -- int )
dup swapd JNIEnv-functions JNINativeInterface-FindClass (find-class) ;
: (get-static-field-id)
- "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ;
+ "void*" { "JNINativeInterface*" "void*" "char*" "char*" } cdecl alien-indirect ;
: get-static-field-id ( class name sig jnienv -- int )
dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetStaticFieldID (get-static-field-id) ;
: (get-static-object-field)
- "void*" { "JNINativeInterface*" "void*" "void*" } "cdecl" alien-indirect ;
+ "void*" { "JNINativeInterface*" "void*" "void*" } cdecl alien-indirect ;
: get-static-object-field ( class id jnienv -- int )
dup >r >r 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-GetStaticObjectField (get-static-object-field) ;
: (get-method-id)
- "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ;
+ "void*" { "JNINativeInterface*" "void*" "char*" "char*" } cdecl alien-indirect ;
: get-method-id ( class name sig jnienv -- int )
dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetMethodID (get-method-id) ;
: (new-string)
- "void*" { "JNINativeInterface*" "char*" "int" } "cdecl" alien-indirect ;
+ "void*" { "JNINativeInterface*" "char*" "int" } cdecl alien-indirect ;
: new-string ( str jnienv -- str )
dup >r >r dup length 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-NewString (new-string) ;
: (call1)
- "void" { "JNINativeInterface*" "void*" "void*" "int" } "cdecl" alien-indirect ;
+ "void" { "JNINativeInterface*" "void*" "void*" "int" } cdecl alien-indirect ;
: call1 ( obj method-id jstr jnienv -- )
dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-CallObjectMethod (call1) ;
IN: ldap.libldap
<< "libldap" {
- { [ win32? ] [ "libldap.dll" "stdcall" ] }
- { [ macosx? ] [ "libldap.dylib" "cdecl" ] }
- { [ unix? ] [ "libldap.so" "cdecl" ] }
+ { [ win32? ] [ "libldap.dll" stdcall ] }
+ { [ macosx? ] [ "libldap.dylib" cdecl ] }
+ { [ unix? ] [ "libldap.so" cdecl ] }
} cond add-library >>
: LDAP_VERSION1 1 ; inline
[ t ] [ f ]
[ { } ]
[ drop f ]
- [ "cdecl" ]
+ [ cdecl ]
[ first ] [ second ] [ third ] [ fourth ]
[ ">" write ] [ "/>" write ]
} ;
words math threads io.encodings.ascii ;
IN: odbc
-<< "odbc" "odbc32.dll" "stdcall" add-library >>
+<< "odbc" "odbc32.dll" stdcall add-library >>
LIBRARY: odbc
IN: oracle.liboci
"oci" {
- { [ os winnt? ] [ "oci.dll" "stdcall" ] }
- { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
- { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
+ { [ os winnt? ] [ "oci.dll" stdcall ] }
+ { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" cdecl ] }
+ { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" cdecl ] }
} cond add-library
! ===============================================
IN: pdf.libhpdf
<< "libhpdf" {
- { [ win32? ] [ "libhpdf.dll" "stdcall" ] }
- { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
+ { [ win32? ] [ "libhpdf.dll" stdcall ] }
+ { [ macosx? ] [ "libhpdf.dylib" cdecl ] }
+ { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" cdecl ] }
} cond add-library >>
! compression mode
p->datastack_size = 32 * sizeof(cell);
p->retainstack_size = 32 * sizeof(cell);
-#ifdef FACTOR_PPC
+#if defined(__OpenBSD__) && defined(FACTOR_X86)
+ p->callstack_size = 64 * sizeof(cell);
+#elif defined(FACTOR_PPC)
p->callstack_size = 256 * sizeof(cell);
#else
p->callstack_size = 128 * sizeof(cell);
}
#endif
+
+FACTOR_FASTCALL(int) ffi_test_49(int x) { return x + 1; }
+FACTOR_FASTCALL(int) ffi_test_50(int x, int y) { return x + y + 1; }
+FACTOR_FASTCALL(int) ffi_test_51(int x, int y, int z) { return x + y + z + 1; }
+FACTOR_FASTCALL(int) ffi_test_52(int x, float y, int z) { return x + y + z + 1; }
+FACTOR_FASTCALL(int) ffi_test_53(int x, float y, int z, int w)
+{
+ return x + y + z + w + 1;
+}
+
+FACTOR_FASTCALL(int) ffi_test_54(struct test_struct_11 x, int y)
+{
+ return x.x + x.y + y + 1;
+}
+
+FACTOR_FASTCALL(int) ffi_test_55(struct test_struct_11 x, int y, int z)
+{
+ return x.x + x.y + y + z + 1;
+}
+
+FACTOR_FASTCALL(int) ffi_test_56(struct test_struct_11 x, int y, int z, int w)
+{
+ return x.x + x.y + y + z + w + 1;
+}
+
+FACTOR_FASTCALL(struct test_struct_11) ffi_test_57(int x, int y)
+{
+ struct test_struct_11 r = { x + y, x - y };
+ return r;
+}
+
+FACTOR_FASTCALL(struct test_struct_11) ffi_test_58(int x, int y, int z)
+{
+ struct test_struct_11 r = { x + y, y - z };
+ return r;
+}
#if defined(_MSC_VER)
#define FACTOR_STDCALL(return_type) return_type __stdcall
+ #define FACTOR_FASTCALL(return_type) return_type __fastcall
#elif defined(i386) || defined(__i386) || defined(__i386__)
#define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type
+ #define FACTOR_FASTCALL(return_type) __attribute__((fastcall)) return_type
#else
#define FACTOR_STDCALL(return_type) return_type
+ #define FACTOR_FASTCALL(return_type) return_type
#endif
#if defined(__APPLE__)
FACTOR_EXPORT short ffi_test_48(struct bool_field_test x);
#endif
+
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_49(int x);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_50(int x, int y);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_51(int x, int y, int z);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_52(int x, float y, int z);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_53(int x, float y, int z, int w);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_54(struct test_struct_11 x, int y);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_55(struct test_struct_11 x, int y, int z);
+FACTOR_EXPORT FACTOR_FASTCALL(int) ffi_test_56(struct test_struct_11 x, int y, int z, int w);
+FACTOR_EXPORT FACTOR_FASTCALL(struct test_struct_11) ffi_test_57(int x, int y);
+FACTOR_EXPORT FACTOR_FASTCALL(struct test_struct_11) ffi_test_58(int x, int y, int z);
projects / factor.git / commitdiff