Added alien.marshall and modified alien.inline accordingly

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
+USING: accessors alien.inline.compiler alien.inline.types
-alien.parser arrays assocs effects fry generalizations grouping
+alien.libraries alien.marshall alien.parser arrays assocs
-io.files io.files.info io.files.temp kernel lexer math
+combinators effects fry generalizations grouping io.files
-math.order math.ranges multiline namespaces sequences splitting
+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 ;
-
 <PRIVATE
 SYMBOL: c-library
 SYMBOL: library-is-c++
@@ -48,6 +41,18 @@ SYMBOL: c-strings
     types-effect>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 <effect>
+    [
+        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 ;

basis/alien/inline/types/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

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&& ;

basis/alien/marshall/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

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 ;

basis/alien/marshall/private/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

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 -- )
+<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? [
+        [ <TYPE> 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 ;