Merge branch 'cxx' of git://github.com/jedahu/factor
Slava Pestov
commit
3c7bd34a15
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
: class-mixin ( str -- word )
|
||||
create-class-in [ define-mixin-class ] keep ;
|
||||
|
||||
: class-tuple-word ( word -- word' )
|
||||
"#" append create-in ;
|
||||
|
||||
: define-class-tuple ( word mixin -- )
|
||||
[ drop class-wrapper { } define-tuple-class ]
|
||||
[ add-mixin-instance ] 2bi ;
|
||||
PRIVATE>
|
||||
|
||||
: 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> :> 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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jeremy Hughes
|
||||
|
|
@ -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: <string>
|
||||
|
||||
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: <std::string> new_string
|
||||
|
||||
{ 1 1 } [ new_string ] must-infer-as
|
||||
{ 1 1 } [ c_str_std__string ] must-infer-as
|
||||
[ t ] [ "abc" <std::string> std::string? ] unit-test
|
||||
[ "abc" ] [ "abc" <std::string> to-string ] unit-test
|
||||
|
||||
|
||||
DELETE-C-LIBRARY: inheritance
|
||||
C-LIBRARY: inheritance
|
||||
|
||||
COMPILE-AS-C++
|
||||
|
||||
C-INCLUDE: <cstring>
|
||||
|
||||
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: <alpha> new_alpha
|
||||
ALIAS: <beta> 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> alpha#? ] unit-test
|
||||
[ t ] [ "x" <alpha> alpha? ] unit-test
|
||||
[ t ] [ "x" <beta> alpha? ] unit-test
|
||||
[ f ] [ "x" <beta> alpha#? ] unit-test
|
||||
[ 5 ] [ "hello" <alpha> length ] unit-test
|
||||
[ 4 ] [ "hello" <beta> length ] unit-test
|
||||
[ "hello" ] [ "hello" <alpha> render ] unit-test
|
||||
[ "llo" ] [ "hello" <beta> render ] unit-test
|
||||
[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
|
||||
[ "hello" ] [ "hello" <alpha> chop ] unit-test
|
||||
[ "lo" ] [ "hello" <beta> chop ] unit-test
|
||||
[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 <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 ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue