[Rcpp-commits] r373 - in pkg: inst/unitTests src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 14 22:00:24 CET 2010
Author: romain
Date: 2010-01-14 22:00:22 +0100 (Thu, 14 Jan 2010)
New Revision: 373
Modified:
pkg/inst/unitTests/runit.evaluator.R
pkg/src/Environment.cpp
pkg/src/Evaluator.cpp
pkg/src/ExpressionVector.cpp
pkg/src/Function.cpp
pkg/src/GenericVector.cpp
pkg/src/Language.cpp
pkg/src/Pairlist.cpp
pkg/src/Rcpp/Evaluator.h
pkg/src/Rcpp/Function.h
Log:
rework evaluator to use the 'geterrmessage' thing suggested by L.Gautier and M. Morgan
Modified: pkg/inst/unitTests/runit.evaluator.R
===================================================================
--- pkg/inst/unitTests/runit.evaluator.R 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/inst/unitTests/runit.evaluator.R 2010-01-14 21:00:22 UTC (rev 373)
@@ -22,24 +22,18 @@
}
test.evaluator.error <- function(){
- funx <- cfunction(signature(x = "expression"), '
- Rcpp::Evaluator evaluator( x ) ;
- evaluator.run( Rcpp::Environment::global_env() ) ;
- return evaluator.getError() ;
+ funx <- cfunction(signature(), '
+ return Rcpp::Evaluator::run( Rf_lang2( Rf_install("stop"), Rf_mkString( "boom" ) ) ) ;
', Rcpp=TRUE, verbose=FALSE)
- err <- funx( expression(stop("error")) )
- checkTrue( all( "simpleError" %in% class(err ) ), msg = "error capture" )
+ checkException( funx(), msg = "Evaluator::run( stop() )" )
}
test.evaluator.ok <- function(){
- funx <- cfunction(signature(x = "expression"), '
- Rcpp::Evaluator evaluator( x ) ;
- evaluator.run( Rcpp::Environment::global_env() ) ;
- return evaluator.getResult() ;
+ funx <- cfunction(signature(x="integer"), '
+ return Rcpp::Evaluator::run( Rf_lang2( Rf_install("sample"), x ) ) ;
', Rcpp=TRUE, verbose=FALSE)
- x <- funx( expression( sample(1:10) ) )
- checkEquals( sort(x), 1:10, msg = "Evaluator running fine" )
+ checkEquals( sort(funx(1:10)), 1:10, msg = "Evaluator running fine" )
}
-
+
Modified: pkg/src/Environment.cpp
===================================================================
--- pkg/src/Environment.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Environment.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -47,16 +47,15 @@
Environment::Environment( SEXP x = R_GlobalEnv) throw(not_compatible) : RObject::RObject(x){
if( ! Rf_isEnvironment(x) ) {
-
/* not an environment, but maybe convertible to one using
as.environment, try that */
- Evaluator evaluator( Rf_lang2(Symbol("as.environment"), x ) ) ;
- evaluator.run() ;
- if( evaluator.successfull() ){
- setSEXP( evaluator.getResult().asSexp() ) ;
- } else{
+ SEXP res ;
+ try{
+ res = Evaluator::run( Rf_lang2(Rf_install("as.environment"), x ) ) ;
+ } catch( const Evaluator::eval_error& ex){
throw not_compatible( "cannot convert to environment" ) ;
}
+ setSEXP( res ) ;
}
}
@@ -67,24 +66,25 @@
} else if( name == "package:base" ){
setSEXP( R_BaseEnv ) ;
} else{
- Evaluator evaluator( Rf_lang2(Symbol("as.environment"), Rf_mkString(name.c_str()) ) ) ;
- evaluator.run() ;
- if( evaluator.successfull() ){
- setSEXP( evaluator.getResult().asSexp() ) ;
- } else{
- throw no_such_env(name) ;
+ SEXP res = R_NilValue ;
+ try{
+ res = Evaluator::run(
+ Rf_lang2( Rf_install("as.environment"), Rf_mkString(name.c_str()) ) ) ;
+ } catch( const Evaluator::eval_error& ex){
+ throw no_such_env(name) ;
}
+ setSEXP( res ) ;
}
}
Environment::Environment(int pos) throw(no_such_env) : RObject(R_GlobalEnv){
- Evaluator evaluator( Rf_lang2(Symbol("as.environment"), Rf_ScalarInteger(pos) ) ) ;
- evaluator.run() ;
- if( evaluator.successfull() ){
- setSEXP( evaluator.getResult() ) ;
- } else{
- throw no_such_env(pos) ;
- }
+ SEXP res ;
+ try{
+ res = Evaluator::run( Rf_lang2( Rf_install("as.environment"), Rf_ScalarInteger(pos) ) ) ;
+ } catch( const Evaluator::eval_error& ex){
+ throw no_such_env(pos) ;
+ }
+ setSEXP( res ) ;
}
Environment::Environment( const Environment& other ) throw() {
Modified: pkg/src/Evaluator.cpp
===================================================================
--- pkg/src/Evaluator.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Evaluator.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -23,27 +23,33 @@
#include <Rcpp/Environment.h>
namespace Rcpp {
-
- Evaluator::Evaluator( SEXP expression = R_NilValue) :
- expression(expression),
- error_occured(false),
- result(),
- error() {}
-
- Evaluator::~Evaluator(){}
-
- void Evaluator::run(SEXP env ) throw() {
- Environment rcpp = Environment::namespace_env("Rcpp") ;
- SEXP call = Rf_lang3( Rf_install("protectedEval"), expression, env ) ;
- result = wrap( Rf_eval( call, rcpp ) );
- error_occured = LOGICAL( Rf_eval( Rf_lang1( Rf_install("errorOccured")) , rcpp) )[0] ;
- if( error_occured ){
- error = wrap( Rf_eval( Rf_lang1(Rf_install("getCurrentError")) , rcpp) );
+
+ Evaluator::eval_error::eval_error( const std::string& message) throw() :
+ message(message){}
+ Evaluator::eval_error::~eval_error( ) throw(){} ;
+ const char* Evaluator::eval_error::what() const throw(){ return message.c_str() ; }
+
+ SEXP Evaluator::run(SEXP expr, SEXP env) throw(eval_error) {
+ int error = 0 ;
+ SEXP res = PROTECT( R_tryEval( expr, env, &error ) ) ;
+ if( error ){
+ UNPROTECT( 1 ) ; /* res */
+ SEXP message = PROTECT( Rf_eval( Rf_lang1( Rf_install("geterrmessage") ), R_GlobalEnv ) );
+ std::string err_msg ;
+ if( TYPEOF( message ) == STRSXP && Rf_length( message ) ){
+ err_msg = CHAR( STRING_ELT( message, 0 ) ) ;
+ } else{
+ err_msg = "error with no message" ;
+ }
+ UNPROTECT(1) ; /* message */
+ throw eval_error( err_msg ) ;
+ } else {
+ UNPROTECT( 1) ; /* res */
+ return res ;
}
}
- void Evaluator::run() throw() {
- run( R_GlobalEnv) ;
+ SEXP Evaluator::run( SEXP expr) throw(eval_error){
+ return run(expr, R_GlobalEnv );
}
-
} // namespace Rcpp
Modified: pkg/src/ExpressionVector.cpp
===================================================================
--- pkg/src/ExpressionVector.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/ExpressionVector.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -35,13 +35,13 @@
break ;
default:
{
- Evaluator e( Rf_lang2( Symbol("as.expression"), x ) ) ;
- e.run() ;
- if( e.successfull() ){
- setSEXP( e.getResult() ) ;
- } else{
+ SEXP res = R_NilValue ;
+ try{
+ SEXP res = Evaluator::run( Rf_lang2( Rf_install("as.expression"), x ) ) ;
+ } catch( const Evaluator::eval_error& e){
throw not_compatible( "could not convert to an expression vector" ) ;
}
+ setSEXP( res ) ;
}
}
}
Modified: pkg/src/Function.cpp
===================================================================
--- pkg/src/Function.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Function.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -53,18 +53,4 @@
return Environment( CLOENV(m_sexp) ) ;
}
- Function::eval_error::eval_error(const RObject& err) throw() : message(){
- if( err.isNULL() ) {
- message = "unknown error" ;
- } else{
- message = as<std::string>( Rf_eval(
- Rf_lang2( Rf_install("conditionMessage"), err),
- R_GlobalEnv ) );
- }
- }
- Function::eval_error::~eval_error() throw(){}
- const char* Function::eval_error::what() throw() {
- return message.c_str() ;
- }
-
} // namespace Rcpp
Modified: pkg/src/GenericVector.cpp
===================================================================
--- pkg/src/GenericVector.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/GenericVector.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -35,13 +35,13 @@
break ;
default:
{
- Evaluator e( Rf_lang2( Symbol("as.list"), x ) ) ;
- e.run() ;
- if( e.successfull() ){
- setSEXP( e.getResult() ) ;
- } else{
+ SEXP res = R_NilValue ;
+ try{
+ res = Evaluator::run( Rf_lang2( Rf_install( "as.list" ), x ) ) ;
+ } catch( const Evaluator::eval_error& ex){
throw not_compatible( "could not convert to a list" ) ;
}
+ setSEXP( res ) ;
}
}
}
Modified: pkg/src/Language.cpp
===================================================================
--- pkg/src/Language.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Language.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -20,8 +20,8 @@
// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
#include <Rcpp/Language.h>
-#include <Rcpp/Evaluator.h>
#include <RcppCommon.h>
+#include <Rcpp/wrap.h>
namespace Rcpp {
Modified: pkg/src/Pairlist.cpp
===================================================================
--- pkg/src/Pairlist.cpp 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Pairlist.cpp 2010-01-14 21:00:22 UTC (rev 373)
@@ -36,13 +36,13 @@
break ;
default:
{
- Evaluator evaluator( Rf_lang2( Rf_install("as.pairlist"), x ) ) ;
- evaluator.run() ;
- if( evaluator.successfull() ){
- setSEXP( evaluator.getResult().asSexp() ) ;
- } else{
+ SEXP res= R_NilValue;
+ try{
+ res = Evaluator::run( Rf_lang2( Rf_install("as.pairlist"), x ) ) ;
+ } catch( const Evaluator::eval_error& ex){
throw not_compatible( "cannot convert to call (LANGSXP)" ) ;
}
+ setSEXP( res ) ;
}
}
}
Modified: pkg/src/Rcpp/Evaluator.h
===================================================================
--- pkg/src/Rcpp/Evaluator.h 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Rcpp/Evaluator.h 2010-01-14 21:00:22 UTC (rev 373)
@@ -24,26 +24,24 @@
#include <RcppCommon.h>
#include <Rcpp/RObject.h>
-#include <Rcpp/Environment.h>
#include <Rcpp/wrap.h>
namespace Rcpp{
class Evaluator{
public:
- Evaluator(SEXP expression ) ;
- ~Evaluator() ;
- void run(SEXP env) throw() ;
- void run() throw() ;
- inline RObject getResult() const { return result ; }
- inline RObject getError() const { return error ; }
- inline bool successfull() const { return !error_occured ; }
-
-private:
- SEXP expression ;
- bool error_occured ;
- RObject result ;
- RObject error ;
+
+ class eval_error : public std::exception{
+ public:
+ eval_error( const std::string& message ) throw() ;
+ ~eval_error() throw() ;
+ const char* what() const throw() ;
+ private:
+ std::string message ;
+ } ;
+
+ static SEXP run(SEXP expr) throw(eval_error) ;
+ static SEXP run(SEXP expr, SEXP env) throw(eval_error) ;
};
} // namespace Rcpp
Modified: pkg/src/Rcpp/Function.h
===================================================================
--- pkg/src/Rcpp/Function.h 2010-01-13 10:01:52 UTC (rev 372)
+++ pkg/src/Rcpp/Function.h 2010-01-14 21:00:22 UTC (rev 373)
@@ -47,18 +47,6 @@
} ;
/**
- * exception generated when a function calls generates an R error
- */
- class eval_error : public std::exception{
- public:
- eval_error(const RObject& err) throw() ;
- ~eval_error() throw() ;
- const char* what() throw() ;
- private:
- std::string message ;
- } ;
-
- /**
* Attempts to convert the SEXP to a pair list
*
* @throw not_compatible if the SEXP could not be converted
@@ -77,16 +65,8 @@
*/
#ifdef HAS_VARIADIC_TEMPLATES
template<typename... Args>
- SEXP operator()( const Args&... args) throw(eval_error){
-
- /* FIXME: we should use applyClosure instead */
- Evaluator evaluator( Rf_lcons( m_sexp, pairlist(args...) ) ) ;
- evaluator.run() ;
- if( evaluator.successfull() ){
- return evaluator.getResult() ;
- } else{
- throw eval_error( evaluator.getError() );
- }
+ SEXP operator()( const Args&... args) throw(Evaluator::eval_error){
+ return Evaluator::run( Rf_lcons( m_sexp, pairlist(args...) ) ) ;
}
#endif
More information about the Rcpp-commits
mailing list