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

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 ;
 

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

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 ;

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
+USING: accessors arrays alien alien.c-types alien.arrays
-alien.arrays alien.strings kernel math namespaces parser
+alien.strings kernel math namespaces parser sequences words
-sequences words quotations math.parser splitting grouping
+quotations math.parser splitting grouping effects assocs
-effects assocs combinators lexer strings.parser alien.parser 
+combinators lexer strings.parser alien.parser fry vocabs.parser
-fry vocabs.parser words.constant alien.libraries ;
+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! ;
+    scan current-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 ;
 
 SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ;
 

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 ;
 

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
+! GCC bugs
-[ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
+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
+[ 8 ] [
-[ 13 ] [ 3 4 5 &: ffi_test_51 fastcall-iii-indirect ] unit-test
+    3 4
-[ 13 ] [ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect ] unit-test
+    os windows? [ &: @ffi_test_50@8 ] [ &: ffi_test_50 ] if
-[ 19 ] [ 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect ] unit-test
+    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 } ]

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

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 )

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_49(int x)
-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; }
+	return x + 1;
-FACTOR_FASTCALL(int) ffi_test_52(int x, float y, int z) { return x + y + z + 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)