steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

alien.*: frontend varargs support! #1677 

alien-invoke gets an extra parameter indicating if the call uses varargs
or not. In 99.9% of the cases, the parameter should be f, but is t if
varargs are indicated. E.g

: do-printf ( fmt d -- st ) int f "printf" { c-string double } t alien-invoke ;
char-rename
Björn Lindqvist 2016-08-10 01:18:52 +02:00
parent 7ab3ebfdd5
commit ddc5ece757
14 changed files with 61 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/c-types/c-types-docs.factor
View File

@ -87,7 +87,7 @@ $nl
"In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:" "In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, pointer types can be created by suffixing " { $snippet "*" } " to a C type name. Outside of FFI definitions, a pointer C type can be created using the " { $link POSTPONE: pointer: } " syntax word:"
{ $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" } { $unchecked-example "FUNCTION: int* foo ( char* bar ) ;" }
{ $unchecked-example ": foo ( bar -- int* ) { $unchecked-example ": foo ( bar -- int* )
pointer: int f \"foo\" { pointer: char } alien-invoke ;" } } ; pointer: int f \"foo\" { pointer: char } f alien-invoke ;" } } ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."

2
basis/alien/libraries/unix/unix.factor
View File

@ -3,7 +3,7 @@ io.pathnames system ;
IN: alien.libraries.unix IN: alien.libraries.unix
: (dlerror) ( -- string ) : (dlerror) ( -- string )
\ c-string f "dlerror" { } alien-invoke ; inline \ c-string f "dlerror" { } f alien-invoke ; inline
M: unix dlerror (dlerror) ; M: unix dlerror (dlerror) ;

14
basis/alien/parser/parser.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff. ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.enums alien.libraries USING: accessors alien alien.c-types alien.enums alien.libraries
arrays classes classes.parser combinators arrays classes classes.parser combinators combinators.short-circuit
combinators.short-circuit compiler.units effects fry kernel compiler.units effects fry kernel lexer locals math namespaces parser
lexer locals math namespaces parser sequences splitting sequences splitting vocabs.parser words ;
vocabs.parser words ;
IN: alien.parser IN: alien.parser
SYMBOL: current-library SYMBOL: current-library
@ -122,9 +121,6 @@ PRIVATE>
scan-token scan-token
] until drop types names [ >array ] bi@ ; ] until drop types names [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
: function-effect ( names return -- effect ) : function-effect ( names return -- effect )
[ { } ] [ return-type-name 1array ] if-void <effect> ; [ { } ] [ return-type-name 1array ] if-void <effect> ;
@ -132,7 +128,7 @@ PRIVATE>
create-word-in dup reset-generic ; create-word-in dup reset-generic ;
:: (make-function) ( return function library types names -- quot effect ) :: (make-function) ( return function library types names -- quot effect )
return library function types function-quot return library function types '[ _ _ _ _ f alien-invoke ]
names return function-effect ; names return function-effect ;
:: make-function ( return function library types names -- word quot effect ) :: make-function ( return function library types names -- word quot effect )
@ -157,7 +153,7 @@ PRIVATE>
PREDICATE: alien-function-alias-word < word PREDICATE: alien-function-alias-word < word
def>> { def>> {
[ length 5 = ] [ length 6 = ]
[ last \ alien-invoke eq? ] [ last \ alien-invoke eq? ]
} 1&& ; } 1&& ;

2
basis/cocoa/messages/messages.factor
View File

@ -12,7 +12,7 @@ IN: cocoa.messages
SPECIALIZED-ARRAY: void* SPECIALIZED-ARRAY: void*
: make-sender ( signature function -- quot ) : make-sender ( signature function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ; [ over first , f , , second , f , \ alien-invoke , ] [ ] make ;
: sender-stub-name ( signature -- str ) : sender-stub-name ( signature -- str )
first2 [ name>> ] [ first2 [ name>> ] [

2
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -77,7 +77,7 @@ IN: compiler.cfg.builder.tests
[ [ t ] loop ] [ [ t ] loop ]
[ [ dup ] loop ] [ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ] [ [ 2 ] [ 3 throw ] if 4 ]
[ int f "malloc" { int } alien-invoke ] [ int f "malloc" { int } f alien-invoke ]
[ int { int } cdecl alien-indirect ] [ int { int } cdecl alien-indirect ]
[ int { int } cdecl [ ] alien-callback ] [ int { int } cdecl [ ] alien-callback ]
[ swap - + * ] [ swap - + * ]

32
basis/compiler/tests/alien.factor
View File

@ -136,13 +136,13 @@ unit-test
[ stdcall ] [ "f-stdcall" lookup-library abi>> ] unit-test [ stdcall ] [ "f-stdcall" lookup-library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int ) : ffi_test_18 ( w x y z -- int )
int "f-stdcall" "ffi_test_18" { int int int int } int "f-stdcall" "ffi_test_18" { int int int int } f
alien-invoke gc ; alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test [ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- BAR ) : ffi_test_19 ( x y z -- BAR )
BAR "f-stdcall" "ffi_test_19" { long long long } BAR "f-stdcall" "ffi_test_19" { long long long } f
alien-invoke gc ; alien-invoke gc ;
[ 11 6 -7 ] [ [ 11 6 -7 ] [
@ -150,9 +150,9 @@ unit-test
] unit-test ] unit-test
: multi_ffi_test_18 ( w x y z w' x' y' z' -- int int ) : 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 ] [ int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke ]
4 ndip 4 ndip
int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke int "f-stdcall" "ffi_test_18" { int int int int } f alien-invoke
gc ; gc ;
[ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test [ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
@ -181,7 +181,7 @@ FUNCTION: void ffi_test_20 ( double x1, double x2, double x3,
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y ) : ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
int int
"f-cdecl" "ffi_test_31" "f-cdecl" "ffi_test_31"
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int } { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int } f
alien-invoke gc 3 ; alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test [ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
@ -189,7 +189,7 @@ FUNCTION: void ffi_test_20 ( double x1, double x2, double x3,
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result ) : ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
float float
"f-cdecl" "ffi_test_31_point_5" "f-cdecl" "ffi_test_31_point_5"
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float } { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float } f
alien-invoke ; alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test [ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
@ -646,18 +646,18 @@ os windows? [
[ fastcall ] [ "f-fastcall" lookup-library abi>> ] unit-test [ fastcall ] [ "f-fastcall" lookup-library abi>> ] unit-test
: ffi_test_49 ( x -- int ) : ffi_test_49 ( x -- int )
int "f-fastcall" "ffi_test_49" { int } int "f-fastcall" "ffi_test_49" { int } f
alien-invoke gc ; alien-invoke gc ;
: ffi_test_50 ( x y -- int ) : ffi_test_50 ( x y -- int )
int "f-fastcall" "ffi_test_50" { int int } int "f-fastcall" "ffi_test_50" { int int } f
alien-invoke gc ; alien-invoke gc ;
: ffi_test_51 ( x y z -- int ) : ffi_test_51 ( x y z -- int )
int "f-fastcall" "ffi_test_51" { int int int } int "f-fastcall" "ffi_test_51" { int int int } f
alien-invoke gc ; alien-invoke gc ;
: multi_ffi_test_51 ( x y z x' y' z' -- int int ) : multi_ffi_test_51 ( x y z x' y' z' -- int int )
[ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ] [ int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke ]
3dip 3dip
int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ; int "f-fastcall" "ffi_test_51" { int int int } f alien-invoke gc ;
[ 4 ] [ 3 ffi_test_49 ] unit-test [ 4 ] [ 3 ffi_test_49 ] unit-test
[ 8 ] [ 3 4 ffi_test_50 ] unit-test [ 8 ] [ 3 4 ffi_test_50 ] unit-test
@ -665,16 +665,16 @@ os windows? [
[ 13 22 ] [ 3 4 5 6 7 8 multi_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 ) : ffi_test_52 ( x y z -- int )
int "f-fastcall" "ffi_test_52" { int float int } int "f-fastcall" "ffi_test_52" { int float int } f
alien-invoke gc ; alien-invoke gc ;
: ffi_test_53 ( x y z w -- int ) : ffi_test_53 ( x y z w -- int )
int "f-fastcall" "ffi_test_53" { int float int int } int "f-fastcall" "ffi_test_53" { int float int int } f
alien-invoke gc ; alien-invoke gc ;
: ffi_test_57 ( x y -- test-struct-11 ) : ffi_test_57 ( x y -- test-struct-11 )
test-struct-11 "f-fastcall" "ffi_test_57" { int int } test-struct-11 "f-fastcall" "ffi_test_57" { int int } f
alien-invoke gc ; alien-invoke gc ;
: ffi_test_58 ( x y z -- test-struct-11 ) : ffi_test_58 ( x y z -- test-struct-11 )
test-struct-11 "f-fastcall" "ffi_test_58" { int int int } test-struct-11 "f-fastcall" "ffi_test_58" { int int int } f
alien-invoke gc ; alien-invoke gc ;
! Make sure that large longlong/ulonglong are correctly dealt with ! Make sure that large longlong/ulonglong are correctly dealt with
@ -938,7 +938,7 @@ FUNCTION: void* bug1021_test_1 ( void* s, int x )
FUNCTION-ALIAS: do-sum-ints2 int ffi_test_64 ( int n, int a, int b ) FUNCTION-ALIAS: do-sum-ints2 int ffi_test_64 ( int n, int a, int b )
FUNCTION-ALIAS: do-sum-ints3 int ffi_test_64 ( int n, int a, int b, int c ) FUNCTION-ALIAS: do-sum-ints3 int ffi_test_64 ( int n, int a, int b, int c )
{ 30 60 } [ { 30 60 } [
2 10 20 do-sum-ints2 2 10 20 do-sum-ints2
3 10 20 30 do-sum-ints3 3 10 20 30 do-sum-ints3
] unit-test ] unit-test

8
basis/compiler/tests/codegen.factor
View File

@ -257,8 +257,8 @@ TUPLE: id obj ;
{ float } declare dup 0 = { float } declare dup 0 =
[ drop 1 ] [ [ drop 1 ] [
dup 0 >= dup 0 >=
[ 2 double "libm" "pow" { double double } alien-invoke ] [ 2 double "libm" "pow" { double double } f alien-invoke ]
[ -0.5 double "libm" "pow" { double double } alien-invoke ] [ -0.5 double "libm" "pow" { double double } f alien-invoke ]
if if
] if ; ] if ;
@ -476,8 +476,8 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
: gc-root-messup ( a -- b ) : gc-root-messup ( a -- b )
dup [ dup [
1024 (byte-array) 2array 1024 (byte-array) 2array
10 void* "libc" "malloc" { ulong } alien-invoke 10 void* "libc" "malloc" { ulong } f alien-invoke
void "libc" "free" { void* } alien-invoke void "libc" "free" { void* } f alien-invoke
] when ; ] when ;
[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test [ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test

20
basis/stack-checker/alien/alien.factor
View File

@ -41,27 +41,31 @@ TUPLE: alien-callback-params < alien-node-params
: infer-return ( params -- ) : infer-return ( params -- )
return-prep-quot infer-quot-here ; return-prep-quot infer-quot-here ;
: pop-return ( params -- params ) : pop-abi ( params -- params )
pop-literal [ add-depends-on-c-type ] [ >>return ] bi ; pop-literal >>abi ;
: pop-library ( params -- params )
pop-literal >>library ;
: pop-function ( params -- params ) : pop-function ( params -- params )
pop-literal >>function ; pop-literal >>function ;
: pop-library ( params -- params )
pop-literal >>library ;
: pop-params ( params -- params ) : pop-params ( params -- params )
pop-literal [ [ add-depends-on-c-type ] each ] [ >>parameters ] bi ; pop-literal [ [ add-depends-on-c-type ] each ] [ >>parameters ] bi ;
: pop-abi ( params -- params )
pop-literal >>abi ;
: pop-quot ( params -- params ) : pop-quot ( params -- params )
pop-literal >>quot ; pop-literal >>quot ;
: pop-return ( params -- params )
pop-literal [ add-depends-on-c-type ] [ >>return ] bi ;
: pop-varargs? ( params -- params )
pop-literal >>varargs? ;
: infer-alien-invoke ( -- ) : infer-alien-invoke ( -- )
alien-invoke-params new alien-invoke-params new
! Compile-time parameters ! Compile-time parameters
pop-varargs?
pop-params pop-params
pop-function pop-function
pop-library pop-library

6
basis/ui/backend/cocoa/views/views.factor
View File

@ -170,10 +170,10 @@ CLASS: FactorView < NSOpenGLView
-> respondsToSelector: c-bool> [ -> respondsToSelector: c-bool> [
self SEL: setWantsBestResolutionOpenGLSurface: 1 self SEL: setWantsBestResolutionOpenGLSurface: 1
void f "objc_msgSend" { id SEL char } alien-invoke void f "objc_msgSend" { id SEL char } f alien-invoke
self SEL: backingScaleFactor self SEL: backingScaleFactor
double f "objc_msgSend" { id SEL } alien-invoke double f "objc_msgSend" { id SEL } f alien-invoke
dup 1.0 > [ dup 1.0 > [
gl-scale-factor set-global t retina? set-global gl-scale-factor set-global t retina? set-global
@ -416,7 +416,7 @@ CLASS: FactorWindowDelegate < NSObject
-> respondsToSelector: c-bool> [ -> respondsToSelector: c-bool> [
SEL: backingScaleFactor SEL: backingScaleFactor
double f "objc_msgSend" { id SEL } alien-invoke double f "objc_msgSend" { id SEL } f alien-invoke
[ [ 1.0 > ] keep f ? gl-scale-factor set-global ] [ [ 1.0 > ] keep f ? gl-scale-factor set-global ]
[ 1.0 > retina? set-global ] bi [ 1.0 > retina? set-global ] bi

2
core/alien/alien-tests.factor
View File

@ -125,4 +125,4 @@ SYMBOL: foo
] unit-test ] unit-test
[ void { } cdecl [ ] alien-assembly ] [ callsite-not-compiled? ] must-fail-with [ void { } cdecl [ ] alien-assembly ] [ callsite-not-compiled? ] must-fail-with
[ void f "flor" { } alien-invoke ] [ callsite-not-compiled? ] must-fail-with [ void f "flor" { } f alien-invoke ] [ callsite-not-compiled? ] must-fail-with

2
core/alien/alien.factor
View File

@ -94,7 +94,7 @@ ERROR: callsite-not-compiled word ;
: alien-indirect ( args... funcptr return parameters abi -- return... ) : alien-indirect ( args... funcptr return parameters abi -- return... )
\ alien-indirect callsite-not-compiled ; \ alien-indirect callsite-not-compiled ;
: alien-invoke ( args... return library function parameters -- return... ) : alien-invoke ( args... return library function parameters varargs? -- return... )
\ alien-invoke callsite-not-compiled ; \ alien-invoke callsite-not-compiled ;
<PRIVATE <PRIVATE

10
extra/alien/fortran/fortran-tests.factor
View File

@ -202,7 +202,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke] ! [fortran-invoke]
[ [
c:void "funpack" "funtimes_" c:void "funpack" "funtimes_"
{ pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long } { pointer: { c:char 12 } pointer: c:longlong pointer: c:float pointer: complex-float pointer: c:short c:long } f
alien-invoke alien-invoke
] 6 nkeep ] 6 nkeep
! [fortran-results>] ! [fortran-results>]
@ -227,7 +227,7 @@ intel-unix-abi fortran-abi [
[ { [ drop ] } spread ] [ { [ drop ] } spread ]
} 1 ncleave } 1 ncleave
! [fortran-invoke] ! [fortran-invoke]
[ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } alien-invoke ] [ c:float "funpack" "fun_times_" { pointer: { c:float 0 } } f alien-invoke ]
1 nkeep 1 nkeep
! [fortran-results>] ! [fortran-results>]
shuffle( reta aa -- reta aa ) shuffle( reta aa -- reta aa )
@ -245,7 +245,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke] ! [fortran-invoke]
[ [
c:void "funpack" "fun_times_" c:void "funpack" "fun_times_"
{ pointer: complex-float pointer: { c:float 0 } } { pointer: complex-float pointer: { c:float 0 } } f
alien-invoke alien-invoke
] 2 nkeep ] 2 nkeep
! [fortran-results>] ! [fortran-results>]
@ -262,7 +262,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke] ! [fortran-invoke]
[ [
c:void "funpack" "fun_times_" c:void "funpack" "fun_times_"
{ pointer: { c:char 20 } long } { pointer: { c:char 20 } long } f
alien-invoke alien-invoke
] 2 nkeep ] 2 nkeep
! [fortran-results>] ! [fortran-results>]
@ -288,7 +288,7 @@ intel-unix-abi fortran-abi [
! [fortran-invoke] ! [fortran-invoke]
[ [
c:void "funpack" "fun_times_" c:void "funpack" "fun_times_"
{ pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long } { pointer: { c:char 10 } long pointer: { c:char 20 } pointer: c:float pointer: { c:char 30 } c:long c:long } f
alien-invoke alien-invoke
] 7 nkeep ] 7 nkeep
! [fortran-results>] ! [fortran-results>]

4
extra/alien/fortran/fortran.factor
View File

@ -329,8 +329,8 @@ M: character-type (<fortran-result>)
return parameters fortran-sig>c-sig :> ( c-return c-parameters ) return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function function fortran-name>symbol-name :> c-function
[args>args] [args>args]
c-return library c-function c-parameters \ alien-invoke c-return library c-function c-parameters f \ alien-invoke
5 [ ] nsequence 6 [ ] nsequence
c-parameters length \ nkeep c-parameters length \ nkeep
[ ] 3sequence ; [ ] 3sequence ;

16
extra/fjsc/resources/bootstrap.factor
View File

@ -7,14 +7,14 @@ USE: kernel-internals
: elements ( string -- result ) : elements ( string -- result )
! Call JQuery's $ function ! Call JQuery's $ function
window { "result" } "" "$" { "string" } alien-invoke ; window { "result" } "" "$" { "string" } f alien-invoke ;
: html ( string -- element ) : html ( string -- element )
! Set the innerHTML of element using jQuery ! Set the innerHTML of element using jQuery
{ } "" "html" { "string" } alien-invoke ; { } "" "html" { "string" } f alien-invoke ;
: bind-event ( name element quot -- ) : bind-event ( name element quot -- )
>function swap { } "" "with-variables" { "string" "function" } alien-invoke ; >function swap { } "" "with-variables" { "string" "function" } f alien-invoke ;
"scratchpad" set-in "scratchpad" set-in
@ -31,9 +31,9 @@ USE: kernel-internals
"Waiting for click on button" alert "Waiting for click on button" alert
continue continue
] callcc0 ] callcc0
drop "Click done!" alert drop "Click done!" alert
] callcc0 ; ] callcc0 ;
: alert ( string -- ) : alert ( string -- )
! Display the string in an alert box ! Display the string in an alert box
window { } "" "alert" { "string" } alien-invoke ; window { } "" "alert" { "string" } f alien-invoke ;