[Rcpp-commits] r4158 - in pkg/Rcpp: . R inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Dec 15 21:03:15 CET 2012
Author: romain
Date: 2012-12-15 21:03:15 +0100 (Sat, 15 Dec 2012)
New Revision: 4158
Modified:
pkg/Rcpp/ChangeLog
pkg/Rcpp/R/exceptions.R
pkg/Rcpp/inst/include/Rcpp/exceptions.h
pkg/Rcpp/src/api.cpp
pkg/Rcpp/src/exceptions.cpp
Log:
new impl of forward_exception_to_r
Modified: pkg/Rcpp/ChangeLog
===================================================================
--- pkg/Rcpp/ChangeLog 2012-12-13 23:45:44 UTC (rev 4157)
+++ pkg/Rcpp/ChangeLog 2012-12-15 20:03:15 UTC (rev 4158)
@@ -1,3 +1,9 @@
+2012-12-15 Romain Francois <romain at r-enthusiasts.com>
+
+ * include/Rcpp/exceptions.h: added exception_to_r_condition
+ * exceptions.cpp: new implementation of forward_exception_to_r that
+ directly calls stop rather than a function in Rcpp
+
2012-12-14 Romain Francois <romain at r-enthusiasts.com>
* include/Rcpp/sugar/functions/clamp.h: clamp was pretty wrong
Modified: pkg/Rcpp/R/exceptions.R
===================================================================
--- pkg/Rcpp/R/exceptions.R 2012-12-13 23:45:44 UTC (rev 4157)
+++ pkg/Rcpp/R/exceptions.R 2012-12-15 20:03:15 UTC (rev 4158)
@@ -15,7 +15,6 @@
# 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)
Modified: pkg/Rcpp/inst/include/Rcpp/exceptions.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/exceptions.h 2012-12-13 23:45:44 UTC (rev 4157)
+++ pkg/Rcpp/inst/include/Rcpp/exceptions.h 2012-12-15 20:03:15 UTC (rev 4158)
@@ -128,6 +128,7 @@
void forward_exception_to_r( const std::exception& ) ;
SEXP exception_to_try_error( const std::exception& ) ;
+SEXP exception_to_r_condition( const std::exception& ) ;
SEXP string_to_try_error( const std::string& ) ;
std::string demangle( const std::string& name) ;
Modified: pkg/Rcpp/src/api.cpp
===================================================================
--- pkg/Rcpp/src/api.cpp 2012-12-13 23:45:44 UTC (rev 4157)
+++ pkg/Rcpp/src/api.cpp 2012-12-15 20:03:15 UTC (rev 4158)
@@ -106,7 +106,7 @@
// }}}
// {{{ RObject
- void RObject::setSEXP(SEXP x){
+ void RObject::setSEXP(SEXP x){
RCPP_DEBUG_1( "RObject::setSEXP(SEXP = <%p> )", x ) ;
/* if we are setting to the same SEXP as we already have, do nothing */
@@ -1153,6 +1153,30 @@
}
// }}}
+// {{{ demangling
+#ifdef RCPP_HAS_DEMANGLING
+#include <cxxabi.h>
+
+std::string demangle( const std::string& name ){
+ std::string real_class ;
+ int status =-1 ;
+ char *dem = 0;
+ dem = abi::__cxa_demangle(name.c_str(), 0, 0, &status);
+ if( status == 0 ){
+ real_class = dem ;
+ free(dem);
+ } else {
+ real_class = name ;
+ }
+ return real_class ;
+}
+#else
+std::string demangle( const std::string& name ){
+ return name ;
+}
+#endif
+// }}}
+
// {{{ utilities (from RcppCommon.cpp)
SEXP rcpp_can_use_cxx0x(){
#ifdef HAS_VARIADIC_TEMPLATES
Modified: pkg/Rcpp/src/exceptions.cpp
===================================================================
--- pkg/Rcpp/src/exceptions.cpp 2012-12-13 23:45:44 UTC (rev 4157)
+++ pkg/Rcpp/src/exceptions.cpp 2012-12-15 20:03:15 UTC (rev 4158)
@@ -67,77 +67,60 @@
#undef RCPP_SIMPLE_EXCEPTION_WHAT
}
+
+SEXP get_last_call(){
+ SEXP sys_calls_symbol = Rf_install( "sys.calls" ) ;
+ SEXP sys_calls_expr = PROTECT( Rf_lang1(sys_calls_symbol) ) ;
+ SEXP calls = PROTECT( Rf_eval( sys_calls_expr, R_GlobalEnv ) ) ;
+ SEXP res = calls ;
+ while( !Rf_isNull(CDR(res)) ) res = CDR(res);
+ UNPROTECT(2);
+ return CAR(res) ;
+}
-// for now, the fancy exception handling is only available in GCC,
-// simply because we've not investigated if it is available in other
-// compilers
-#ifdef RCPP_HAS_DEMANGLING
-#include <typeinfo>
-#if defined(__GNUC__) && !defined(__clang__)
- #ifdef IS_EARLIER_THAN_GCC_460
- #include <exception_defines.h>
- #endif
- #ifdef IS_GCC_460_OR_LATER
- #include <bits/exception_defines.h>
- #endif
-#endif
-#ifdef __clang__
- #if __has_include(<exception_defines.h>)
- #include <exception_defines.h>
- #elif __has_include(<bits/exception_defines.h>)
- #include <bits/exception_defines.h>
- #else
- #error clang could not find <exception_defines.h>
- #endif
-#endif
-#include <cxxabi.h>
+SEXP get_exception_classes( const std::string& ex_class) {
+ SEXP res = PROTECT( Rf_allocVector( STRSXP, 4 ) );
+ SET_STRING_ELT( res, 0, Rf_mkChar( ex_class.c_str() ) ) ;
+ SET_STRING_ELT( res, 1, Rf_mkChar( "C++Error" ) ) ;
+ SET_STRING_ELT( res, 2, Rf_mkChar( "error" ) ) ;
+ SET_STRING_ELT( res, 3, Rf_mkChar( "condition" ) ) ;
+ UNPROTECT(1) ;
+ return res;
+}
-std::string demangle( const std::string& name ){
- std::string real_class ;
- int status =-1 ;
- char *dem = 0;
- dem = abi::__cxa_demangle(name.c_str(), 0, 0, &status);
- if( status == 0 ){
- real_class = dem ;
- free(dem);
- } else {
- real_class = name ;
- }
- return real_class ;
+SEXP make_condition(const std::string& ex_msg, SEXP call, SEXP cppstack, SEXP classes){
+ SEXP res = PROTECT( Rf_allocVector( VECSXP, 3 ) ) ;
+ SEXP message = PROTECT( Rf_mkString( ex_msg.c_str() ) ) ;
+ SET_VECTOR_ELT( res, 0, message ) ;
+ SET_VECTOR_ELT( res, 1, call ) ;
+ SET_VECTOR_ELT( res, 2, cppstack ) ;
+ SEXP names = PROTECT( Rf_allocVector( STRSXP, 3 ) ) ;
+ SET_STRING_ELT( names, 0, Rf_mkChar( "message" ) ) ;
+ SET_STRING_ELT( names, 1, Rf_mkChar( "call" ) ) ;
+ SET_STRING_ELT( names, 2, Rf_mkChar( "cppstack" ) ) ;
+ Rf_setAttrib( res, R_NamesSymbol, names ) ;
+ Rf_setAttrib( res, R_ClassSymbol, classes ) ;
+ UNPROTECT(3) ;
+ return res ;
}
-void forward_exception_to_r( const std::exception& ex){
- std::string exception_class ;
- std::string exception_what = ex.what();
- const char *name = typeid(ex).name() ;
- // now we need to demangle "name"
- {
- int status = -1;
- char *dem = 0;
- dem = abi::__cxa_demangle(name, 0, 0, &status);
- if( status == 0){
- exception_class = dem ; /* great we can use the demangled name */
- free(dem);
- } else{
- exception_class = name ; /* just using the mangled name */
- }
- }
- SEXP cppExceptSym = Rf_install("cpp_exception"); // cannot cause a gc() once in symbol table
- SEXP cppExceptExpr = PROTECT(Rf_lang3(cppExceptSym,
- Rf_mkString(exception_what.c_str()),
- Rf_mkString(exception_class.c_str())));
- Rf_eval(cppExceptExpr, R_FindNamespace(Rf_mkString("Rcpp"))); // Should not return
- UNPROTECT(1); // in case someone replaces the definition of "cpp_exception" such that it does return
+SEXP exception_to_r_condition( const std::exception& ex){
+ std::string ex_class = demangle( typeid(ex).name() ) ;
+ std::string ex_msg = ex.what() ;
+
+ SEXP cppstack = PROTECT( rcpp_get_stack_trace() ) ;
+ SEXP call = PROTECT( get_last_call() ) ;
+ SEXP classes = PROTECT( get_exception_classes(ex_class) ) ;
+ SEXP condition = PROTECT( make_condition( ex_msg, call, cppstack, classes ) ) ;
+ rcpp_set_stack_trace( R_NilValue ) ;
+ UNPROTECT(4) ;
+ return condition ;
}
-#else
void forward_exception_to_r( const std::exception& ex){
- SEXP cppExceptSym = Rf_install("cpp_exception"); // cannot cause a gc() once in symbol table
- SEXP cppExceptExpr = PROTECT(Rf_lang3(cppExceptSym, Rf_mkString(ex.what()), R_NilValue));
- Rf_eval(cppExceptExpr, R_FindNamespace(Rf_mkString("Rcpp"))); // Should not return
- UNPROTECT(1); // in case someone replaces the definition of "cpp_exception" such that it does return
+ SEXP condition = PROTECT(exception_to_r_condition(ex)) ;
+ SEXP stop_sym = Rf_install( "stop" ) ;
+ SEXP expr = PROTECT( Rf_lang2( stop_sym , condition ) );
+ UNPROTECT(2) ;
+ Rf_eval( expr, R_GlobalEnv ) ;
}
-std::string demangle( const std::string& name ){
- return name ;
-}
-#endif
More information about the Rcpp-commits
mailing list