[Rcpp-devel] [Rcpp-commits] r215 - in pkg: R inst inst/examples/RcppInline src

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sun Dec 27 18:15:21 CET 2009


Author: romain
Date: 2009-12-27 18:15:20 +0100 (Sun, 27 Dec 2009)
New Revision: 215

Added:
   pkg/R/exceptions.R
   pkg/R/zzz.R
   pkg/inst/examples/RcppInline/UncaughtExceptions.r
Modified:
   pkg/inst/ChangeLog
   pkg/inst/examples/RcppInline/RcppSexpTests.r
   pkg/src/RcppCommon.cpp
   pkg/src/RcppCommon.h
   pkg/src/RcppSexp.cpp
   pkg/src/RcppSexp.h
Log:
added experimental uncaught exception handling

Added: pkg/R/exceptions.R
===================================================================
--- pkg/R/exceptions.R	                        (rev 0)
+++ pkg/R/exceptions.R	2009-12-27 17:15:20 UTC (rev 215)
@@ -0,0 +1,28 @@
+# Copyright (C)        2009 Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+uncaught_cpp_exception <- function( message = "uncaught C++ exception" ){
+	callstack <- sys.calls()
+	ncalls <- length(callstack)
+	call <- if( ncalls > 1L) callstack[[ ncalls - 1L ]] else match.call()
+	classes <- c( "C++Error", "error", "condition" )
+	condition <- structure( 
+		list( message = message, call = call ), 
+		class = classes )
+	stop( condition )
+}
+

Added: pkg/R/zzz.R
===================================================================
--- pkg/R/zzz.R	                        (rev 0)
+++ pkg/R/zzz.R	2009-12-27 17:15:20 UTC (rev 215)
@@ -0,0 +1,20 @@
+# Copyright (C)        2009 Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+.onAttach <- function(libname, pkgname){
+	.Call( "initUncaughtExceptionHandler", PACKAGE = pkgname )
+}

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/inst/ChangeLog	2009-12-27 17:15:20 UTC (rev 215)
@@ -1,5 +1,14 @@
 2009-12-27  Romain Francois <francoisromain at free.fr>
 	
+	* src/RcppCommon.{h,cpp} : added experimental uncaught exception
+	management
+	
+	* R/zzz.R : added .onAttach, used to register the uncaught exception
+	management on package attach
+	
+	* R/exceptions.R : added R side of the exception management, unexported
+	as it is only used by internal C++ code
+	
 	* src/RcppSexp.{h,cpp} : added method isNULL to test if the 
 	underlying SEXP is NULL
 	

Modified: pkg/inst/examples/RcppInline/RcppSexpTests.r
===================================================================
--- pkg/inst/examples/RcppInline/RcppSexpTests.r	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/inst/examples/RcppInline/RcppSexpTests.r	2009-12-27 17:15:20 UTC (rev 215)
@@ -1,4 +1,22 @@
 #!/usr/bin/r -t
+#
+# Copyright (C) 2009 Dirk Eddelbuettel
+# Copyright (C) 2009 Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
 suppressMessages(library(Rcpp))
 

Added: pkg/inst/examples/RcppInline/UncaughtExceptions.r
===================================================================
--- pkg/inst/examples/RcppInline/UncaughtExceptions.r	                        (rev 0)
+++ pkg/inst/examples/RcppInline/UncaughtExceptions.r	2009-12-27 17:15:20 UTC (rev 215)
@@ -0,0 +1,30 @@
+#!/usr/bin/r -t
+#
+# Copyright (C) 2009 Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
+
+require( Rcpp)
+funx <- cfunction(signature(), '
+throw std::range_error("boom") ;
+return R_NilValue ;
+', Rcpp=TRUE, verbose=FALSE)
+tryCatch(  funx(), "C++Error" = function(e){
+	print( "gotcha" )
+} )
+print( rnorm(10) )
+
+

Modified: pkg/src/RcppCommon.cpp
===================================================================
--- pkg/src/RcppCommon.cpp	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/src/RcppCommon.cpp	2009-12-27 17:15:20 UTC (rev 215)
@@ -39,3 +39,19 @@
 inline void logTxtFunction(const char* file, const int line, const char* expression) {
     Rprintf("%s:%d %s\n", file, line, expression);
 }
+
+void forward_uncaught_exceptions_to_r(){
+	/* we don't bother unprotecting */
+	SEXP m = PROTECT( Rf_mkString( "uncaught C++ exception" ) ) ;
+	SEXP call = PROTECT( Rf_lang2( Rf_install("uncaught_cpp_exception"), m ) ) ;
+	Rf_eval( call, R_FindNamespace(Rf_mkString("Rcpp")) ) ; 
+	
+	/* but this is never actually called since the call eventually calls stop */
+	UNPROTECT(1);
+}
+SEXP initUncaughtExceptionHandler(){
+	void (*old_terminate)() = std::set_terminate(forward_uncaught_exceptions_to_r);
+	return R_NilValue ;
+}
+
+

Modified: pkg/src/RcppCommon.h
===================================================================
--- pkg/src/RcppCommon.h	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/src/RcppCommon.h	2009-12-27 17:15:20 UTC (rev 215)
@@ -4,6 +4,7 @@
 //
 // Copyright (C) 2005 - 2006 Dominick Samperi
 // Copyright (C) 2008 - 2009 Dirk Eddelbuettel
+// Copyright (C)        2009 Romain Francois
 //
 // This file is part of Rcpp.
 //
@@ -23,6 +24,7 @@
 #ifndef RcppCommon_h
 #define RcppCommon_h
 
+#include <exception>
 #include <iostream>
 #include <sstream>
 #include <string>
@@ -51,4 +53,7 @@
 //#define logTxt(x) logTxtFunction(__FILE__, __LINE__, x);
 #define logTxt(x) 
 
+void forward_uncaught_exceptions_to_r() ;
+RcppExport SEXP initUncaughtExceptionHandler() ; 
+
 #endif

Modified: pkg/src/RcppSexp.cpp
===================================================================
--- pkg/src/RcppSexp.cpp	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/src/RcppSexp.cpp	2009-12-27 17:15:20 UTC (rev 215)
@@ -3,6 +3,7 @@
 // RcppSexp.h: Rcpp R/C++ interface class library -- SEXP support
 //
 // Copyright (C) 2009 Dirk Eddelbuettel
+// Copyright (C) 2009 Romain Francois
 //
 // This file is part of Rcpp.
 //

Modified: pkg/src/RcppSexp.h
===================================================================
--- pkg/src/RcppSexp.h	2009-12-27 16:23:08 UTC (rev 214)
+++ pkg/src/RcppSexp.h	2009-12-27 17:15:20 UTC (rev 215)
@@ -3,6 +3,7 @@
 // RcppSexp.h: Rcpp R/C++ interface class library -- SEXP support
 //
 // Copyright (C) 2009 Dirk Eddelbuettel
+// Copyright (C) 2009 Romain Francois
 //
 // This file is part of Rcpp.
 //

_______________________________________________
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