[Rcpp-commits] r1290 - in pkg/Rcpp: . R inst/include inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu May 20 14:43:45 CEST 2010
Author: romain
Date: 2010-05-20 14:43:45 +0200 (Thu, 20 May 2010)
New Revision: 1290
Modified:
pkg/Rcpp/NAMESPACE
pkg/Rcpp/R/Module.R
pkg/Rcpp/inst/include/Rcpp.h
pkg/Rcpp/inst/include/Rcpp/Module.h
pkg/Rcpp/src/Module.cpp
Log:
hiding experimental module features (for now)
Modified: pkg/Rcpp/NAMESPACE
===================================================================
--- pkg/Rcpp/NAMESPACE 2010-05-20 12:27:57 UTC (rev 1289)
+++ pkg/Rcpp/NAMESPACE 2010-05-20 12:43:45 UTC (rev 1290)
@@ -6,6 +6,7 @@
importFrom( utils, capture.output )
importFrom( inline, cfunction )
-exportClasses( Module )
-export( Module )
+# exportClasses( Module )
+# export( Module )
+
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-05-20 12:27:57 UTC (rev 1289)
+++ pkg/Rcpp/R/Module.R 2010-05-20 12:43:45 UTC (rev 1290)
@@ -15,30 +15,31 @@
# You should have received a copy of the GNU General Public License
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
-setClass( "Module", representation( pointer = "externalptr" ) )
+# not yet
+# setClass( "Module", representation( pointer = "externalptr" ) )
+#
+# Module <- function( module, PACKAGE ){
+# name <- sprintf( "_rcpp_module_boot_%s", module )
+# symbol <- getNativeSymbolInfo( name, PACKAGE )
+# xp <- .Call( symbol )
+# new( "Module", pointer = xp )
+# }
+#
+# setMethod( "$", "Module", function(x, name){
+# function( ... ) {
+# res <- .External( "Module__invoke" , x at pointer, name, ..., PACKAGE = "Rcpp" )
+# if( isTRUE( res$void ) ) invisible(NULL) else res$result
+# }
+# } )
+#
+# setMethod( "show", "Module", function( object ){
+# info <- .Call( "Module__funtions_arity", object at pointer, PACKAGE = "Rcpp" )
+# name <- .Call( "Module__name", object at pointer )
+# txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
+# writeLines( txt )
+# txt <- sprintf( "%15s : %d arguments", names(info), info )
+# writeLines( txt )
+# } )
-Module <- function( module, PACKAGE ){
- name <- sprintf( "_rcpp_module_boot_%s", module )
- symbol <- getNativeSymbolInfo( name, PACKAGE )
- xp <- .Call( symbol )
- new( "Module", pointer = xp )
-}
-
-setMethod( "$", "Module", function(x, name){
- function( ... ) {
- res <- .External( "Module__invoke" , x at pointer, name, ..., PACKAGE = "Rcpp" )
- if( isTRUE( res$void ) ) invisible(NULL) else res$result
- }
-} )
-
-setMethod( "show", "Module", function( object ){
- info <- .Call( "Module__funtions_arity", object at pointer, PACKAGE = "Rcpp" )
- name <- .Call( "Module__name", object at pointer )
- txt <- sprintf( "Rcpp module '%s' \n\t%d functions: ", name, length(info) )
- writeLines( txt )
- txt <- sprintf( "%15s : %d arguments", names(info), info )
- writeLines( txt )
-} )
-
#TODO: maybe attach( Module ), with( Module )
Modified: pkg/Rcpp/inst/include/Rcpp/Module.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Module.h 2010-05-20 12:27:57 UTC (rev 1289)
+++ pkg/Rcpp/inst/include/Rcpp/Module.h 2010-05-20 12:43:45 UTC (rev 1290)
@@ -8,7 +8,7 @@
//
// Rcpp is free software: you can redistribute it and/or modify it
// under the terms of the GNU General Public License as published by
-// the Free Software Foundation, either version 2 of the License, or
+// the Free Software Foundation, either version 2 of the License, or
// (at your option) any later version.
//
// Rcpp is distributed in the hope that it will be useful, but
@@ -22,6 +22,7 @@
#ifndef Rcpp_Module_h
#define Rcpp_Module_h
+#ifdef RCPP_EXPERIMENTAL
namespace Rcpp{
class CppFunction {
@@ -33,16 +34,30 @@
virtual bool is_void(){ return false ; }
};
+
+// templates CppFunction0, ..., CppFunction65
#include <Rcpp/module/Module_generated_CppFunction.h>
+// make_function factories
#include <Rcpp/module/Module_generated_make_function.h>
+class class_Base {
+public:
+ class_Base(const char* name_) : name(name_){} ;
+
+ virtual SEXP invoke( const std::string& method_name, SEXP *args, int nargs ) = 0 ;
+
+private:
+ std::string name ;
+} ;
+
class Module {
public:
typedef std::map<std::string,CppFunction*> MAP ;
+ typedef std::map<std::string,class_Base*> CLASS_MAP ;
Module() : name(), functions() {}
- Module(const char* name_) : name(name_), functions() {}
+ Module(const char* name_) : name(name_), functions(), classes() {}
SEXP invoke( const std::string& name, SEXP* args, int nargs){
try{
@@ -74,15 +89,67 @@
std::string name ;
private:
- std::map<std::string,CppFunction*> functions ;
+ MAP functions ;
+ CLASS_MAP classes ;
};
+template <typename Class>
+class CppMethod {
+ public:
+ CppMethod() {}
+ virtual SEXP operator()(SEXP* args) { return R_NilValue ; }
+ virtual ~CppMethod(){}
+ virtual int nargs(){ return 0 ; }
+ virtual bool is_void(){ return false ; }
+
+} ;
+
+template <typename Class>
+class class_{
+public:
+ typedef class_ self ;
+ typedef CppMethod<Class> method ;
+ typedef std::map<std::string,method*> METHOD_MAP ;
+ typedef std::pair<const std::string,method*> PAIR ;
+
+ class_( const char* name_ ) : class_Base(name_), methods() {}
+
+ SEXP invoke( const std::string& method_name, SEXP *args, int nargs ){
+ try{
+ typename METHOD_MAP::iterator it = methods.find( method_name ) ;
+ if( it == methods.end() ){
+ throw std::range_error( "no such method" ) ;
+ }
+ method* met = it->second ;
+ if( met->nargs() > nargs ){
+ throw std::range_error( "incorrect number of arguments" ) ;
+ }
+ return Rcpp::List::create(
+ Rcpp::Named("result") = met->operator()( args ),
+ Rcpp::Named("void") = met->is_void()
+ ) ;
+
+ } catch( std::exception& __ex__ ){
+ forward_exception_to_r( __ex__ );
+ }
+ return R_NilValue ; // -Wall
+ }
+
+ self& AddMethod( const char* name, method* m){
+ methods.insert( PAIR( name,m ) ) ;
+ return *this ;
+ }
+
+private:
+ METHOD_MAP methods ;
+} ;
+
extern Rcpp::Module* current_scope ;
+// function factories
#include <Rcpp/module/Module_generated_function.h>
-
}
@@ -97,7 +164,7 @@
return mod_xp ; \
} \
void _rcpp_module_##name##_init()
-
+#endif
#endif
Modified: pkg/Rcpp/inst/include/Rcpp.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp.h 2010-05-20 12:27:57 UTC (rev 1289)
+++ pkg/Rcpp/inst/include/Rcpp.h 2010-05-20 12:43:45 UTC (rev 1290)
@@ -69,6 +69,9 @@
#include <Rcpp/Formula.h>
#include <Rcpp/DataFrame.h>
+// #define RCPP_EXPERIMENTAL
+#ifdef RCPP_EXPERIMENTAL
#include <Rcpp/Module.h>
+#endif
#endif
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2010-05-20 12:27:57 UTC (rev 1289)
+++ pkg/Rcpp/src/Module.cpp 2010-05-20 12:43:45 UTC (rev 1290)
@@ -19,6 +19,8 @@
// You should have received a copy of the GNU General Public License
// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+#ifdef RCPP_EXPERIMENTAL
+
#include <Rcpp.h>
#define MAX_ARGS 65
@@ -72,8 +74,7 @@
ptr_fun() ;
return R_NilValue ;
}
-
-
}
+#endif
More information about the Rcpp-commits
mailing list