[Rcpp-devel] [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
 	

_______________________________________________
Rcpp-commits mailing list
Rcpp-commits at lists.r-forge.r-project.org
https://lists.r-forge.r-project.org/cgi-bin/mailman/listinfo/rcpp-commits


More information about the Rcpp-devel mailing list