steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

alien.marshall(.private): free and non-free marshallers and struct marshalling

db4
Jeremy Hughes 2009-07-07 16:04:41 +12:00
parent dc9bcc8b73
commit f61b736f10
2 changed files with 117 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
basis/alien/marshall/marshall.factor
View File

@ -39,17 +39,80 @@ M: alien-wrapper dynamic-cast ;
: marshall-void** ( obj -- alien )
[ marshall-void* ] map >void*-array malloc-underlying ;
: marshall-char*-or-string ( n/string -- alien )
dup string?
: (marshall-char*-or-string) ( n/string -- alien )
string?
[ utf8 string>alien malloc-byte-array ]
[ marshall-char* ] if ;
[ (marshall-char*) ] if ;
: marshall-char**-or-strings ( seq -- alien )
dup first string?
: marshall-char*-or-string ( n/string -- alien )
[ (marshall-char*-or-string) ] ptr-pass-through ;
: marshall-char*-or-string-free ( n/string -- alien )
[ (marshall-char*-or-string) &free ] ptr-pass-through ;
: (marshall-char**-or-strings) ( seq -- alien )
first string?
[ utf8 strings>alien malloc-byte-array ]
[ marshall-char** ] if ;
[ (marshall-char**) ] if ;
: marshall-char**-or-string ( n/string -- alien )
[ (marshall-char**-or-string) ] ptr-pass-through ;
: marshall-char**-or-string-free ( n/string -- alien )
[ (marshall-char**-or-string) &free ] ptr-pass-through ;
: 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*-free ] ] }
{ "char*" [ [ marshall-char*-or-string-free ] ] }
{ "uchar*" [ [ marshall-uchar*-free ] ] }
{ "short*" [ [ marshall-short*-free ] ] }
{ "ushort*" [ [ marshall-ushort*-free ] ] }
{ "int*" [ [ marshall-int*-free ] ] }
{ "uint*" [ [ marshall-uint*-free ] ] }
{ "long*" [ [ marshall-long*-free ] ] }
{ "ulong*" [ [ marshall-ulong*-free ] ] }
{ "float*" [ [ marshall-float*-free ] ] }
{ "double*" [ [ marshall-double*-free ] ] }
{ "bool&" [ [ marshall-bool*-free ] ] }
{ "char&" [ [ marshall-char*-free ] ] }
{ "uchar&" [ [ marshall-uchar*-free ] ] }
{ "short&" [ [ marshall-short*-free ] ] }
{ "ushort&" [ [ marshall-ushort*-free ] ] }
{ "int&" [ [ marshall-int*-free ] ] }
{ "uint&" [ [ marshall-uint*-free ] ] }
{ "long&" [ [ marshall-long*-free ] ] }
{ "ulong&" [ [ marshall-ulong*-free ] ] }
{ "float&" [ [ marshall-float*-free ] ] }
{ "double&" [ [ marshall-double*-free ] ] }
{ "void*" [ [ marshall-void* ] ] }
{ "bool**" [ [ marshall-bool**-free ] ] }
{ "char**" [ [ marshall-char**-or-strings-free ] ] }
{ "uchar**" [ [ marshall-uchar**-free ] ] }
{ "short**" [ [ marshall-short**-free ] ] }
{ "ushort**" [ [ marshall-ushort**-free ] ] }
{ "int**" [ [ marshall-int**-free ] ] }
{ "uint**" [ [ marshall-uint**-free ] ] }
{ "long**" [ [ marshall-long**-free ] ] }
{ "ulong**" [ [ marshall-ulong**-free ] ] }
{ "float**" [ [ marshall-float**-free ] ] }
{ "double**" [ [ marshall-double**-free ] ] }
{ "void**" [ [ marshall-void** ] ] }
[ drop f ]
} case ;
: struct-primitive-marshaller ( type -- quot/f )
{
{ "bool" [ [ marshall-bool ] ] }
{ "char" [ [ marshall-char ] ] }
@ -100,13 +163,27 @@ M: alien-wrapper dynamic-cast ;
[ drop f ]
} case ;
: marshall-struct ( obj -- byte-array ) ;
: marshall-non-ptr ( obj -- byte-array/f )
{
{ [ dup byte-array? ] [ ] }
{ [ dup alien-wrapper? ]
[ [ underlying>> ] [ class name>> heap-size ] bi
memory>byte-array ] }
} cond ;
: marshaller ( type -- quot )
factorize-type dup primitive-marshaller [ nip ] [
pointer?
[ [ marshall-pointer ] ]
[ [ marshall-struct ] ] if
[ [ marshall-non-pointer ] ] if
] if* ;
: struct-field-marshaller ( type -- quot )
factorize-type dup struct-primitive-marshaller [ nip ] [
pointer?
[ [ marshall-pointer ] ]
[ [ marshall-non-pointer ] ] if
] if* ;
@ -155,20 +232,26 @@ M: alien-wrapper dynamic-cast ;
} case ;
: unmarshall-struct ( byte-array -- byte-array' ) ;
: struct-unmarshaller ( type -- quot )
current-vocab lookup [
dup superclasses [ struct-wrapper? ] any? [
[ class name>> heap-size ] keep
'[ malloc-byte-array _ new swap >>underlying ]
] [ drop [ ] ] if
] [ [ ] ] if* ;
: pointer-unmarshaller ( type -- quot )
type-sans-pointer current-vocab lookup [
dup superclasses [ alien-wrapper = ] any? [
'[ _ new >>underlying dynamic-cast ]
dup superclasses [ alien-wrapper? ] any? [
'[ _ new swap >>underlying dynamic-cast ]
] [ drop [ ] ] if
] [ [ ] ] if* ;
: unmarshaller ( type -- quot )
factorize-type dup primitive-unmarshaller [ nip ] [
dup pointer?
[ '[ _ pointer-unmarshaller ] ]
[ drop [ unmarshall-struct ] ] if
[ pointer-unmarshaller ]
[ struct-unmarshaller ] if
] if* ;
: out-arg-unmarshaller ( type -- quot )

31
basis/alien/marshall/private/private.factor
View File

@ -15,6 +15,9 @@ IN: alien.marshall.private
MACRO: marshall-x* ( num-quot seq-quot -- alien )
'[ bool>arg dup number? _ _ if ] ;
: ptr-pass-through ( obj quot -- alien )
over c-ptr? [ drop ] [ call ] if ;
: malloc-underlying ( obj -- alien )
underlying>> malloc-byte-array ;
@ -22,22 +25,30 @@ 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}**)
marshall-TYPE* DEFINES marshall-${TYPE}*
marshall-TYPE** DEFINES marshall-${TYPE}**
marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
WHERE
: marshall-TYPE ( n -- byte-array )
dup c-ptr? [ bool>arg ] unless ;
[ bool>arg ] ptr-pass-through ;
: (marshall-TYPE*) ( n/seq -- alien )
[ <TYPE> malloc-byte-array ]
[ >TYPE-array malloc-underlying ]
marshall-x* ;
: (marshall-TYPE**) ( seq -- alien )
[ >TYPE-array malloc-underlying ]
map >void*-array malloc-underlying ;
: marshall-TYPE* ( n/seq -- alien )
dup c-ptr? [
[ <TYPE> malloc-byte-array ]
[ >TYPE-array malloc-underlying ]
marshall-x* &free
] unless ;
[ (marshall-TYPE*) ] ptr-pass-through ;
: marshall-TYPE** ( seq -- alien )
dup c-ptr? [
[ >TYPE-array malloc-underlying ]
map >void*-array malloc-underlying &free
] unless ;
[ (marshall-TYPE**) ] ptr-pass-through ;
: marshall-TYPE*-free ( n/seq -- alien )
[ (marshall-TYPE*) &free ] ptr-pass-through ;
: marshall-TYPE**-free ( seq -- alien )
[ (marshall-TYPE**) &free ] ptr-pass-through ;
;FUNCTOR
SYNTAX: PRIMITIVE-MARSHALLERS: