[Rcpp-commits] r2116 - in pkg/Rcpp: R inst inst/include inst/include/Rcpp src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 16 16:51:31 CEST 2010
Author: romain
Date: 2010-09-16 16:51:31 +0200 (Thu, 16 Sep 2010)
New Revision: 2116
Added:
pkg/Rcpp/inst/include/Rcpp/Reference.h
pkg/Rcpp/src/Reference.cpp
Modified:
pkg/Rcpp/R/Module.R
pkg/Rcpp/inst/ChangeLog
pkg/Rcpp/inst/include/Rcpp.h
pkg/Rcpp/inst/include/Rcpp/exceptions.h
pkg/Rcpp/src/Module.cpp
pkg/Rcpp/src/exceptions.cpp
Log:
skeleton for a Rcpp::Reference class
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/R/Module.R 2010-09-16 14:51:31 UTC (rev 2116)
@@ -141,33 +141,12 @@
new( as.character(Class), pointer = out$xp, cppclass = Class at pointer, module = Class at module )
} )
-MethodInvoker <- function( x, name ){
- function(...){
- res <- .External( "Class__invoke_method", x at cppclass, name, x at pointer, ... , PACKAGE = "Rcpp" )
- if( isTRUE( res$void ) ) invisible(NULL) else res$result
- }
-}
-
-# dollar_cppobject <- function(x, name){
-# if( .Call( "Class__has_method", x at cppclass, name, PACKAGE = "Rcpp" ) ){
-# MethodInvoker( x, name )
-# } else if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ) {
-# .Call( "CppClass__get", x at cppclass, x at pointer, name, PACKAGE = "Rcpp" )
-# } else {
-# stop( "no such method or property" )
+# MethodInvoker <- function( x, name ){
+# function(...){
+# res <- .External( "Class__invoke_method", x at cppclass, name, x at pointer, ... , PACKAGE = "Rcpp" )
+# if( isTRUE( res$void ) ) invisible(NULL) else res$result
# }
# }
-#
-# setMethod( "$", "C++Object", dollar_cppobject )
-#
-# dollargets_cppobject <- function(x, name, value){
-# if( .Call("Class__has_property", x at cppclass, name, PACKAGE = "Rcpp" ) ){
-# .Call( "CppClass__set", x at cppclass, x at pointer, name, value, PACKAGE = "Rcpp" )
-# }
-# x
-# }
-#
-# setReplaceMethod( "$", "C++Object", dollargets_cppobject )
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ){
if(is(module, "Module")) {
Modified: pkg/Rcpp/inst/ChangeLog
===================================================================
--- pkg/Rcpp/inst/ChangeLog 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/inst/ChangeLog 2010-09-16 14:51:31 UTC (rev 2116)
@@ -12,6 +12,11 @@
* R/Module.R: (unexported) functions .getField and .setField that
call CppField__get and CppField__set
+
+ * inst/include/Rcpp/Reference.h: skeleton for a Rcpp::Reference class that
+ will help dealing with reference classes on the C++ side
+
+ * src/Reference.cpp: implementation (needs update)
2010-09-15 Romain Francois <romain at r-enthusiasts.com>
Added: pkg/Rcpp/inst/include/Rcpp/Reference.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/Reference.h (rev 0)
+++ pkg/Rcpp/inst/include/Rcpp/Reference.h 2010-09-16 14:51:31 UTC (rev 2116)
@@ -0,0 +1,124 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// S4.h: Rcpp R/C++ interface class library -- S4 objects
+//
+// Copyright (C) 2010 Dirk Eddelbuettel and 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 Rcpp_Reference_h
+#define Rcpp_Reference_h
+
+#include <Rcpp/S4.h>
+#include <Rcpp/exceptions.h>
+
+namespace Rcpp{
+
+/**
+ * S4 object (of a reference class)
+ */
+class Reference : public S4 {
+public:
+ Reference() ;
+
+ /**
+ * checks that x is an S4 object of a reference class and wrap it.
+ *
+ * @param x must be an S4 object of some reference class
+ */
+ Reference(SEXP x) throw(not_reference) ;
+
+ /**
+ * copy constructor
+ *
+ * @param other other S4 object
+ */
+ Reference(const Reference& other) ;
+ Reference(const RObject::SlotProxy& proxy ) throw(not_reference) ;
+ Reference(const RObject::AttributeProxy& proxy ) throw(not_reference);
+
+ Reference& operator=( const Reference& other);
+ Reference& operator=( SEXP other ) throw(not_reference) ;
+
+ /**
+ * Creates an reference object of the requested class.
+ *
+ * @param klass name of the target reference class
+ * @throw reference_creation_error if klass does not map to a known S4 class
+ */
+ Reference( const std::string& klass ) throw(S4_creation_error,reference_creation_error) ;
+
+
+ // TODO: perhaps I should move this to RObject (do the same as SlotProxy, etc ...)
+ /**
+ * Proxy for objects slots.
+ */
+ class FieldProxy {
+ public:
+ /**
+ * Creates a field proxy.
+ *
+ * @param v parent object of which we get/set a field
+ * @param name field name
+ */
+ FieldProxy( const Reference& v, const std::string& name) throw(no_such_field) ;
+
+ /**
+ * lhs use. Assigns the target slot using the current
+ * value of another slot proxy.
+ *
+ * @param rhs another slot proxy
+ */
+ FieldProxy& operator=(const FieldProxy& rhs) ;
+
+ /**
+ * lhs use. Assigns the slot by wrapping the rhs object
+ *
+ * @param rhs wrappable object
+ */
+ template <typename T> FieldProxy& operator=(const T& rhs){
+ set( wrap(rhs) ) ;
+ return *this ;
+ }
+
+ /**
+ * rhs use. Retrieves the current value of the slot
+ * and structures it as a T object. This only works
+ * when as<T> makes sense
+ */
+ template <typename T> operator T() const {
+ return as<T>(get()) ;
+ }
+
+ private:
+ const Reference& parent;
+ std::string field_name ;
+
+ SEXP get() const ;
+ void set(SEXP x ) const;
+ } ;
+ friend class FieldProxy ;
+
+ FieldProxy field( const std::string& name) const ;
+
+
+private:
+ void set( SEXP x) throw(not_reference) ;
+} ;
+
+} // namespace Rcpp
+
+#endif
Modified: pkg/Rcpp/inst/include/Rcpp/exceptions.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/exceptions.h 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/inst/include/Rcpp/exceptions.h 2010-09-16 14:51:31 UTC (rev 2116)
@@ -73,13 +73,16 @@
RCPP_SIMPLE_EXCEPTION_CLASS(index_out_of_bounds, "index out of bounds")
RCPP_SIMPLE_EXCEPTION_CLASS(parse_error, "parse error")
RCPP_SIMPLE_EXCEPTION_CLASS(not_s4, "not an S4 object")
+RCPP_SIMPLE_EXCEPTION_CLASS(not_reference, "not an S4 object of a reference class")
RCPP_SIMPLE_EXCEPTION_CLASS(no_such_slot, "no such slot")
+RCPP_SIMPLE_EXCEPTION_CLASS(no_such_field, "no such field")
RCPP_SIMPLE_EXCEPTION_CLASS(not_a_closure, "not a closure")
RCPP_SIMPLE_EXCEPTION_CLASS(no_such_function, "no such function")
RCPP_SIMPLE_EXCEPTION_CLASS(unevaluated_promise, "promise not yet evaluated")
RCPP_EXCEPTION_CLASS(not_compatible, message )
RCPP_EXCEPTION_CLASS(S4_creation_error, std::string("error creating object of S4 class : ") + message )
+RCPP_EXCEPTION_CLASS(reference_creation_error, std::string("error creating object of reference class : ") + message )
RCPP_EXCEPTION_CLASS(no_such_binding, std::string("no such binding : '") + message + "'" )
RCPP_EXCEPTION_CLASS(binding_not_found, std::string("binding not found: '") + message + "'" )
RCPP_EXCEPTION_CLASS(binding_is_locked, std::string("binding is locked: '") + message + "'" )
Modified: pkg/Rcpp/inst/include/Rcpp.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp.h 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/inst/include/Rcpp.h 2010-09-16 14:51:31 UTC (rev 2116)
@@ -37,6 +37,7 @@
#include <Rcpp/Named.h>
#include <Rcpp/S4.h>
+#include <Rcpp/Reference.h>
#include <Rcpp/clone.h>
#include <Rcpp/grow.h>
#include <Rcpp/Dimension.h>
Modified: pkg/Rcpp/src/Module.cpp
===================================================================
--- pkg/Rcpp/src/Module.cpp 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/src/Module.cpp 2010-09-16 14:51:31 UTC (rev 2116)
@@ -91,6 +91,8 @@
XP_Class cl(xp) ;
return cl->complete();
}
+
+// that needs to eventually disappear as we will use the ones below
RCPP_FUNCTION_3(SEXP, CppClass__get, XP_Class cl, SEXP obj, std::string name){
return cl->getProperty( name, obj ) ;
}
Added: pkg/Rcpp/src/Reference.cpp
===================================================================
--- pkg/Rcpp/src/Reference.cpp (rev 0)
+++ pkg/Rcpp/src/Reference.cpp 2010-09-16 14:51:31 UTC (rev 2116)
@@ -0,0 +1,103 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// S4.cpp: Rcpp R/C++ interface class library -- S4 objects
+//
+// Copyright (C) 2010 Dirk Eddelbuettel and 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/>.
+
+#include <Rcpp/Reference.h>
+#include <Rcpp/exceptions.h>
+#include <Rcpp/Vector.h>
+
+namespace Rcpp {
+
+ Reference::Reference() : S4(){}
+
+ Reference::Reference(SEXP x) throw(not_reference) : S4(){
+ set( x) ;
+ }
+
+ Reference::Reference( const Reference& other) : S4(){
+ setSEXP( other.asSexp() ) ;
+ }
+
+ Reference::Reference( const RObject::SlotProxy& proxy ) throw(not_reference) : S4() {
+ set( proxy ) ;
+ }
+ Reference::Reference( const RObject::AttributeProxy& proxy ) throw(not_reference) : S4() {
+ set( proxy ) ;
+ }
+
+ Reference& Reference::operator=( const Reference& other){
+ setSEXP( other.asSexp() ) ;
+ return *this ;
+ }
+
+ Reference& Reference::operator=( SEXP other ) throw(not_reference) {
+ set( other ) ;
+ return *this ;
+ }
+
+ Reference::Reference( const std::string& klass ) throw(S4_creation_error,reference_creation_error) : S4(klass){
+ // TODO: check that klass is indeed a reference class
+ }
+
+ void Reference::set( SEXP x) throw(not_reference) {
+ // TODO: check that x is of a reference class
+ if( ! ::Rf_isS4(x) ){
+ throw not_reference() ;
+ } else{
+ setSEXP( x) ;
+ }
+ }
+
+
+
+ Reference::FieldProxy::FieldProxy( const Reference& v, const std::string& name) throw(no_such_field) :
+ parent(v), field_name(name) {
+ if( !R_has_slot( v, Rf_install(name.c_str())) ){
+ throw no_such_slot() ;
+ }
+ }
+
+ Reference::FieldProxy& Reference::FieldProxy::operator=(const FieldProxy& rhs){
+ set( rhs.get() ) ;
+ return *this ;
+ }
+
+
+ SEXP Reference::FieldProxy::get() const {
+ // TODO: get the field
+ return R_NilValue ;
+ // return R_do_slot( parent, Rf_install( slot_name.c_str() ) ) ;
+ }
+
+ void Reference::FieldProxy::set( SEXP x) const {
+ // TODO: set the field
+
+ // // the SEXP might change (.Data)
+ // SEXP new_obj = PROTECT( R_do_slot_assign(
+ // parent,
+ // Rf_install( slot_name.c_str() ),
+ // x
+ // ) ) ;
+ // const_cast<RObject&>(parent).setSEXP( new_obj ) ;
+ // UNPROTECT(1) ;
+ }
+
+
+} // namespace Rcpp
Modified: pkg/Rcpp/src/exceptions.cpp
===================================================================
--- pkg/Rcpp/src/exceptions.cpp 2010-09-16 10:07:09 UTC (rev 2115)
+++ pkg/Rcpp/src/exceptions.cpp 2010-09-16 14:51:31 UTC (rev 2116)
@@ -36,6 +36,7 @@
RCPP_EXCEPTION_WHAT(not_compatible)
RCPP_EXCEPTION_WHAT(S4_creation_error)
+RCPP_EXCEPTION_WHAT(reference_creation_error)
RCPP_EXCEPTION_WHAT(no_such_binding)
RCPP_EXCEPTION_WHAT(binding_not_found)
RCPP_EXCEPTION_WHAT(binding_is_locked)
@@ -51,7 +52,9 @@
RCPP_SIMPLE_EXCEPTION_WHAT(index_out_of_bounds, "index out of bounds" )
RCPP_SIMPLE_EXCEPTION_WHAT(parse_error, "parse error")
RCPP_SIMPLE_EXCEPTION_WHAT(not_s4, "not an S4 object" )
+RCPP_SIMPLE_EXCEPTION_WHAT(not_reference, "not a reference S4 object" )
RCPP_SIMPLE_EXCEPTION_WHAT(no_such_slot, "no such slot" )
+RCPP_SIMPLE_EXCEPTION_WHAT(no_such_field, "no such field" )
RCPP_SIMPLE_EXCEPTION_WHAT(not_a_closure, "not a closure" )
RCPP_SIMPLE_EXCEPTION_WHAT(no_such_function, "no such function" )
RCPP_SIMPLE_EXCEPTION_WHAT(unevaluated_promise, "promise not yet evaluated" )
More information about the Rcpp-commits
mailing list