[Rcpp-commits] r2285 - in pkg/Rcpp: R inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Oct 7 14:27:18 CEST 2010
Author: romain
Date: 2010-10-07 14:27:18 +0200 (Thu, 07 Oct 2010)
New Revision: 2285
Modified:
pkg/Rcpp/R/exceptions.R
pkg/Rcpp/R/zzz.R
pkg/Rcpp/inst/include/Rcpp/cache.h
pkg/Rcpp/src/Environment.cpp
pkg/Rcpp/src/cache.cpp
pkg/Rcpp/src/exceptions.cpp
Log:
take a few more things internal
Modified: pkg/Rcpp/R/exceptions.R
===================================================================
--- pkg/Rcpp/R/exceptions.R 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/R/exceptions.R 2010-10-07 12:27:18 UTC (rev 2285)
@@ -28,32 +28,28 @@
}
# used by Rcpp::Evaluator
-exceptions <- new.env()
-setCurrentError <- function( condition = NULL) exceptions[["current"]] <- condition
-resetCurrentError <- function() {
- setCurrentError(NULL)
- setErrorOccured(FALSE)
-}
-getCurrentError <- function() exceptions[["current"]]
-setErrorOccured <- function(error_occured = TRUE) exceptions[["error_occured"]] <- error_occured
-setErrorOccured(FALSE)
+setCurrentError <- function( condition = NULL) .Call( "rcpp_set_current_error", condition, PACKAGE = "Rcpp" )
+getCurrentError <- function() .Call( "rcpp_get_current_error", PACKAGE = "Rcpp" )
+setErrorOccured <- function(error_occured = TRUE) .Call( "rcpp_set_error_occured", error_occured, PACKAGE = "Rcpp" )
+getErrorOccured <- function() .Call( "rcpp_get_error_occured", PACKAGE = "Rcpp" )
+
+setStackTrace <- function(trace = TRUE) .Call( "rcpp_set_stack_trace", trace, PACKAGE = "Rcpp" )
+getStackTrace <- function() .Call( "rcpp_get_stack_trace", PACKAGE = "Rcpp" )
+
# all below are called from Evaluator::run
# on the C++ side, don't change them unless you also change
# Evaluator::run
-getCurrentErrorMessage <- function() conditionMessage( exceptions[["current"]] )
-resetCurrentError()
-errorOccured <- function() isTRUE( exceptions[["error_occured"]] )
+getCurrentErrorMessage <- function() conditionMessage( getCurrentError() )
+errorOccured <- function() getErrorOccured()
.rcpp_error_recorder <- function(e){
- setErrorOccured( TRUE )
- setCurrentError( e )
- invisible( NULL )
+ invisible( .Call( "rcpp_error_recorder", e, PACKAGE = "Rcpp" ) )
}
# simplified version of utils::tryCatch
rcpp_tryCatch <- function(expr, unused){ # unused is kept for compatibility, but is indeed not used
- resetCurrentError()
+ .Call("reset_current_error", PACKAGE = "Rcpp")
rcpp_doTryCatch <- function(expr, env) {
.Internal(.addCondHands("error", list(.rcpp_error_recorder),
env, environment(), FALSE))
@@ -73,12 +69,3 @@
.rcpp_error_recorder(cond)
}
-rcpp_set_current_stack_trace <- function( trace ){
- exceptions[["stack_trace"]] <- trace
-}
-rcpp_get_current_stack_trace <- function(){
- exceptions[["stack_trace"]]
-}
-rcpp_set_current_stack_trace( NULL )
-
-
Modified: pkg/Rcpp/R/zzz.R
===================================================================
--- pkg/Rcpp/R/zzz.R 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/R/zzz.R 2010-10-07 12:27:18 UTC (rev 2285)
@@ -17,6 +17,7 @@
.onLoad <- function(libname, pkgname){
install_help_workaround()
+ .Call("reset_current_error", PACKAGE = "Rcpp" )
minimum_svn_rev <- packageDescription( pkgname )[["MinimumSvnRev"]]
if( as.integer(R.version[["svn rev"]]) < as.integer(minimum_svn_rev)){
Modified: pkg/Rcpp/inst/include/Rcpp/cache.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/cache.h 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/inst/include/Rcpp/cache.h 2010-10-07 12:27:18 UTC (rev 2285)
@@ -32,6 +32,14 @@
extern "C" SEXP get_rcpp_cache() ;
extern "C" SEXP init_Rcpp_cache() ;
-extern "C" SEXP maybe_init() ;
+extern "C" void maybe_init() ;
+extern "C" SEXP reset_current_error() ;
+extern "C" SEXP rcpp_error_recorder(SEXP) ;
+extern "C" SEXP rcpp_set_current_error(SEXP) ;
+extern "C" SEXP rcpp_get_current_error() ;
+extern "C" SEXP rcpp_set_error_occured(SEXP) ;
+extern "C" SEXP rcpp_get_error_occured() ;
+extern "C" SEXP rcpp_set_stack_trace(SEXP) ;
+extern "C" SEXP rcpp_get_stack_trace() ;
#endif
Modified: pkg/Rcpp/src/Environment.cpp
===================================================================
--- pkg/Rcpp/src/Environment.cpp 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/src/Environment.cpp 2010-10-07 12:27:18 UTC (rev 2285)
@@ -259,7 +259,6 @@
}
Environment Environment::Rcpp_namespace() throw() {
- // return Environment( Rf_eval( Rf_lcons( Rf_install("getNamespace"), Rf_cons( Rf_mkString("Rcpp") , R_NilValue) ), R_GlobalEnv ) ) ;
return Rcpp::internal::get_Rcpp_namespace() ;
}
Modified: pkg/Rcpp/src/cache.cpp
===================================================================
--- pkg/Rcpp/src/cache.cpp 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/src/cache.cpp 2010-10-07 12:27:18 UTC (rev 2285)
@@ -27,8 +27,7 @@
namespace Rcpp{
namespace internal{
SEXP get_Rcpp_namespace(){
- maybe_init() ;
- return VECTOR_ELT( Rcpp_cache , 0 ) ;
+ maybe_init() ; return VECTOR_ELT( Rcpp_cache , 0 ) ;
}
}
@@ -37,18 +36,74 @@
// only used for debugging
SEXP get_rcpp_cache() { return Rcpp_cache ; }
-SEXP maybe_init() {
- if( ! Rcpp_cache_ready ) init_Rcpp_cache() ;
+void maybe_init() {
+ if( ! Rcpp_cache_ready ) init_Rcpp_cache() ;
}
SEXP init_Rcpp_cache(){
Rcpp_cache = PROTECT( Rf_allocVector( VECSXP, 10 ) );
// the Rcpp namespace
- SET_VECTOR_ELT( Rcpp_cache, 0, Rf_eval( Rf_lcons( Rf_install("getNamespace"), Rf_cons( Rf_mkString("Rcpp") , R_NilValue) ), R_GlobalEnv ) ) ;
- R_PreserveObject( Rcpp_cache ) ;
- UNPROTECT(1) ;
+ SEXP RCPP = PROTECT( Rf_eval( Rf_lcons( Rf_install("getNamespace"), Rf_cons( Rf_mkString("Rcpp") , R_NilValue) ), R_GlobalEnv ) ) ;
+ SET_VECTOR_ELT( Rcpp_cache, 0, RCPP ) ;
+ reset_current_error() ;
+
+ R_PreserveObject( Rcpp_cache ) ;
+ UNPROTECT(2) ;
Rcpp_cache_ready = true ;
return Rcpp_cache ;
}
+SEXP reset_current_error(){
+ // error occured
+ SET_VECTOR_ELT( Rcpp_cache, 1, Rf_ScalarLogical(FALSE) ) ;
+
+ // current error
+ SET_VECTOR_ELT( Rcpp_cache, 2, R_NilValue ) ;
+
+ // stack trace
+ SET_VECTOR_ELT( Rcpp_cache, 3, R_NilValue ) ;
+
+ return R_NilValue ;
+}
+
+SEXP rcpp_error_recorder(SEXP e){
+ maybe_init() ;
+
+ // error occured
+ SET_VECTOR_ELT( Rcpp_cache, 1, Rf_ScalarLogical(TRUE) ) ;
+
+ // current error
+ rcpp_set_current_error(e ) ;
+
+ return R_NilValue ;
+
+}
+
+SEXP rcpp_set_current_error(SEXP e){
+ SET_VECTOR_ELT( Rcpp_cache, 2, e ) ;
+ return R_NilValue ;
+}
+
+SEXP rcpp_get_current_error(){
+ return VECTOR_ELT( Rcpp_cache, 2 ) ;
+}
+
+SEXP rcpp_set_error_occured(SEXP e){
+ SET_VECTOR_ELT( Rcpp_cache, 1, e ) ;
+ return R_NilValue ;
+}
+
+SEXP rcpp_get_error_occured(){
+ return VECTOR_ELT( Rcpp_cache, 1 ) ;
+}
+
+SEXP rcpp_set_stack_trace(SEXP e){
+ SET_VECTOR_ELT( Rcpp_cache, 3, e ) ;
+ return R_NilValue ;
+}
+
+SEXP rcpp_get_stack_trace(){
+ return VECTOR_ELT( Rcpp_cache, 3 ) ;
+}
+
Modified: pkg/Rcpp/src/exceptions.cpp
===================================================================
--- pkg/Rcpp/src/exceptions.cpp 2010-10-07 11:41:56 UTC (rev 2284)
+++ pkg/Rcpp/src/exceptions.cpp 2010-10-07 12:27:18 UTC (rev 2285)
@@ -23,9 +23,7 @@
namespace Rcpp{
exception::exception( const char* message_, const char* file, int line) : message(message_){
- SEXP call = PROTECT( Rf_lang2( Rf_install("rcpp_set_current_stack_trace") , stack_trace(file,line) ) ) ;
- Rf_eval( call, R_FindNamespace( Rf_mkString( "Rcpp") ) ) ;
- UNPROTECT(1) ;
+ rcpp_set_stack_trace( stack_trace(file,line) ) ;
}
exception::~exception() throw(){}
More information about the Rcpp-commits
mailing list