alien.marshall: C++ type parsing

extra/alien/inline/types/types.factor

@@ -2,7 +2,7 @@
 ! 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' )
@@ -21,6 +21,9 @@ IN: alien.inline.types
 : pointer-to-const? ( str -- ? )
     cify-type "const " head? ;
 
+: template-class? ( str -- ? )
+    [ CHAR: < = ] any? ;
+
 MEMO: resolved-primitives ( -- seq )
     primitive-types [ resolve-typedef ] map ;
 
@@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
         [ 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 ;

extra/alien/marshall/marshall.factor

@@ -12,7 +12,7 @@ specialized-arrays.short specialized-arrays.uchar
 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 ]
@@ -20,6 +20,7 @@ filter [ define-primitive-marshallers ] each >>
 
 TUPLE: alien-wrapper { underlying alien } ;
 TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
 
 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
 
@@ -28,6 +29,8 @@ 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? ] [ ] }
@@ -288,16 +291,8 @@ ALIAS: marshall-void* marshall-pointer
     [ ]
     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 ;