diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor old mode 100644 new mode 100755 index 8c74aa102a..9f44dec80a --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -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 ; diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor old mode 100644 new mode 100755 index 5a042fd436..86249436aa --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -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 diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor old mode 100644 new mode 100755 index 0891caa04a..7b677c3581 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -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 ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor old mode 100644 new mode 100755 index 00148a82d4..bc7e590cff --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -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 suffix! ; SYNTAX: 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 ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index ffccf9f118..b16f471d11 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 8735d7cae4..279c6ef39f 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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 ] alien-callback ; + : fastcall-struct-return-iii-callback ( -- ptr ) test-struct-11 { int int int } fastcall [ [ drop + ] [ - nip ] 3bi test-struct-11 ] 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 } ] diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 40c6bd40db..05c627fb99 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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 diff --git a/core/alien/alien.factor b/core/alien/alien.factor old mode 100644 new mode 100755 index 27e326a557..d67e0a12b9 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -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 ) diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 993ca18fa3..7d9abe2f87 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -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)