Added alien.marshall and modified alien.inline accordingly
parent
284ef4f048
commit
577420b7dd
|
@ -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 ;
|
||||
|
||||
<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 ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -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&& ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
|
@ -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 ;
|
Loading…
Reference in New Issue