diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor index cbe8ce8841..6f5c2a720d 100644 --- a/basis/alien/inline/inline.factor +++ b/basis/alien/inline/inline.factor @@ -1,20 +1,13 @@ ! Copyright (C) 2009 Jeremy Hughes. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.inline.compiler alien.libraries -alien.parser arrays assocs effects fry generalizations grouping -io.files io.files.info io.files.temp kernel lexer math -math.order math.ranges multiline namespaces sequences splitting +USING: accessors alien.inline.compiler alien.inline.types +alien.libraries alien.marshall alien.parser arrays assocs +combinators effects fry generalizations grouping io.files +io.files.info io.files.temp kernel lexer locals math math.order +math.ranges multiline namespaces quotations sequences splitting strings system vocabs.loader vocabs.parser words ; IN: alien.inline -: factorize-type ( str -- str' ) - "const-" ?head drop - "unsigned-" ?head [ "u" prepend ] when - "long-" ?head [ "long" prepend ] when ; - -: cify-type ( str -- str' ) - { { CHAR: ~ CHAR: space } } substitute ; - params-return factorize-type -roll concat make-function ; +:: marshalled-function ( function types effect -- word quot effect ) + function types effect factor-function + [ in>> ] + [ out>> types [ pointer-to-primitive? ] filter append ] + bi + [ + types [ marshaller ] map \ spread rot + types length \ nkeep + types [ out-arg-unmarshaller ] map \ spread + 7 narray >quotation + ] dip ; + : prototype-string ( function types effect -- str ) [ [ cify-type ] map ] dip types-effect>params-return cify-type -rot @@ -95,6 +100,14 @@ PRIVATE> [ in>> ] keep [ factor-function define-declared ] 3keep out>> prototype-string' ; +: define-c-marshalled ( function types effect -- prototype ) + [ marshalled-function define-declared ] 3keep + prototype-string ; + +: define-c-marshalled' ( function effect -- prototype ) + [ in>> ] keep [ marshalled-function define-declared ] 3keep + out>> prototype-string' ; + : define-c-link ( str -- ) "-l" prepend compiler-args get push ; @@ -123,4 +136,8 @@ SYNTAX: C-FUNCTION: function-types-effect define-c-function append-function-body c-strings get push ; +SYNTAX: C-MARSHALLED: + function-types-effect define-c-marshalled + append-function-body c-strings get push ; + SYNTAX: ;C-LIBRARY compile-c-library ; diff --git a/basis/alien/inline/types/authors.txt b/basis/alien/inline/types/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/inline/types/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/inline/types/types.factor b/basis/alien/inline/types/types.factor new file mode 100644 index 0000000000..6321c38b0a --- /dev/null +++ b/basis/alien/inline/types/types.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types assocs combinators.short-circuit fry +kernel memoize sequences splitting ; +IN: alien.inline.types + +: factorize-type ( str -- str' ) + "const-" ?head drop + "unsigned-" ?head [ "u" prepend ] when + "long-" ?head [ "long" prepend ] when ; + +: cify-type ( str -- str' ) + { { CHAR: ~ CHAR: space } } substitute ; + +: const-type? ( str -- ? ) + "const-" head? ; + +MEMO: resolved-primitives ( -- seq ) + primitive-types [ resolve-typedef ] map ; + +: primitive-type? ( type -- ? ) + factorize-type resolve-typedef [ resolved-primitives ] dip + '[ _ = ] any? ; + +: pointer? ( type -- ? ) + [ "*" tail? ] [ "&" tail? ] bi or ; + +: type-sans-pointer ( type -- type' ) + [ '[ _ = ] "*&" swap any? ] trim-tail ; + +: pointer-to-primitive? ( type -- ? ) + { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ; diff --git a/basis/alien/marshall/authors.txt b/basis/alien/marshall/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/marshall.factor b/basis/alien/marshall/marshall.factor new file mode 100644 index 0000000000..8ee7fc8f06 --- /dev/null +++ b/basis/alien/marshall/marshall.factor @@ -0,0 +1,179 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline.types +alien.marshall.private +alien.strings byte-arrays classes combinators +combinators.short-circuit destructors fry +io.encodings.utf8 kernel sequences +specialized-arrays.alien +specialized-arrays.bool specialized-arrays.char +specialized-arrays.double specialized-arrays.float +specialized-arrays.int specialized-arrays.long +specialized-arrays.longlong specialized-arrays.ulonglong +specialized-arrays.short specialized-arrays.uchar +specialized-arrays.uint specialized-arrays.ulong +specialized-arrays.ushort strings unix.utilities +vocabs.parser words ; +IN: alien.marshall + +<< primitive-types [ "void*" = not ] filter +[ define-primitive-marshallers ] each >> + +TUPLE: alien-wrapper { underlying alien } ; + +GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' ) + +M: alien-wrapper dynamic-cast ; + +: marshall-pointer ( obj -- alien ) + { + { [ dup alien? ] [ ] } + { [ dup not ] [ ] } + { [ dup byte-array? ] [ malloc-byte-array ] } + { [ dup alien-wrapper? ] [ underlying>> ] } + } cond ; + +: marshall-void* ( obj -- alien ) + marshall-pointer ; + +: marshall-void** ( obj -- alien ) + [ marshall-void* ] map >void*-array malloc-underlying ; + +: marshall-char*-or-string ( n/string -- alien ) + dup string? + [ utf8 string>alien malloc-byte-array ] + [ marshall-char* ] if ; + +: marshall-char**-or-strings ( seq -- alien ) + dup first string? + [ utf8 strings>alien malloc-byte-array ] + [ marshall-char** ] if ; + +: primitive-marshaller ( type -- quot/f ) + { + { "bool" [ [ marshall-bool ] ] } + { "char" [ [ marshall-char ] ] } + { "uchar" [ [ marshall-uchar ] ] } + { "short" [ [ marshall-short ] ] } + { "ushort" [ [ marshall-ushort ] ] } + { "int" [ [ marshall-int ] ] } + { "uint" [ [ marshall-uint ] ] } + { "long" [ [ marshall-long ] ] } + { "ulong" [ [ marshall-ulong ] ] } + { "float" [ [ marshall-float ] ] } + { "double" [ [ marshall-double ] ] } + { "bool*" [ [ marshall-bool* ] ] } + { "char*" [ [ marshall-char*-or-string ] ] } + { "uchar*" [ [ marshall-uchar* ] ] } + { "short*" [ [ marshall-short* ] ] } + { "ushort*" [ [ marshall-ushort* ] ] } + { "int*" [ [ marshall-int* ] ] } + { "uint*" [ [ marshall-uint* ] ] } + { "long*" [ [ marshall-long* ] ] } + { "ulong*" [ [ marshall-ulong* ] ] } + { "float*" [ [ marshall-float* ] ] } + { "double*" [ [ marshall-double* ] ] } + { "bool&" [ [ marshall-bool* ] ] } + { "char&" [ [ marshall-char* ] ] } + { "uchar&" [ [ marshall-uchar* ] ] } + { "short&" [ [ marshall-short* ] ] } + { "ushort&" [ [ marshall-ushort* ] ] } + { "int&" [ [ marshall-int* ] ] } + { "uint&" [ [ marshall-uint* ] ] } + { "long&" [ [ marshall-long* ] ] } + { "ulong&" [ [ marshall-ulong* ] ] } + { "float&" [ [ marshall-float* ] ] } + { "double&" [ [ marshall-double* ] ] } + { "void*" [ [ marshall-void* ] ] } + { "bool**" [ [ marshall-bool** ] ] } + { "char**" [ [ marshall-char**-or-strings ] ] } + { "uchar**" [ [ marshall-uchar** ] ] } + { "short**" [ [ marshall-short** ] ] } + { "ushort**" [ [ marshall-ushort** ] ] } + { "int**" [ [ marshall-int** ] ] } + { "uint**" [ [ marshall-uint** ] ] } + { "long**" [ [ marshall-long** ] ] } + { "ulong**" [ [ marshall-ulong** ] ] } + { "float**" [ [ marshall-float** ] ] } + { "double**" [ [ marshall-double** ] ] } + { "void**" [ [ marshall-void** ] ] } + [ drop f ] + } case ; + +: marshall-struct ( obj -- byte-array ) ; + +: marshaller ( type -- quot ) + factorize-type dup primitive-marshaller [ nip ] [ + pointer? + [ [ marshall-pointer ] ] + [ [ marshall-struct ] ] if + ] if* ; + + +: unmarshall-char*-to-string ( alien -- string ) + utf8 alien>string ; + +: unmarshall-bool ( n -- ? ) + 0 = not ; + +: primitive-unmarshaller ( type -- quot/f ) + { + { "bool" [ [ unmarshall-bool ] ] } + { "char" [ [ ] ] } + { "uchar" [ [ ] ] } + { "short" [ [ ] ] } + { "ushort" [ [ ] ] } + { "int" [ [ ] ] } + { "uint" [ [ ] ] } + { "long" [ [ ] ] } + { "ulong" [ [ ] ] } + { "float" [ [ ] ] } + { "double" [ [ ] ] } + { "bool*" [ [ *bool ] ] } + { "char*" [ [ unmarshall-char*-to-string ] ] } + { "uchar*" [ [ *uchar ] ] } + { "short*" [ [ *short ] ] } + { "ushort*" [ [ *ushort ] ] } + { "int*" [ [ *int ] ] } + { "uint*" [ [ *uint ] ] } + { "long*" [ [ *long ] ] } + { "ulong*" [ [ *ulong ] ] } + { "float*" [ [ *float ] ] } + { "double*" [ [ *double ] ] } + { "bool&" [ [ *bool ] ] } + { "char&" [ [ *char ] ] } + { "uchar&" [ [ *uchar ] ] } + { "short&" [ [ *short ] ] } + { "ushort&" [ [ *ushort ] ] } + { "int&" [ [ *int ] ] } + { "uint&" [ [ *uint ] ] } + { "long&" [ [ *long ] ] } + { "ulong&" [ [ *ulong ] ] } + { "float&" [ [ *float ] ] } + { "double&" [ [ *double ] ] } + [ drop f ] + } case ; + + +: unmarshall-struct ( byte-array -- byte-array' ) ; + +: pointer-unmarshaller ( type -- quot ) + type-sans-pointer current-vocab lookup [ + dup superclasses [ alien-wrapper = ] any? [ + '[ _ new >>underlying dynamic-cast ] + ] [ drop [ ] ] if + ] [ [ ] ] if* ; + +: unmarshaller ( type -- quot ) + factorize-type dup primitive-unmarshaller [ nip ] [ + dup pointer? + [ '[ _ pointer-unmarshaller ] ] + [ drop [ unmarshall-struct ] ] if + ] if* ; + +: out-arg-unmarshaller ( type -- quot ) + dup { + [ const-type? not ] + [ factorize-type pointer-to-primitive? ] + } 1&& + [ primitive-unmarshaller ] [ drop [ drop ] ] if ; diff --git a/basis/alien/marshall/private/authors.txt b/basis/alien/marshall/private/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/basis/alien/marshall/private/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/basis/alien/marshall/private/private.factor b/basis/alien/marshall/private/private.factor new file mode 100644 index 0000000000..71852abe36 --- /dev/null +++ b/basis/alien/marshall/private/private.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types alien.inline arrays +combinators fry functors kernel lexer libc macros math +sequences specialized-arrays.alien ; +IN: alien.marshall.private + +: bool>arg ( ? -- 1/0/obj ) + { + { t [ 1 ] } + { f [ 0 ] } + [ ] + } case ; + +MACRO: marshall-x* ( num-quot seq-quot -- alien ) + '[ bool>arg dup number? _ _ if ] ; + +: malloc-underlying ( obj -- alien ) + underlying>> malloc-byte-array ; + +FUNCTOR: define-primitive-marshallers ( TYPE -- ) + IS <${TYPE}> +>TYPE-array IS >${TYPE}-array +marshall-TYPE DEFINES marshall-${TYPE} +marshall-TYPE* DEFINES marshall-${TYPE}* +marshall-TYPE** DEFINES marshall-${TYPE}** +WHERE +: marshall-TYPE ( n -- byte-array ) + dup c-ptr? [ bool>arg ] unless ; +: marshall-TYPE* ( n/seq -- alien ) + dup c-ptr? [ + [ malloc-byte-array ] + [ >TYPE-array malloc-underlying ] + marshall-x* &free + ] unless ; +: marshall-TYPE** ( seq -- alien ) + dup c-ptr? [ + [ >TYPE-array malloc-underlying ] + map >void*-array malloc-underlying &free + ] unless ; +;FUNCTOR + +SYNTAX: PRIMITIVE-MARSHALLERS: +";" parse-tokens [ define-primitive-marshallers ] each ;