263 lines
9.5 KiB
Factor
263 lines
9.5 KiB
Factor
! 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 libc 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.short specialized-arrays.uchar
|
|
specialized-arrays.uint specialized-arrays.ulong
|
|
specialized-arrays.ulonglong 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 } ;
|
|
TUPLE: struct-wrapper < alien-wrapper disposed ;
|
|
|
|
GENERIC: dynamic-cast ( alien-wrapper -- alien-wrapper' )
|
|
|
|
M: alien-wrapper dynamic-cast ;
|
|
M: struct-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-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 )
|
|
dup first string?
|
|
[ utf8 strings>alien malloc-byte-array ]
|
|
[ (marshall-char**) ] if ;
|
|
|
|
: marshall-char**-or-strings ( n/string -- alien )
|
|
[ (marshall-char**-or-strings) ] ptr-pass-through ;
|
|
|
|
: marshall-char**-or-strings-free ( n/string -- alien )
|
|
[ (marshall-char**-or-strings) &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 ] ] }
|
|
{ "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-non-pointer ( 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-non-pointer ] ] if
|
|
] if* ;
|
|
|
|
: struct-field-marshaller ( type -- quot )
|
|
factorize-type dup struct-primitive-marshaller [ nip ] [
|
|
pointer?
|
|
[ [ marshall-pointer ] ]
|
|
[ [ marshall-non-pointer ] ] 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 ;
|
|
|
|
|
|
: 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 swap >>underlying dynamic-cast ]
|
|
] [ drop [ ] ] if
|
|
] [ [ ] ] if* ;
|
|
|
|
: unmarshaller ( type -- quot )
|
|
factorize-type dup primitive-unmarshaller [ nip ] [
|
|
dup pointer?
|
|
[ pointer-unmarshaller ]
|
|
[ struct-unmarshaller ] if
|
|
] if* ;
|
|
|
|
: out-arg-unmarshaller ( type -- quot )
|
|
dup {
|
|
[ const-type? not ]
|
|
[ factorize-type pointer-to-primitive? ]
|
|
} 1&&
|
|
[ primitive-unmarshaller ] [ drop [ drop ] ] if ;
|