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

Merge branch 'master' of git://factorcode.org/git/factor

release
Joe Groff 2010-04-12 16:17:12 -07:00
parent a83090edba 918b202b9a
commit 88ae5425c1
9 changed files with 123 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/fortran/fortran.factor Normal file → Executable file
View File

@ -434,15 +434,15 @@ MACRO: fortran-invoke ( return library function parameters -- )
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
f current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
scan current-library get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ;
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ current-library set ]
[ set-fortran-abi ] bi ;

5
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

@ -38,6 +38,11 @@ M: library dispose dll>> [ dispose ] when* ;
: library-abi ( library -- abi )
library [ abi>> ] [ cdecl ] if* ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYMBOL: deploy-libraries
deploy-libraries [ V{ } clone ] initialize

13
basis/alien/parser/parser.factor Normal file → Executable file
View File

@ -7,6 +7,8 @@ splitting words fry locals lexer namespaces summary math
vocabs.parser words.constant ;
IN: alien.parser
SYMBOL: current-library
: parse-c-type-name ( name -- word )
dup search [ ] [ no-word ] ?if ;
@ -117,7 +119,7 @@ PRIVATE>
names return function-effect ;
: (FUNCTION:) ( -- word quot effect )
scan-function-name "c-library" get ";" scan-c-args make-function ;
scan-function-name current-library get ";" scan-c-args make-function ;
: callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ;
@ -131,7 +133,7 @@ PRIVATE>
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
current-library get
scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
@ -142,3 +144,10 @@ PREDICATE: alien-function-word < word
PREDICATE: alien-callback-type-word < typedef-word
"callback-effect" word-prop ;
: global-quot ( type word -- quot )
name>> current-library get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

26
basis/alien/syntax/syntax.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser words.constant alien.libraries ;
USING: accessors arrays alien alien.c-types alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects assocs
combinators lexer strings.parser alien.parser fry vocabs.parser
words.constant alien.libraries ;
IN: alien.syntax
SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
@ -13,7 +13,7 @@ SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: LIBRARY: scan current-library set ;
SYNTAX: FUNCTION:
(FUNCTION:) define-declared ;
@ -33,20 +33,8 @@ SYNTAX: C-ENUM:
SYNTAX: C-TYPE:
void CREATE-C-TYPE typedef ;
ERROR: no-such-symbol name library ;
: address-of ( name library -- value )
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] append! ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
swap c-type-getter-boxer append ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
scan current-library get '[ _ _ address-of ] append! ;
SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;

14
basis/compiler/codegen/codegen.factor
View File

@ -18,6 +18,7 @@ compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
FROM: namespaces => set ;
FROM: compiler.errors => no-such-symbol ;
IN: compiler.codegen
SYMBOL: insn-counts
@ -415,13 +416,18 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
dll-path compiling-word get no-such-library drop
] if ;
: stdcall-mangle ( params -- symbols )
: decorated-symbol ( params -- symbols )
[ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
[ drop ] [ "@" glue ] [ "@" glue "_" prepend ] 2tri
3array ;
{
[ drop ]
[ "@" glue ]
[ "@" glue "_" prepend ]
[ "@" glue "@" prepend ]
} 2cleave
4array ;
: alien-invoke-dlsym ( params -- symbols dll )
[ dup abi>> stdcall = [ stdcall-mangle ] [ function>> ] if ]
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;

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

@ -20,7 +20,9 @@ IN: compiler.tests.alien
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
"f-cdecl" libfactor-ffi-tests-path cdecl add-library
: mingw? ( -- ? ) os windows? vm-compiler "GCC" head? and ;
"f-cdecl" libfactor-ffi-tests-path mingw? mingw cdecl ? add-library
"f-stdcall" libfactor-ffi-tests-path stdcall add-library
@ -653,55 +655,103 @@ FUNCTION: void this_does_not_exist ( ) ;
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
! GCC bugs
mingw? [
[ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
[ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
] unless
[ 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
[ 8 ] [
3 4
os windows? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
fastcall-ii-indirect
] unit-test
[ 13 ] [
3 4 5
os windows? [ &: @ffi_test_51@12 ] [ &: ffi_test_51 ] if
fastcall-iii-indirect
] unit-test
mingw? [
[ 13 ] [
3 4.0 5
os windows? [ &: @ffi_test_52@12 ] [ &: ffi_test_52 ] if
fastcall-ifi-indirect
] unit-test
[ 19 ] [
3 4.0 5 6
os windows? [ &: @ffi_test_53@16 ] [ &: ffi_test_53 ] if
fastcall-ifii-indirect
] unit-test
] unless
[ S{ test-struct-11 f 7 -1 } ]
[ 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect ] unit-test
[
3 4
os windows? [ &: @ffi_test_57@8 ] [ &: ffi_test_57 ] if
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
[
3 4 7
os windows? [ &: @ffi_test_58@12 ] [ &: ffi_test_58 ] if
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
basis/cpu/x86/32/32.factor
View File

@ -315,9 +315,6 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
[ abi>> mingw = os windows? not or ]
bi and ;
: callee-cleanup? ( abi -- ? )
{ stdcall fastcall thiscall } member? ;
: stack-arg-size ( params -- n )
dup abi>> '[
alien-parameters flatten-value-types

3
core/alien/alien.factor Normal file → Executable file
View File

@ -68,6 +68,9 @@ SINGLETONS: stdcall thiscall fastcall cdecl mingw ;
UNION: abi stdcall thiscall fastcall cdecl mingw ;
: callee-cleanup? ( abi -- ? )
{ stdcall fastcall thiscall } member? ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )

34
vm/ffi_test.c
View File

@ -56,7 +56,7 @@ int ffi_test_9(int a, int b, int c, int d, int e, int f, int g)
int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h)
{
return a - b - c - d - e - f - g - h;
return (int)(a - b - c - d - e - f - g - h);
}
int ffi_test_11(int a, struct foo b, int c)
@ -66,7 +66,7 @@ int ffi_test_11(int a, struct foo b, int c)
int ffi_test_12(int a, int b, struct rect c, int d, int e, int f)
{
return a + b + c.x + c.y + c.w + c.h + d + e + f;
return (int)(a + b + c.x + c.y + c.w + c.h + d + e + f);
}
int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k)
@ -128,7 +128,7 @@ long long ffi_test_21(long x, long y)
long ffi_test_22(long x, long long y, long long z)
{
return x + y / z;
return (long)(x + y / z);
}
float ffi_test_23(float x[3], float y[3])
@ -262,7 +262,7 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
int ffi_test_39(long a, long b, struct test_struct_13 s)
{
assert(a == b);
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
return (int)(s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6);
}
struct test_struct_14 ffi_test_40(double x1, double x2)
@ -330,13 +330,29 @@ short ffi_test_48(struct bool_field_test x)
#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_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 (int)(x + y + z + 1);
}
FACTOR_FASTCALL(int) ffi_test_53(int x, float y, int z, int w)
{
return x + y + z + w + 1;
return (int)(x + y + z + w + 1);
}
FACTOR_FASTCALL(int) ffi_test_54(struct test_struct_11 x, int y)