diff --git a/extra/alien/cxx/authors.txt b/extra/alien/cxx/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor new file mode 100644 index 0000000000..9d0ee24f50 --- /dev/null +++ b/extra/alien/cxx/cxx.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.cxx.parser alien.marshall +alien.inline.types classes.mixin classes.tuple kernel namespaces +assocs sequences parser classes.parser alien.marshall.syntax +interpolate locals effects io strings make vocabs.parser words +generic fry quotations ; +IN: alien.cxx + + + +: define-c++-class ( name superclass-mixin -- ) + [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip + add-mixin-instance define-class-tuple ; + +:: define-c++-method ( class-name generic name types effect virtual -- ) + [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name' + effect [ in>> "self" suffix ] [ out>> ] bi :> effect' + types class-name "*" append suffix :> types' + effect in>> "," join :> args + class-name virtual [ "#" append ] unless current-vocab lookup :> class + SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body + name' types' effect' body define-c-marshalled + class generic create-method name' current-vocab lookup 1quotation define ; diff --git a/extra/alien/cxx/parser/authors.txt b/extra/alien/cxx/parser/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/parser/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor new file mode 100644 index 0000000000..5afaab29e0 --- /dev/null +++ b/extra/alien/cxx/parser/parser.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: parser lexer alien.inline ; +IN: alien.cxx.parser + +: parse-c++-class-definition ( -- class superclass-mixin ) + scan scan-word ; + +: parse-c++-method-definition ( -- class-name generic name types effect ) + scan scan-word function-types-effect ; diff --git a/extra/alien/cxx/syntax/authors.txt b/extra/alien/cxx/syntax/authors.txt new file mode 100644 index 0000000000..c45c6f3279 --- /dev/null +++ b/extra/alien/cxx/syntax/authors.txt @@ -0,0 +1 @@ +Jeremy Hughes \ No newline at end of file diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor new file mode 100644 index 0000000000..24f685a197 --- /dev/null +++ b/extra/alien/cxx/syntax/syntax-tests.factor @@ -0,0 +1,113 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.cxx.syntax alien.inline.syntax +alien.marshall.syntax alien.marshall accessors kernel ; +IN: alien.cxx.syntax.tests + +DELETE-C-LIBRARY: test +C-LIBRARY: test + +COMPILE-AS-C++ + +C-INCLUDE: + +C-TYPEDEF: std::string string + +C++-CLASS: std::string c++-root + +GENERIC: to-string ( obj -- str ) + +C++-METHOD: std::string to-string const-char* c_str ( ) + +CM-FUNCTION: std::string* new_string ( const-char* s ) + return new std::string(s); +; + +;C-LIBRARY + +ALIAS: new_string + +{ 1 1 } [ new_string ] must-infer-as +{ 1 1 } [ c_str_std__string ] must-infer-as +[ t ] [ "abc" std::string? ] unit-test +[ "abc" ] [ "abc" to-string ] unit-test + + +DELETE-C-LIBRARY: inheritance +C-LIBRARY: inheritance + +COMPILE-AS-C++ + +C-INCLUDE: + +RAW-C: +class alpha { + public: + alpha(const char* s) { + str = s; + }; + const char* render() { + return str; + }; + virtual const char* chop() { + return str; + }; + virtual int length() { + return strlen(str); + }; + const char* str; +}; + +class beta : alpha { + public: + beta(const char* s) : alpha(s + 1) { }; + const char* render() { + return str + 1; + }; + virtual const char* chop() { + return str + 2; + }; +}; +; + +C++-CLASS: alpha c++-root +C++-CLASS: beta alpha + +CM-FUNCTION: alpha* new_alpha ( const-char* s ) + return new alpha(s); +; + +CM-FUNCTION: beta* new_beta ( const-char* s ) + return new beta(s); +; + +ALIAS: new_alpha +ALIAS: new_beta + +GENERIC: render ( obj -- obj ) +GENERIC: chop ( obj -- obj ) +GENERIC: length ( obj -- n ) + +C++-METHOD: alpha render const-char* render ( ) +C++-METHOD: beta render const-char* render ( ) +C++-VIRTUAL: alpha chop const-char* chop ( ) +C++-VIRTUAL: beta chop const-char* chop ( ) +C++-VIRTUAL: alpha length int length ( ) + +;C-LIBRARY + +{ 1 1 } [ render_alpha ] must-infer-as +{ 1 1 } [ chop_beta ] must-infer-as +{ 1 1 } [ length_alpha ] must-infer-as +[ t ] [ "x" alpha#? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ t ] [ "x" alpha? ] unit-test +[ f ] [ "x" alpha#? ] unit-test +[ 5 ] [ "hello" length ] unit-test +[ 4 ] [ "hello" length ] unit-test +[ "hello" ] [ "hello" render ] unit-test +[ "llo" ] [ "hello" render ] unit-test +[ "ello" ] [ "hello" underlying>> \ alpha# new swap >>underlying render ] unit-test +[ "hello" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" chop ] unit-test +[ "lo" ] [ "hello" underlying>> \ alpha# new swap >>underlying chop ] unit-test diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor new file mode 100644 index 0000000000..66c72c1c2b --- /dev/null +++ b/extra/alien/cxx/syntax/syntax.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Jeremy Hughes. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.cxx alien.cxx.parser ; +IN: alien.cxx.syntax + +SYNTAX: C++-CLASS: + parse-c++-class-definition define-c++-class ; + +SYNTAX: C++-METHOD: + parse-c++-method-definition f define-c++-method ; + +SYNTAX: C++-VIRTUAL: + parse-c++-method-definition t define-c++-method ; diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor index 94b98d1eb5..070febc324 100644 --- a/extra/alien/inline/types/types.factor +++ b/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 ; 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 ; + +TUPLE: c++-type name params ptr ; +C: 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 ]] +;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 ; diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor index 6002b0c1c3..deac9fd186 100644 --- a/extra/alien/marshall/marshall-docs.factor +++ b/extra/alien/marshall/marshall-docs.factor @@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller "for all types except pointers to non-const primitives." } ; -HELP: pointer-unmarshaller +HELP: class-unmarshaller { $values { "type" " a C type string" } { "quot" quotation } diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor index 85b157e4a0..547e37f78a 100644 --- a/extra/alien/marshall/marshall.factor +++ b/extra/alien/marshall/marshall.factor @@ -11,7 +11,8 @@ 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 libc.private struct-arrays ; +unix.utilities vocabs.parser words libc.private struct-arrays +locals generalizations math ; IN: alien.marshall << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ] @@ -19,6 +20,9 @@ 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' ) @@ -27,6 +31,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? ] [ ] } @@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer : ?malloc-byte-array ( c-type -- alien ) dup alien? [ malloc-byte-array ] unless ; -: struct-unmarshaller ( type -- quot ) - current-vocab lookup [ - dup superclasses [ \ struct-wrapper = ] any? [ - '[ ?malloc-byte-array _ new swap >>underlying ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +:: 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 -: pointer-unmarshaller ( type -- quot ) - type-sans-pointer current-vocab lookup [ - dup superclasses [ \ alien-wrapper = ] any? [ - '[ _ new swap >>underlying unmarshall-cast ] - ] [ drop [ ] ] if - ] [ [ ] ] if* ; +: 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 dup primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : struct-field-unmarshaller ( type -- quot ) - factorize-type dup struct-primitive-unmarshaller [ nip ] [ - dup pointer? - [ pointer-unmarshaller ] - [ struct-unmarshaller ] if - ] if* ; + factorize-type { + [ struct-primitive-unmarshaller ] + [ non-primitive-unmarshaller ] + [ drop [ ] ] + } 1|| ; : out-arg-unmarshaller ( type -- quot ) dup pointer-to-non-const-primitive?