[Rcpp-commits] r3546 - in pkg/Rcpp: . R inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 24 15:03:21 CET 2012
Author: romain
Date: 2012-03-24 15:03:21 +0100 (Sat, 24 Mar 2012)
New Revision: 3546
Modified:
pkg/Rcpp/ChangeLog
pkg/Rcpp/R/exceptions.R
pkg/Rcpp/R/zzz.R
pkg/Rcpp/inst/include/Rcpp/cache.h
pkg/Rcpp/src/Evaluator.cpp
pkg/Rcpp/src/Rcpp_init.c
pkg/Rcpp/src/cache.cpp
Log:
using tryCatch instead of rcpp_tryCatch, no more .Internal use
Modified: pkg/Rcpp/ChangeLog
===================================================================
--- pkg/Rcpp/ChangeLog 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/ChangeLog 2012-03-24 14:03:21 UTC (rev 3546)
@@ -1,3 +1,10 @@
+2012-03-24 Romain Francois <romain at r-enthusiasts.com>
+
+ * src/cache.cpp: Using a single Rcpp_cache, stored in the Rcpp namespace
+
+ * src/Evaluator.cpp: Using tryCatch instead of rcpp_tryCatch, no more using .Internal
+
+
2012-03-23 Dirk Eddelbuettel <edd at debian.org>
* inst/doc/Rcpp-FAQ/Rcpp-FAQ.Rnw: Added short subsection on how to
Modified: pkg/Rcpp/R/exceptions.R
===================================================================
--- pkg/Rcpp/R/exceptions.R 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/R/exceptions.R 2012-03-24 14:03:21 UTC (rev 3546)
@@ -15,6 +15,7 @@
# You should have received a copy of the GNU General Public License
# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+.rcpp_cache <- NULL
cpp_exception <- function( message = "C++ exception", class = NULL, cppstack = rcpp_get_current_stack_trace() ){
callstack <- sys.calls()
ncalls <- length(callstack)
@@ -46,49 +47,9 @@
# Evaluator::run
getCurrentErrorMessage <- function() conditionMessage( getCurrentError() )
-errorOccured <- function() getErrorOccured()
-.rcpp_error_recorder <- function(e){
+.rcpp_error_recorder <- function(e){
invisible( .Call( rcpp_error_recorder, e ) )
}
-# simplified version of base::tryCatch
-rcpp_tryCatch <- function(expr, unused){ # unused is kept for compatibility, but is indeed not used
- .Call(reset_current_error)
- rcpp_doTryCatch <- function(expr, env) {
- .Internal(.addCondHands("error", list(.rcpp_error_recorder), env, environment(), FALSE))
- ## dot.int.ernal <- get( paste( '.Int', 'ernal', sep=''), baseenv())
- ## dot.add.cond.hands <- get( paste( '.add', 'Cond', 'Hands', sep=''), baseenv()) -- never found :-/
- ## dot.int.ernal(.Call("addcondhands", "error", list(.rcpp_error_recorder), env, environment(), FALSE))
- expr
- }
- parentenv <- parent.frame()
- value <- rcpp_doTryCatch( return(expr), parentenv )
- if (is.null(value[[1L]])) {
- ## a simple error; message is stored internally
- ## and call is in result; this defers all allocs until
- ## after the jump
- msg <- geterrmessage()
- call <- value[[2L]]
- cond <- simpleError(msg, call)
- }
- else cond <- value[[1L]]
- .rcpp_error_recorder(cond)
-}
-## rcpp_tryCatch <- function(expr){
-## .Call(reset_current_error)
-## value <- withCallingHandlers( return(expr), error = .rcpp_error_recorder )
-## if (is.null(value[[1L]])) {
-## # a simple error; message is stored internally
-## # and call is in result; this defers all allocs until
-## # after the jump
-## msg <- geterrmessage()
-## call <- value[[2L]]
-## cond <- simpleError(msg, call)
-## }
-## else cond <- value[[1L]]
-## .rcpp_error_recorder(cond)
-## }
-
-
Modified: pkg/Rcpp/R/zzz.R
===================================================================
--- pkg/Rcpp/R/zzz.R 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/R/zzz.R 2012-03-24 14:03:21 UTC (rev 3546)
@@ -20,9 +20,6 @@
.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
-# .Call("init_Rcpp_cache", PACKAGE = "Rcpp" )
minimum_svn_rev <- packageDescription( pkgname )[["MinimumSvnRev"]]
# if( as.integer(R.version[["svn rev"]]) < as.integer(minimum_svn_rev)){
# packageStartupMessage(gettextf(paste("R version (%s) older than minimum required (%s)",
Modified: pkg/Rcpp/inst/include/Rcpp/cache.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/cache.h 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/inst/include/Rcpp/cache.h 2012-03-24 14:03:21 UTC (rev 3546)
@@ -26,8 +26,6 @@
namespace internal{
SEXP get_Rcpp_namespace() ;
- SEXP get_rcpptrycatch() ;
- SEXP get_evalq() ;
}
}
Modified: pkg/Rcpp/src/Evaluator.cpp
===================================================================
--- pkg/Rcpp/src/Evaluator.cpp 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/src/Evaluator.cpp 2012-03-24 14:03:21 UTC (rev 3546)
@@ -21,43 +21,45 @@
#include <Rcpp/Evaluator.h>
-void maybe_init() ;
-
namespace Rcpp {
SEXP Evaluator::run(SEXP expr, SEXP env) {
PROTECT(expr);
- maybe_init() ;
reset_current_error() ;
Environment RCPP = Environment::Rcpp_namespace();
- static SEXP rcpp_tryCatchSym = NULL, evalqSym, errorOccuredSym, getCurrentErrorMessageSym;
- if (!rcpp_tryCatchSym) {
- rcpp_tryCatchSym = ::Rf_install("rcpp_tryCatch");
+ static SEXP tryCatchSym = NULL, evalqSym, errorOccuredSym, getCurrentErrorMessageSym;
+ if (!tryCatchSym) {
+ tryCatchSym = ::Rf_install("tryCatch");
evalqSym = ::Rf_install("evalq");
errorOccuredSym = ::Rf_install("errorOccured");
getCurrentErrorMessageSym = ::Rf_install("getCurrentErrorMessage");
}
- SEXP call = PROTECT(::Rf_lang2(rcpp_tryCatchSym, PROTECT(::Rf_lang3(evalqSym, expr, env))));
+ SEXP call = PROTECT( Rf_lang3(
+ tryCatchSym,
+ Rf_lang3( evalqSym, expr, env ),
+ Rf_install( ".rcpp_error_recorder" )
+ ) ) ;
+ SET_TAG( CDDR(call), Rf_install( "error" ) ) ;
/* call the tryCatch call */
SEXP res = PROTECT(::Rf_eval( call, RCPP ) );
/* was there an error ? */
- int error = ::Rf_asLogical(PROTECT(::Rf_eval(PROTECT(::Rf_lang1(errorOccuredSym)), RCPP)));
- UNPROTECT(2) ;
+ int error = INTEGER( rcpp_get_error_occured())[0] ;
+ UNPROTECT(3) ;
+
if( error ) {
std::string
message(CHAR(::Rf_asChar(PROTECT(::Rf_eval(
PROTECT(::Rf_lang1(getCurrentErrorMessageSym)),
RCPP)))));
- UNPROTECT( 6 ) ;
+ UNPROTECT( 2 ) ;
throw eval_error(message) ;
}
- UNPROTECT(4) ;
return res ;
}
Modified: pkg/Rcpp/src/Rcpp_init.c
===================================================================
--- pkg/Rcpp/src/Rcpp_init.c 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/src/Rcpp_init.c 2012-03-24 14:03:21 UTC (rev 3546)
@@ -56,8 +56,6 @@
CALLDEF(Module__get_function, 2),
CALLDEF(get_rcpp_cache,0),
-// CALLDEF(init_Rcpp_cache,0),
- CALLDEF(reset_current_error,0),
CALLDEF(rcpp_error_recorder,1),
CALLDEF(rcpp_set_current_error,1),
CALLDEF(rcpp_get_current_error,0),
Modified: pkg/Rcpp/src/cache.cpp
===================================================================
--- pkg/Rcpp/src/cache.cpp 2012-03-24 13:56:07 UTC (rev 3545)
+++ pkg/Rcpp/src/cache.cpp 2012-03-24 14:03:21 UTC (rev 3546)
@@ -21,68 +21,64 @@
#include <Rcpp.h>
+static bool Rcpp_cache_know = false ;
static SEXP Rcpp_cache = R_NilValue ;
-static bool Rcpp_cache_ready = false ;
-
-void maybe_init() {
- if( ! Rcpp_cache_ready ) init_Rcpp_cache() ;
-}
+SEXP reset_current_error__(SEXP) ;
+
namespace Rcpp {
namespace internal {
SEXP get_Rcpp_namespace(){
- maybe_init() ; return VECTOR_ELT( Rcpp_cache , 0 ) ;
+ return VECTOR_ELT( Rcpp_cache , 0 ) ;
}
- SEXP get_rcpptrycatch(){
- // maybe_init() ; return VECTOR_ELT( Rcpp_cache, 4 ) ;
- return Rf_install("rcpp_tryCatch") ; // maybe not worth assigning to SEXP
- }
- SEXP get_evalq(){
- // maybe_init() ; return VECTOR_ELT( Rcpp_cache, 5 ) ;
- return Rf_install("evalq"); // maybe not worth assigning to SEXP
- }
}
}
// only used for debugging
-SEXP get_rcpp_cache() { return Rcpp_cache ; }
+SEXP get_rcpp_cache() {
+ if( ! Rcpp_cache_know ){
+ SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
+ SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
+
+ Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
+ Rcpp_cache_know = true ;
+ UNPROTECT(1) ;
+ }
+ return Rcpp_cache ;
+}
SEXP init_Rcpp_cache(){
- Rcpp_cache = PROTECT( Rf_allocVector( VECSXP, 10 ) );
-
- // the Rcpp namespace
- SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
+ SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
- SET_VECTOR_ELT( Rcpp_cache, 0, RCPP ) ;
- reset_current_error() ;
- // SET_VECTOR_ELT( Rcpp_cache, 4, Rf_install("rcpp_tryCatch") ) ;
- // SET_VECTOR_ELT( Rcpp_cache, 5, Rf_install("evalq") ) ;
+ SEXP cache = PROTECT( Rf_allocVector( VECSXP, 10 ) );
+
+ // the Rcpp namespace
+ SET_VECTOR_ELT( cache, 0, RCPP ) ;
+ reset_current_error__(cache) ;
- R_PreserveObject( Rcpp_cache ) ;
- UNPROTECT(2) ;
- Rcpp_cache_ready = true ;
- return Rcpp_cache ;
+ Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
+
+ UNPROTECT(2) ;
+ return cache ;
}
-SEXP reset_current_error(){
+SEXP reset_current_error__(SEXP cache){
- // error occured
- SET_VECTOR_ELT( Rcpp_cache, 1, Rf_ScalarLogical(FALSE) ) ;
+ SET_VECTOR_ELT( cache, 1, Rf_ScalarLogical(FALSE) ) ;
// current error
- SET_VECTOR_ELT( Rcpp_cache, 2, R_NilValue ) ;
+ SET_VECTOR_ELT( cache, 2, R_NilValue ) ;
// stack trace
- SET_VECTOR_ELT( Rcpp_cache, 3, R_NilValue ) ;
+ SET_VECTOR_ELT( cache, 3, R_NilValue ) ;
return R_NilValue ;
}
+SEXP reset_current_error(){ return reset_current_error__( get_rcpp_cache() ) ; }
-SEXP rcpp_error_recorder(SEXP e){
- maybe_init() ;
-
+SEXP rcpp_error_recorder(SEXP e, SEXP cache){
// error occured
- SET_VECTOR_ELT( Rcpp_cache, 1, Rf_ScalarLogical(TRUE) ) ;
+ SET_VECTOR_ELT( cache, 1, Rf_ScalarLogical(TRUE) ) ;
// current error
rcpp_set_current_error(e ) ;
@@ -90,31 +86,33 @@
return R_NilValue ;
}
+SEXP rcpp_error_recorder(SEXP e){ return rcpp_error_recorder(e, get_rcpp_cache() ) ;}
-SEXP rcpp_set_current_error(SEXP e){
- SET_VECTOR_ELT( Rcpp_cache, 2, e ) ;
+SEXP rcpp_set_current_error(SEXP e, SEXP cache){
+ SET_VECTOR_ELT( cache, 2, e ) ;
return R_NilValue ;
}
+SEXP rcpp_set_current_error(SEXP e){ return rcpp_set_current_error(e, get_rcpp_cache() ) ; }
SEXP rcpp_get_current_error(){
- return VECTOR_ELT( Rcpp_cache, 2 ) ;
+ return VECTOR_ELT( get_rcpp_cache(), 2 ) ;
}
SEXP rcpp_set_error_occured(SEXP e){
- SET_VECTOR_ELT( Rcpp_cache, 1, e ) ;
+ SET_VECTOR_ELT( get_rcpp_cache(), 1, e ) ;
return R_NilValue ;
}
SEXP rcpp_get_error_occured(){
- return VECTOR_ELT( Rcpp_cache, 1 ) ;
+ return VECTOR_ELT( get_rcpp_cache(), 1 ) ;
}
SEXP rcpp_set_stack_trace(SEXP e){
- SET_VECTOR_ELT( Rcpp_cache, 3, e ) ;
+ SET_VECTOR_ELT( get_rcpp_cache(), 3, e ) ;
return R_NilValue ;
}
SEXP rcpp_get_stack_trace(){
- return VECTOR_ELT( Rcpp_cache, 3 ) ;
+ return VECTOR_ELT( get_rcpp_cache(), 3 ) ;
}
More information about the Rcpp-commits
mailing list