327 lines
12 KiB
Factor
327 lines
12 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 alien.data
|
|
specialized-arrays strings unix.utilities vocabs.parser
|
|
words libc.private locals generalizations math ;
|
|
FROM: alien.c-types => float short ;
|
|
SPECIALIZED-ARRAY: bool
|
|
SPECIALIZED-ARRAY: char
|
|
SPECIALIZED-ARRAY: double
|
|
SPECIALIZED-ARRAY: float
|
|
SPECIALIZED-ARRAY: int
|
|
SPECIALIZED-ARRAY: long
|
|
SPECIALIZED-ARRAY: longlong
|
|
SPECIALIZED-ARRAY: short
|
|
SPECIALIZED-ARRAY: uchar
|
|
SPECIALIZED-ARRAY: uint
|
|
SPECIALIZED-ARRAY: ulong
|
|
SPECIALIZED-ARRAY: ulonglong
|
|
SPECIALIZED-ARRAY: ushort
|
|
SPECIALIZED-ARRAY: void*
|
|
IN: alien.marshall
|
|
|
|
<< primitive-types [ [ void* = ] [ bool = ] bi or not ]
|
|
filter [ define-primitive-marshallers ] each >>
|
|
|
|
TUPLE: alien-wrapper { underlying alien } ;
|
|
TUPLE: struct-wrapper < alien-wrapper disposed ;
|
|
TUPLE: class-wrapper < alien-wrapper disposed ;
|
|
|
|
MIXIN: c++-root
|
|
|
|
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
|
|
|
|
M: alien-wrapper unmarshall-cast ;
|
|
M: struct-wrapper unmarshall-cast ;
|
|
|
|
M: struct-wrapper dispose* underlying>> free ;
|
|
|
|
M: class-wrapper c++-type class name>> parse-c++-type ;
|
|
|
|
: marshall-pointer ( obj -- alien )
|
|
{
|
|
{ [ dup alien? ] [ ] }
|
|
{ [ dup not ] [ ] }
|
|
{ [ dup byte-array? ] [ malloc-byte-array ] }
|
|
{ [ dup alien-wrapper? ] [ underlying>> ] }
|
|
} cond ;
|
|
|
|
: marshall-primitive ( n -- n )
|
|
[ bool>arg ] ptr-pass-through ;
|
|
|
|
ALIAS: marshall-void* marshall-pointer
|
|
|
|
: marshall-void** ( seq -- alien )
|
|
[ marshall-void* ] void*-array{ } map-as 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-strings) ( seq -- alien )
|
|
[ marshall-char*-or-string ] void*-array{ } map-as
|
|
malloc-underlying ;
|
|
|
|
: marshall-char**-or-strings ( seq -- alien )
|
|
[ (marshall-char**-or-strings) ] ptr-pass-through ;
|
|
|
|
: marshall-bool ( ? -- n )
|
|
>boolean [ 1 ] [ 0 ] if ;
|
|
|
|
: (marshall-bool*) ( ?/seq -- alien )
|
|
[ marshall-bool <bool> malloc-byte-array ]
|
|
[ >bool-array malloc-underlying ]
|
|
marshall-x* ;
|
|
|
|
: marshall-bool* ( ?/seq -- alien )
|
|
[ (marshall-bool*) ] ptr-pass-through ;
|
|
|
|
: (marshall-bool**) ( seq -- alien )
|
|
[ marshall-bool* ] map >void*-array malloc-underlying ;
|
|
|
|
: marshall-bool** ( seq -- alien )
|
|
[ (marshall-bool**) ] ptr-pass-through ;
|
|
|
|
: unmarshall-bool ( n -- ? )
|
|
0 = not ;
|
|
|
|
: unmarshall-bool* ( alien -- ? )
|
|
*bool unmarshall-bool ;
|
|
|
|
: unmarshall-bool*-free ( alien -- ? )
|
|
[ *bool unmarshall-bool ] keep add-malloc free ;
|
|
|
|
: primitive-marshaller ( type -- quot/f )
|
|
{
|
|
{ "bool" [ [ ] ] }
|
|
{ "boolean" [ [ marshall-bool ] ] }
|
|
{ "char" [ [ marshall-primitive ] ] }
|
|
{ "uchar" [ [ marshall-primitive ] ] }
|
|
{ "short" [ [ marshall-primitive ] ] }
|
|
{ "ushort" [ [ marshall-primitive ] ] }
|
|
{ "int" [ [ marshall-primitive ] ] }
|
|
{ "uint" [ [ marshall-primitive ] ] }
|
|
{ "long" [ [ marshall-primitive ] ] }
|
|
{ "ulong" [ [ marshall-primitive ] ] }
|
|
{ "long" [ [ marshall-primitive ] ] }
|
|
{ "ulong" [ [ marshall-primitive ] ] }
|
|
{ "float" [ [ marshall-primitive ] ] }
|
|
{ "double" [ [ marshall-primitive ] ] }
|
|
{ "bool*" [ [ marshall-bool* ] ] }
|
|
{ "boolean*" [ [ 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* ] ] }
|
|
{ "longlong*" [ [ marshall-longlong* ] ] }
|
|
{ "ulonglong*" [ [ marshall-ulonglong* ] ] }
|
|
{ "float*" [ [ marshall-float* ] ] }
|
|
{ "double*" [ [ marshall-double* ] ] }
|
|
{ "bool&" [ [ marshall-bool* ] ] }
|
|
{ "boolean&" [ [ 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* ] ] }
|
|
{ "longlong&" [ [ marshall-longlong* ] ] }
|
|
{ "ulonglong&" [ [ marshall-ulonglong* ] ] }
|
|
{ "float&" [ [ marshall-float* ] ] }
|
|
{ "double&" [ [ marshall-double* ] ] }
|
|
{ "void*" [ [ marshall-void* ] ] }
|
|
{ "bool**" [ [ marshall-bool** ] ] }
|
|
{ "boolean**" [ [ 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** ] ] }
|
|
{ "longlong**" [ [ marshall-longlong** ] ] }
|
|
{ "ulonglong**" [ [ marshall-ulonglong** ] ] }
|
|
{ "float**" [ [ marshall-float** ] ] }
|
|
{ "double**" [ [ marshall-double** ] ] }
|
|
{ "void**" [ [ marshall-void** ] ] }
|
|
[ drop f ]
|
|
} case ;
|
|
|
|
: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
|
|
{
|
|
{ [ 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* ;
|
|
|
|
|
|
: unmarshall-char*-to-string ( alien -- string )
|
|
utf8 alien>string ;
|
|
|
|
: unmarshall-char*-to-string-free ( alien -- string )
|
|
[ unmarshall-char*-to-string ] keep add-malloc free ;
|
|
|
|
: primitive-unmarshaller ( type -- quot/f )
|
|
{
|
|
{ "bool" [ [ ] ] }
|
|
{ "boolean" [ [ unmarshall-bool ] ] }
|
|
{ "char" [ [ ] ] }
|
|
{ "uchar" [ [ ] ] }
|
|
{ "short" [ [ ] ] }
|
|
{ "ushort" [ [ ] ] }
|
|
{ "int" [ [ ] ] }
|
|
{ "uint" [ [ ] ] }
|
|
{ "long" [ [ ] ] }
|
|
{ "ulong" [ [ ] ] }
|
|
{ "longlong" [ [ ] ] }
|
|
{ "ulonglong" [ [ ] ] }
|
|
{ "float" [ [ ] ] }
|
|
{ "double" [ [ ] ] }
|
|
{ "bool*" [ [ unmarshall-bool*-free ] ] }
|
|
{ "boolean*" [ [ unmarshall-bool*-free ] ] }
|
|
{ "char*" [ [ ] ] }
|
|
{ "uchar*" [ [ unmarshall-uchar*-free ] ] }
|
|
{ "short*" [ [ unmarshall-short*-free ] ] }
|
|
{ "ushort*" [ [ unmarshall-ushort*-free ] ] }
|
|
{ "int*" [ [ unmarshall-int*-free ] ] }
|
|
{ "uint*" [ [ unmarshall-uint*-free ] ] }
|
|
{ "long*" [ [ unmarshall-long*-free ] ] }
|
|
{ "ulong*" [ [ unmarshall-ulong*-free ] ] }
|
|
{ "longlong*" [ [ unmarshall-long*-free ] ] }
|
|
{ "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
|
|
{ "float*" [ [ unmarshall-float*-free ] ] }
|
|
{ "double*" [ [ unmarshall-double*-free ] ] }
|
|
{ "bool&" [ [ unmarshall-bool*-free ] ] }
|
|
{ "boolean&" [ [ unmarshall-bool*-free ] ] }
|
|
{ "char&" [ [ ] ] }
|
|
{ "uchar&" [ [ unmarshall-uchar*-free ] ] }
|
|
{ "short&" [ [ unmarshall-short*-free ] ] }
|
|
{ "ushort&" [ [ unmarshall-ushort*-free ] ] }
|
|
{ "int&" [ [ unmarshall-int*-free ] ] }
|
|
{ "uint&" [ [ unmarshall-uint*-free ] ] }
|
|
{ "long&" [ [ unmarshall-long*-free ] ] }
|
|
{ "ulong&" [ [ unmarshall-ulong*-free ] ] }
|
|
{ "longlong&" [ [ unmarshall-longlong*-free ] ] }
|
|
{ "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
|
|
{ "float&" [ [ unmarshall-float*-free ] ] }
|
|
{ "double&" [ [ unmarshall-double*-free ] ] }
|
|
[ drop f ]
|
|
} case ;
|
|
|
|
: struct-primitive-unmarshaller ( type -- quot/f )
|
|
{
|
|
{ "bool" [ [ unmarshall-bool ] ] }
|
|
{ "boolean" [ [ unmarshall-bool ] ] }
|
|
{ "char" [ [ ] ] }
|
|
{ "uchar" [ [ ] ] }
|
|
{ "short" [ [ ] ] }
|
|
{ "ushort" [ [ ] ] }
|
|
{ "int" [ [ ] ] }
|
|
{ "uint" [ [ ] ] }
|
|
{ "long" [ [ ] ] }
|
|
{ "ulong" [ [ ] ] }
|
|
{ "longlong" [ [ ] ] }
|
|
{ "ulonglong" [ [ ] ] }
|
|
{ "float" [ [ ] ] }
|
|
{ "double" [ [ ] ] }
|
|
{ "bool*" [ [ unmarshall-bool* ] ] }
|
|
{ "boolean*" [ [ unmarshall-bool* ] ] }
|
|
{ "char*" [ [ ] ] }
|
|
{ "uchar*" [ [ unmarshall-uchar* ] ] }
|
|
{ "short*" [ [ unmarshall-short* ] ] }
|
|
{ "ushort*" [ [ unmarshall-ushort* ] ] }
|
|
{ "int*" [ [ unmarshall-int* ] ] }
|
|
{ "uint*" [ [ unmarshall-uint* ] ] }
|
|
{ "long*" [ [ unmarshall-long* ] ] }
|
|
{ "ulong*" [ [ unmarshall-ulong* ] ] }
|
|
{ "longlong*" [ [ unmarshall-long* ] ] }
|
|
{ "ulonglong*" [ [ unmarshall-ulong* ] ] }
|
|
{ "float*" [ [ unmarshall-float* ] ] }
|
|
{ "double*" [ [ unmarshall-double* ] ] }
|
|
{ "bool&" [ [ unmarshall-bool* ] ] }
|
|
{ "boolean&" [ [ unmarshall-bool* ] ] }
|
|
{ "char&" [ [ unmarshall-char* ] ] }
|
|
{ "uchar&" [ [ unmarshall-uchar* ] ] }
|
|
{ "short&" [ [ unmarshall-short* ] ] }
|
|
{ "ushort&" [ [ unmarshall-ushort* ] ] }
|
|
{ "int&" [ [ unmarshall-int* ] ] }
|
|
{ "uint&" [ [ unmarshall-uint* ] ] }
|
|
{ "long&" [ [ unmarshall-long* ] ] }
|
|
{ "ulong&" [ [ unmarshall-ulong* ] ] }
|
|
{ "longlong&" [ [ unmarshall-longlong* ] ] }
|
|
{ "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
|
|
{ "float&" [ [ unmarshall-float* ] ] }
|
|
{ "double&" [ [ unmarshall-double* ] ] }
|
|
[ drop f ]
|
|
} case ;
|
|
|
|
|
|
: ?malloc-byte-array ( c-type -- alien )
|
|
dup alien? [ malloc-byte-array ] unless ;
|
|
|
|
:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
|
|
type type-quot call current-vocab lookup [
|
|
dup superclasses superclass swap member?
|
|
[ def call ] [ drop clean call f ] if
|
|
] [ clean call f ] if* ; inline
|
|
|
|
: struct-unmarshaller ( type -- quot/f )
|
|
[ ] \ struct-wrapper
|
|
[ '[ ?malloc-byte-array _ new swap >>underlying ] ]
|
|
[ ]
|
|
x-unmarshaller ;
|
|
|
|
: class-unmarshaller ( type -- quot/f )
|
|
[ type-sans-pointer "#" append ] \ class-wrapper
|
|
[ '[ _ new swap >>underlying ] ]
|
|
[ ]
|
|
x-unmarshaller ;
|
|
|
|
: non-primitive-unmarshaller ( type -- quot/f )
|
|
{
|
|
{ [ dup pointer? ] [ class-unmarshaller ] }
|
|
[ struct-unmarshaller ]
|
|
} cond ;
|
|
|
|
: unmarshaller ( type -- quot )
|
|
factorize-type {
|
|
[ primitive-unmarshaller ]
|
|
[ non-primitive-unmarshaller ]
|
|
[ drop [ ] ]
|
|
} 1|| ;
|
|
|
|
: struct-field-unmarshaller ( type -- quot )
|
|
factorize-type {
|
|
[ struct-primitive-unmarshaller ]
|
|
[ non-primitive-unmarshaller ]
|
|
[ drop [ ] ]
|
|
} 1|| ;
|
|
|
|
: out-arg-unmarshaller ( type -- quot )
|
|
dup pointer-to-non-const-primitive?
|
|
[ factorize-type primitive-unmarshaller ]
|
|
[ drop [ drop ] ] if ;
|