[Rcpp-commits] r220 - in pkg: . inst inst/examples/RcppInline src

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Tue Dec 29 10:30:13 CET 2009


Author: romain
Date: 2009-12-29 10:30:12 +0100 (Tue, 29 Dec 2009)
New Revision: 220

Added:
   pkg/inst/examples/RcppInline/external_pointer.r
   pkg/src/RcppXPtr.h
Modified:
   pkg/DESCRIPTION
   pkg/inst/ChangeLog
   pkg/src/Rcpp.h
   pkg/src/RcppExample.cpp
   pkg/src/exception_handling.cpp
Log:
added smart external pointers template class RcppXPtr<typename T>

Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2009-12-28 11:23:31 UTC (rev 219)
+++ pkg/DESCRIPTION	2009-12-29 09:30:12 UTC (rev 220)
@@ -1,6 +1,6 @@
 Package: Rcpp
 Title: Rcpp R/C++ interface package
-Version: 0.7.0.3
+Version: 0.7.0.4
 Date: $Date$
 Author: Dirk Eddelbuettel and Romain Francois, with contributions 
  by Simon Urbanek and David Reiss; based on code written during 

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-28 11:23:31 UTC (rev 219)
+++ pkg/inst/ChangeLog	2009-12-29 09:30:12 UTC (rev 220)
@@ -1,3 +1,20 @@
+2009-12-29  Romain Francois <francoisromain at free.fr>
+
+	* src/RcppXPtr.h: new smart external pointer wrapper. The RcppXPtr 
+	template can be used to wrap a external pointer (SEXP) so that it 
+	looks like the dumb pointer it is wrapping (as far as the * and -> 
+	operator are concerned). The template parameter controls the type
+	of object that is wrapped by the pointer. 
+	
+	* src/Rcpp.h: importing the RcppXPtr.h header
+	
+	* src/RcppExample.cpp: added an example of RcppXPtr usage
+	
+	* inst/examples/RcppInline/external_pointer.r: added example using
+	the RcppXPtr template
+	
+	* DESCRIPTION: marking this as 0.7.0.4
+	
 2009-12-28  Romain Francois <francoisromain at free.fr>
 
 	* R/exceptions.R: s/uncaught_cpp_exception/cpp_exception/ and added a

Added: pkg/inst/examples/RcppInline/external_pointer.r
===================================================================
--- pkg/inst/examples/RcppInline/external_pointer.r	                        (rev 0)
+++ pkg/inst/examples/RcppInline/external_pointer.r	2009-12-29 09:30:12 UTC (rev 220)
@@ -0,0 +1,59 @@
+#!/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)
+require(inline)
+
+funx <- cfunction(signature(), '
+	/* creating a pointer to a vector<int> */
+	std::vector<int>* v = new std::vector<int> ;
+	v->push_back( 1 ) ;
+	v->push_back( 2 ) ;
+	
+	/* wrap the pointer as an external pointer */
+	/* this automatically protected the external pointer from R garbage 
+	   collection until p goes out of scope. */
+	RcppXPtr< std::vector<int> > p(v) ;
+	
+	/* return it back to R, since p goes out of scope after the return 
+	   the external pointer is no more protected by p, but it gets 
+	   protected by being on the R side */
+	return( p.asSexp() ) ;
+	
+', Rcpp=TRUE, verbose=FALSE)
+xp <- funx()
+stopifnot( identical( typeof( xp ), "externalptr" ) )
+
+# passing the pointer back to C++
+funx <- cfunction(signature(x = "externalptr" ), '
+	/* wrapping x as smart external pointer */
+	/* The SEXP based constructor does not protect the SEXP from 
+	   garbage collection automatically, it is already protected 
+	   because it comes from the R side, however if you want to keep 
+	   the RcppXPtr object on the C(++) side
+	   and return something else to R, you need to protect the external
+	   pointer, by using the protect member function */
+	RcppXPtr< std::vector<int> > p(x) ;
+	
+	/* just return the front of the vector as a SEXP */
+	return( RcppSexp( p->front() ).asSexp() ) ;
+', Rcpp=TRUE, verbose=FALSE)
+front <- funx(xp)
+stopifnot( identical( front, 1L ) )
+


Property changes on: pkg/inst/examples/RcppInline/external_pointer.r
___________________________________________________________________
Name: svn:executable
   + *

Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h	2009-12-28 11:23:31 UTC (rev 219)
+++ pkg/src/Rcpp.h	2009-12-29 09:30:12 UTC (rev 220)
@@ -41,5 +41,6 @@
 #include <RcppStringVectorView.h>
 #include <RcppVector.h>
 #include <RcppVectorView.h>
+#include <RcppXPtr.h>
 
 #endif

Modified: pkg/src/RcppExample.cpp
===================================================================
--- pkg/src/RcppExample.cpp	2009-12-28 11:23:31 UTC (rev 219)
+++ pkg/src/RcppExample.cpp	2009-12-29 09:30:12 UTC (rev 220)
@@ -461,3 +461,18 @@
 
     return rl;
 }
+
+RcppExport SEXP RcppXPtrExample_create_external_pointer(){
+	std::vector<int> *v = new std::vector<int> ;
+	v->push_back( 1 ) ;
+	v->push_back( 2 ) ;
+	RcppXPtr< std::vector<int> > p(v) ;
+	return p.asSexp() ;
+}
+
+RcppExport SEXP RcppXPtrExample_get_external_pointer(SEXP x){
+	RcppXPtr< std::vector<int> > p(x) ;
+	return Rf_ScalarInteger( p->back( ) ) ;
+}
+
+

Added: pkg/src/RcppXPtr.h
===================================================================
--- pkg/src/RcppXPtr.h	                        (rev 0)
+++ pkg/src/RcppXPtr.h	2009-12-29 09:30:12 UTC (rev 220)
@@ -0,0 +1,179 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// RcppXPtr.h: Rcpp R/C++ interface class library -- smart external pointers
+//
+// 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/>.
+
+#ifndef RcppXPtr_h
+#define RcppXPtr_h
+
+#include <RcppCommon.h>
+
+template <typename T>
+void delete_finalizer(SEXP p){
+	if( TYPEOF(p) == EXTPTRSXP ){
+		T* ptr = (T*) EXTPTR_PTR(p) ;
+		delete ptr ;
+	}
+}
+
+template <typename T>
+class RcppXPtr {
+	public:
+		
+		/** 
+		 * constructs a RcppXPtr wrapping the external pointer (EXTPTRSXP SEXP)
+		 *
+		 * @param xp external pointer to wrap
+		 */
+		explicit RcppXPtr(SEXP m_sexp) ;
+		
+		/**
+		 * creates a new external pointer wrapping the dumb pointer p. 
+		 * This calls R_PreserveObject to prevent the external pointer 
+		 * from R garbage collection
+		 * 
+		 * @param p dumb pointer to some object
+		 * @param set_delete_finalizer if set to true, a finalizer will 
+		 *        be registered for the external pointer. The finalizer
+		 *        is called when the xp is garbage collected. The finalizer 
+		 *        is merely a call to the delete operator or the pointer
+		 *        so you need to make sure the pointer can be deleted. 
+		 */
+  		explicit RcppXPtr(T* p, bool set_delete_finalizer) ;
+  		
+  		/**
+  		 * if this was built using the SEXP constructor, and no call 
+  		 * to protect was issued, the destructor 
+  		 * does nothing
+  		 *
+  		 * if built using the dumb pointer constructor or a call to 
+  		 * protect was issued, then the external
+  		 * pointer is released (using R_ReleaseObject), so 
+  		 */
+  		~RcppXPtr() ;
+  		
+  		/**
+  		 * Returns a reference to the object wrapped. This allows this
+  		 * object to look and feel like a dumb pointer to T
+  		 */
+  		T& operator*() const ;
+  		
+  		/**
+  		 * Returns the dumb pointer. This allows to call the -> operator 
+  		 * on this as if it was the dumb pointer
+  		 */
+  		T* operator->() const ;
+  		
+  		/**
+  		 * Returns the 'protected' part of the external pointer, this is 
+  		 * the SEXP that is passed in as the third argument of the 
+  		 * R_MakeExternalPointer function. See Writing R extensions
+  		 */
+  		SEXP getProtected() ;
+  		
+  		/** 
+  		 * Returns the 'tag' part of the external pointer, this is the 
+  		 * SEXP that is passed in as the 2nd argument of the 
+  		 * R_MakeExternalPointer function. See Writing R extensions
+  		 */
+  		SEXP getTag() ;
+  		
+  		/**
+  		 * force this external pointer to be protected from R garbage collection 
+  		 */
+  		void protect() ;
+  		
+  		void setDeleteFinalizer() ;
+  		
+  		/** 
+  		 * Returns the external pointer (suitable to send to the R side)
+  		 */
+  		SEXP asSexp();
+    	
+  	private:
+  		
+  		/**
+  		 * The external pointer
+  		 */
+  		SEXP m_sexp;
+  		
+  		/**
+  		 * set to true if this objects protects the external pointer 
+  		 * from R garbage collection (R_PreserveObject/R_ReleaseObject)
+  		 */
+  		bool isProtected;
+};
+
+template<typename T>
+RcppXPtr<T>::RcppXPtr(SEXP m_sexp) : m_sexp(m_sexp), isProtected(false) {}
+
+template<typename T>
+RcppXPtr<T>::RcppXPtr(T* p, bool set_delete_finalizer = true) : isProtected(false) {
+	m_sexp = R_MakeExternalPtr( (void*)p , R_NilValue, R_NilValue) ;
+	if( set_delete_finalizer ){
+		setDeleteFinalizer() ;
+	}
+	protect() ;
+}
+
+template<typename T>
+void RcppXPtr<T>::protect(){
+	R_PreserveObject( m_sexp ) ;
+	isProtected = true ;
+}
+
+template<typename T>
+void RcppXPtr<T>::setDeleteFinalizer(){
+	R_RegisterCFinalizerEx( m_sexp, delete_finalizer<T> , FALSE) ; 
+}
+
+
+template<typename T>
+RcppXPtr<T>::~RcppXPtr(){
+	if( isProtected ){
+		R_ReleaseObject( m_sexp ) ;
+	}
+}
+
+template<typename T>
+T& RcppXPtr<T>::operator*() const {
+	return *((T*)EXTPTR_PTR( m_sexp )) ;
+}
+
+template<typename T>
+T* RcppXPtr<T>::operator->() const {
+	return (T*)(EXTPTR_PTR(m_sexp));
+}
+
+template<typename T>
+SEXP RcppXPtr<T>::getProtected(){
+	return EXTPTR_PROT(m_sexp) ;
+}
+
+template<typename T>
+SEXP RcppXPtr<T>::getTag(){
+	return EXTPTR_TAG(m_sexp) ;
+}
+
+template<typename T>
+SEXP RcppXPtr<T>::asSexp(){
+	return m_sexp ;
+}
+
+#endif

Modified: pkg/src/exception_handling.cpp
===================================================================
--- pkg/src/exception_handling.cpp	2009-12-28 11:23:31 UTC (rev 219)
+++ pkg/src/exception_handling.cpp	2009-12-29 09:30:12 UTC (rev 220)
@@ -1,6 +1,6 @@
 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
 //
-// RcppCommon.cpp: R/C++ interface class library -- common functions
+// exception_handling.cpp: R/C++ interface class library -- common functions
 //
 // Copyright (C) 2009 - 2010 Romain Francois
 //
@@ -66,8 +66,11 @@
     }
     
 	Rf_eval( 
-		Rf_lang3( Rf_install("cpp_exception"), Rf_mkString(exception_what.c_str()), has_exception_class ? Rf_mkString(exception_class.c_str()) : R_NilValue ), 
-		R_FindNamespace(Rf_mkString("Rcpp"))
+		Rf_lang3( 
+			Rf_install("cpp_exception"), 
+			Rf_mkString(exception_what.c_str()), 
+			has_exception_class ? Rf_mkString(exception_class.c_str()) : R_NilValue
+		), R_FindNamespace(Rf_mkString("Rcpp"))
 	) ; 
 }
 SEXP initUncaughtExceptionHandler(){



More information about the Rcpp-commits mailing list