! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs combinators.short-circuit
continuations effects fry kernel math memoize sequences
-splitting ;
+splitting strings peg.ebnf make alien.c-types ;
IN: alien.inline.types
: cify-type ( str -- str' )
: pointer-to-const? ( str -- ? )
cify-type "const " head? ;
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
MEMO: resolved-primitives ( -- seq )
primitive-types [ resolve-typedef ] map ;
[ over pointer-to-primitive? [ ">" prepend ] when ]
assoc-map unzip
] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+ factorize-type parse-c++-type ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+ [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+ [
+ [ name>> % ]
+ [ params>> [ params>string % ] when* ]
+ [ ptr>> [ "*" % ] when ]
+ tri
+ ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
specialized-arrays.uint specialized-arrays.ulong
specialized-arrays.ulonglong specialized-arrays.ushort strings
unix.utilities vocabs.parser words libc.private struct-arrays
-locals generalizations ;
+locals generalizations math ;
IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
TUPLE: alien-wrapper { underlying alien } ;
TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
M: struct-wrapper dispose* underlying>> free ;
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
: marshall-pointer ( obj -- alien )
{
{ [ dup alien? ] [ ] }
[ ]
x-unmarshaller ;
-: template-class-unmarshaller ( type -- quot/f )
- [ parse-c++-type [ name>> ] keep swap ] [ \ template-wrapper = ]
- [ '[ _ _ new swap >>type swap >>underlying unmarshall-cast ] ]
- [ drop ]
- x-unmarshaller ;
-
: non-primitive-unmarshaller ( type -- quot/f )
{
- { [ dup template-class? ]
- [ template-class-unmarshaller ] }
{ [ dup pointer? ] [ class-unmarshaller ] }
[ struct-unmarshaller ]
} cond ;