[Rcpp-commits] r3048 - in pkg/Rcpp: R inst/include/Rcpp inst/include/Rcpp/module src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jun 7 14:44:35 CEST 2011
Author: romain
Date: 2011-06-07 14:44:34 +0200 (Tue, 07 Jun 2011)
New Revision: 3048
Modified:
pkg/Rcpp/R/00_classes.R
pkg/Rcpp/R/Module.R
pkg/Rcpp/R/zzz.R
pkg/Rcpp/inst/include/Rcpp/Module.h
pkg/Rcpp/inst/include/Rcpp/module/Module_generated_CppMethod.h
pkg/Rcpp/src/Module.cpp
Log:
first pass at changes to allow methods of classes to return objects of other exposed classes
Modified: pkg/Rcpp/R/00_classes.R
===================================================================
--- pkg/Rcpp/R/00_classes.R 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/R/00_classes.R 2011-06-07 12:44:34 UTC (rev 3048)
@@ -72,7 +72,8 @@
methods = "list",
constructors = "list",
generator = "refObjectGenerator",
- docstring = "character"
+ docstring = "character",
+ typeid = "character"
),
contains = "character"
)
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/R/Module.R 2011-06-07 12:44:34 UTC (rev 3048)
@@ -114,12 +114,12 @@
# class method for $initialize
-cpp_object_initializer <- function(.self, .refClassDef, ...){
+cpp_object_initializer <- function(.self, .refClassDef, ..., .object_pointer){
selfEnv <- as.environment(.self)
## generate the C++-side object and store its pointer, etc.
## access the private fields in the fieldPrototypes env.
fields <- .refClassDef at fieldPrototypes
- pointer <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
+ pointer <- if(missing(.object_pointer)) new_CppObject_xp(fields$.module, fields$.pointer, ...) else .object_pointer
assign(".module", fields$.module, envir = selfEnv)
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
@@ -138,6 +138,11 @@
.self
}
+cpp_object_maker <- function(typeid, pointer){
+ Class <- Rcpp:::.classes_map[[ typeid ]]
+ new( Class, .object_pointer = pointer )
+}
+
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
if(is(module, "DLLInfo") && missing(mustStart)) mustStart <- TRUE
if(is(module, "Module")) {
@@ -194,6 +199,7 @@
for( i in seq_along(classes) ){
CLASS <- classes[[i]]
+
clname <- as.character(CLASS)
fields <- cpp_fields( CLASS, where )
@@ -244,15 +250,17 @@
}
}
+
}
if(length(classes)) {
module$refClassGenerators <- generators
}
for( i in seq_along(classes) ){
- clname <- as.character(classes[[i]])
+ CLASS <- classes[[i]]
+ clname <- as.character(CLASS)
demangled_name <- sub( "^Rcpp_", "", clname )
- storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
+ .classes_map[[ CLASS at typeid ]] <- storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
}
# functions
Modified: pkg/Rcpp/R/zzz.R
===================================================================
--- pkg/Rcpp/R/zzz.R 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/R/zzz.R 2011-06-07 12:44:34 UTC (rev 3048)
@@ -17,6 +17,8 @@
.dummyInstancePointer <- new.env() # just something permanent
+.classes_map <- new.env()
+
.onLoad <- function(libname, pkgname){
## Call to init_Rcpp_cache is not needed here as it is called in
## R_init_Rcpp. Calling it twice is potentially destructive
@@ -30,3 +32,4 @@
new_dummyObject(.dummyInstancePointer);
}
+
Modified: pkg/Rcpp/inst/include/Rcpp/Module.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Module.h 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/inst/include/Rcpp/Module.h 2011-06-07 12:44:34 UTC (rev 3048)
@@ -29,6 +29,15 @@
class CppClass ;
class CppObject ;
+template <typename T>
+class result {
+public:
+ result( T* ptr_ ) : ptr(ptr_){}
+ operator T*(){ return ptr ; }
+private:
+ T* ptr;
+} ;
+
class CppFunction {
public:
CppFunction(const char* doc = 0) : docstring( doc == 0 ? "" : doc) {}
@@ -99,6 +108,7 @@
virtual void setProperty( SEXP, SEXP, SEXP) {
throw std::range_error( "cannot set property" ) ;
}
+ virtual std::string get_typeinfo_name(){ return "" ; }
std::string name ;
std::string docstring ;
@@ -344,7 +354,8 @@
finalizer_pointer(0),
specials(0),
constructors(),
- class_pointer(0)
+ class_pointer(0),
+ typeinfo_name("")
{
Rcpp::Module* module = getCurrentScope() ;
if( ! module->has_class(name_) ){
@@ -352,6 +363,7 @@
class_pointer->name = name_ ;
class_pointer->docstring = std::string( doc == 0 ? "" : doc );
class_pointer->finalizer_pointer = new finalizer_class ;
+ class_pointer->typeinfo_name = typeid(Class).name() ;
module->AddClass( name_, class_pointer ) ;
}
}
@@ -372,6 +384,10 @@
public:
+ std::string get_typeinfo_name(){
+ return typeinfo_name ;
+ }
+
SEXP newInstance( SEXP* args, int nargs ){
BEGIN_RCPP
signed_constructor_class* p ;
@@ -380,7 +396,8 @@
p = constructors[i];
bool ok = (p->valid)(args, nargs) ;
if( ok ){
- return XP( p->ctor->get_new( args, nargs ), true ) ;
+ Class* ptr = p->ctor->get_new( args, nargs ) ;
+ return XP( ptr, true ) ;
}
}
throw std::range_error( "no valid constructor available for the argument list" ) ;
@@ -702,7 +719,8 @@
int specials ;
vec_signed_constructor constructors ;
self* class_pointer ;
-
+ std::string typeinfo_name ;
+
class_( ) : class_Base(), vec_methods(), properties(), specials(0) {};
} ;
Modified: pkg/Rcpp/inst/include/Rcpp/module/Module_generated_CppMethod.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/module/Module_generated_CppMethod.h 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/inst/include/Rcpp/module/Module_generated_CppMethod.h 2011-06-07 12:44:34 UTC (rev 3048)
@@ -56,6 +56,30 @@
private:
Method met ;
} ;
+
+ template <typename Class, typename T>
+ class CppMethod0< Class, result<T> > : public CppMethod<Class> {
+ public:
+ typedef result<T> (Class::*Method)(void) ;
+ typedef CppMethod<Class> method_class ;
+ typedef XPtr<T> XP ;
+ CppMethod0( Method m) : method_class(), met(m){}
+ SEXP operator()( Class* object, SEXP* ){
+ T* ptr = (object->*met)( ) ;
+ XP res = XP( ptr, true ) ;
+ Function maker = Environment::Rcpp_namespace()[ "cpp_object_maker"] ;
+ return maker( typeid(T).name() , res ) ;
+ }
+ inline int nargs(){ return 0 ; }
+ inline bool is_void(){ return false ; }
+ inline bool is_const(){ return false ; }
+ inline void signature(std::string& s, const char* name){ Rcpp::signature< result<T> >(s, name) ; }
+
+ private:
+ Method met ;
+ } ;
+
+
template <typename Class, typename OUT> class const_CppMethod0 : public CppMethod<Class> {
public:
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2011-06-06 16:04:19 UTC (rev 3047)
+++ pkg/Rcpp/src/Module.cpp 2011-06-07 12:44:34 UTC (rev 3048)
@@ -398,6 +398,7 @@
slot( "methods" ) = cl->getMethods( clxp.asSexp(), buffer ) ;
slot( "constructors") = cl->getConstructors( clxp.asSexp(), buffer ) ;
slot( "docstring" ) = cl->docstring ;
+ slot( "typeid" ) = cl->get_typeinfo_name() ;
}
CppObject::CppObject( Module* p, class_Base* clazz, SEXP xp ) : S4("C++Object") {
More information about the Rcpp-commits
mailing list