diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 040e4ef4c3..d5509ce205 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,9 +1,6 @@ + allot refactoring: - inline float allocation needs a gc check -- fix alien invoke as required - - we can just convert strings to aliens beforehand - - >float first too - docs: don't pass volatile aliens to callbacks + ui: diff --git a/library/compiler/alien/alien-invoke.factor b/library/compiler/alien/alien-invoke.factor index d61092b335..9262158564 100644 --- a/library/compiler/alien/alien-invoke.factor +++ b/library/compiler/alien/alien-invoke.factor @@ -28,16 +28,32 @@ M: alien-invoke-error summary [ alien-invoke-dlsym dlsym drop ] [ inference-warning ] recover ; +: (make-prep-quot) ( parameters -- ) + dup empty? [ + drop + ] [ + unclip c-type c-type-prep % + \ >r , (make-prep-quot) \ r> , + ] if ; + +: make-prep-quot ( parameters -- quot ) + [ (make-prep-quot) ] [ ] make ; + +: prep-alien-invoke ( node -- ) + alien-invoke-parameters make-prep-quot infer-quot ; + \ alien-invoke [ string object string object ] [ ] "infer-effect" set-word-prop \ alien-invoke [ - empty-node dup node, + empty-node pop-literal nip over set-alien-invoke-parameters pop-literal nip over set-alien-invoke-function pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return + dup prep-alien-invoke dup ensure-dlsym + dup node, alien-invoke-stack ] "infer" set-word-prop diff --git a/library/compiler/alien/primitive-types.factor b/library/compiler/alien/primitive-types.factor index 99bb020db2..db2defb69e 100644 --- a/library/compiler/alien/primitive-types.factor +++ b/library/compiler/alien/primitive-types.factor @@ -7,7 +7,6 @@ bootstrap-cell "unbox_alien" "void*" define-primitive-type - [ alien-signed-8 ] [ set-alien-signed-8 ] 8 @@ -15,7 +14,6 @@ bootstrap-cell "unbox_signed_8" "longlong" define-primitive-type - [ alien-unsigned-8 ] [ set-alien-unsigned-8 ] 8 @@ -23,7 +21,6 @@ bootstrap-cell "unbox_unsigned_8" "ulonglong" define-primitive-type - [ alien-signed-cell ] [ set-alien-signed-cell ] bootstrap-cell @@ -31,7 +28,6 @@ bootstrap-cell "unbox_signed_cell" "long" define-primitive-type - [ alien-unsigned-cell ] [ set-alien-unsigned-cell ] bootstrap-cell @@ -39,7 +35,6 @@ bootstrap-cell "unbox_unsigned_cell" "ulong" define-primitive-type - [ alien-signed-4 ] [ set-alien-signed-4 ] 4 @@ -47,7 +42,6 @@ bootstrap-cell "unbox_signed_4" "int" define-primitive-type - [ alien-unsigned-4 ] [ set-alien-unsigned-4 ] 4 @@ -55,7 +49,6 @@ bootstrap-cell "unbox_unsigned_4" "uint" define-primitive-type - [ alien-signed-2 ] [ set-alien-signed-2 ] 2 @@ -63,7 +56,6 @@ bootstrap-cell "unbox_signed_2" "short" define-primitive-type - [ alien-unsigned-2 ] [ set-alien-unsigned-2 ] 2 @@ -71,7 +63,6 @@ bootstrap-cell "unbox_unsigned_2" "ushort" define-primitive-type - [ alien-signed-1 ] [ set-alien-signed-1 ] 1 @@ -79,7 +70,6 @@ bootstrap-cell "unbox_signed_1" "char" define-primitive-type - [ alien-unsigned-1 ] [ set-alien-unsigned-1 ] 1 @@ -87,23 +77,6 @@ bootstrap-cell "unbox_unsigned_1" "uchar" define-primitive-type - -[ alien-unsigned-cell alien>char-string ] -[ >r >r alien-address r> r> set-alien-unsigned-cell ] -bootstrap-cell -"box_char_string" -"unbox_char_string" -"char*" define-primitive-type - - -[ alien-unsigned-cell alien>u16-string ] -[ >r >r alien-address r> r> set-alien-unsigned-cell ] -4 -"box_u16_string" -"unbox_u16_string" -"ushort*" define-primitive-type - - [ alien-unsigned-4 zero? not ] [ 1 0 ? set-alien-unsigned-4 ] 4 @@ -111,7 +84,6 @@ bootstrap-cell "unbox_boolean" "bool" define-primitive-type - [ alien-float ] [ set-alien-float ] 4 @@ -120,6 +92,7 @@ bootstrap-cell "float" define-primitive-type T{ float-regs f 4 } "float" c-type set-c-type-reg-class +[ >float ] "float" c-type set-c-type-prep [ alien-double ] [ set-alien-double ] @@ -129,3 +102,22 @@ T{ float-regs f 4 } "float" c-type set-c-type-reg-class "double" define-primitive-type T{ float-regs f 8 } "double" c-type set-c-type-reg-class +[ >float ] "double" c-type set-c-type-prep + +[ alien-unsigned-cell alien>char-string ] +[ >r >r alien-address r> r> set-alien-unsigned-cell ] +bootstrap-cell +"box_char_string" +"unbox_alien" +"char*" define-primitive-type + +[ string>char-alien ] "char*" c-type set-c-type-prep + +[ alien-unsigned-cell alien>u16-string ] +[ >r >r alien-address r> r> set-alien-unsigned-cell ] +4 +"box_u16_string" +"unbox_alien" +"ushort*" define-primitive-type + +[ string>u16-alien ] "ushort*" c-type set-c-type-prep diff --git a/library/compiler/test/alien.factor b/library/compiler/test/alien.factor index fec2c8c4db..c7d417e107 100644 --- a/library/compiler/test/alien.factor +++ b/library/compiler/test/alien.factor @@ -86,3 +86,8 @@ cpu "x86" = macosx? and [ [ 5 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] unit-test + +FUNCTION: char* ffi_test_15 char* x char* y ; + +[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test +[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 80d269f0c3..8e87b8fb6c 100644 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -93,3 +93,11 @@ struct foo ffi_test_14(int x, int y) r.x = x; r.y = y; return r; } + +char *ffi_test_15(char *x, char *y) +{ + if(strcmp(x,y)) + return "foo"; + else + return "bar"; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index c9aa16d6ab..8991664526 100644 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -15,3 +15,4 @@ struct rect { float x, y, w, h; }; DLLEXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f); DLLEXPORT 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); DLLEXPORT struct foo ffi_test_14(int x, int y); +DLLEXPORT char *ffi_test_15(char *x, char *y);