[Rcpp-commits] r508 - in pkg: inst inst/unitTests src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 28 18:06:45 CET 2010
Author: romain
Date: 2010-01-28 18:06:45 +0100 (Thu, 28 Jan 2010)
New Revision: 508
Added:
pkg/src/Rcpp/DottedPair.h
pkg/src/SimpleVector.cpp
Removed:
pkg/src/Pairlist.cpp
Modified:
pkg/inst/ChangeLog
pkg/inst/unitTests/runit.Pairlist.R
pkg/src/Language.cpp
pkg/src/Rcpp.h
pkg/src/Rcpp/Language.h
pkg/src/Rcpp/Pairlist.h
pkg/src/Rcpp/SimpleVector.h
pkg/src/Rcpp/VectorBase.h
pkg/src/Rcpp/grow.h
pkg/src/RcppCommon.h
pkg/src/VectorBase.cpp
pkg/src/grow.cpp
pkg/src/r_cast.cpp
Log:
added DottedPair template to generate Language and Pairlist since they were almost identical
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/inst/ChangeLog 2010-01-28 17:06:45 UTC (rev 508)
@@ -1,5 +1,9 @@
2010-01-28 Romain Francois <francoisromain at free.fr>
+ * src/Rcpp/DottedPair.h: factored out Language and Pairlist
+ into the new DottedPaitr template, parameterized by the
+ SEXP type (LANGSXP or LISTSXP)
+
* src/Rcpp/SimpleVector.h: simple vectors gain a range
based assign method and a range based assign constructor
* inst/unitTests/runit.IntegerVector.R: new unit test
Modified: pkg/inst/unitTests/runit.Pairlist.R
===================================================================
--- pkg/inst/unitTests/runit.Pairlist.R 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/inst/unitTests/runit.Pairlist.R 2010-01-28 17:06:45 UTC (rev 508)
@@ -25,7 +25,7 @@
funx <- cfunction(signature(x="ANY"), 'return Pairlist(x) ;',
Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
checkEquals( funx( pairlist("rnorm") ), pairlist("rnorm" ), msg = "Pairlist( LISTSXP )" )
- checkEquals( funx( call("rnorm") ), call("rnorm" ), msg = "Pairlist( LANGSXP )" )
+ checkEquals( funx( call("rnorm") ), pairlist(as.name("rnorm")), msg = "Pairlist( LANGSXP )" )
checkEquals( funx(1:10), as.pairlist(1:10) , msg = "Pairlist( INTSXP) " )
checkEquals( funx(TRUE), as.pairlist( TRUE) , msg = "Pairlist( LGLSXP )" )
checkEquals( funx(1.3), as.pairlist(1.3), msg = "Pairlist( REALSXP) " )
Modified: pkg/src/Language.cpp
===================================================================
--- pkg/src/Language.cpp 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Language.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -23,45 +23,13 @@
namespace Rcpp {
- Language::Language( SEXP lang = R_NilValue ) throw(not_compatible) : RObject::RObject( ){
- /* if this is not trivially a call, then try to convert it to one */
- if( lang != R_NilValue && TYPEOF(lang) != LANGSXP ){
-
- /* taken from do_ascall */
- switch( TYPEOF(lang) ){
- case LISTSXP :
- Rf_duplicate( lang ) ;
- break ;
- case VECSXP:
- case EXPRSXP:
- {
- int n = Rf_length(lang) ;
- if( n == 0 ) throw not_compatible("cannot convert to call (LANGSXP)") ;
- SEXP names = RCPP_GET_NAMES(lang) ;
- SEXP res, ap;
- PROTECT( ap = res = Rf_allocList( n ) ) ;
- for( int i=0; i<n; i++){
- SETCAR(ap, VECTOR_ELT(lang, i));
- if (names != R_NilValue && !Rf_StringBlank(STRING_ELT(names, i))){
- SET_TAG(ap, Rf_install(Rf_translateChar(STRING_ELT(names, i))));
- }
- ap = CDR( ap) ;
- }
- UNPROTECT(1) ;
- setSEXP(res) ;
- }
- default:
- throw not_compatible("cannot convert to call (LANGSXP)") ;
- }
- SET_TYPEOF(m_sexp, LANGSXP);
- SET_TAG(m_sexp, R_NilValue);
- } else{
- setSEXP( lang ) ;
- }
-
+ Language::Language() : Language_Base() {};
+
+ Language::Language( SEXP lang ) throw(not_compatible) : Language_Base(lang){
+ update() ;
};
- Language::Language( const std::string& symbol ): RObject::RObject(R_NilValue) {
+ Language::Language( const std::string& symbol ): Language_Base() {
setSEXP( Rf_lcons( Symbol(symbol), R_NilValue ) );
}
@@ -80,106 +48,10 @@
SET_TAG(m_sexp, R_NilValue);
}
- void Language::remove( const int& index ) throw(index_out_of_bounds){
- if( index < 0 || index >= Rf_length(m_sexp) ) throw index_out_of_bounds() ;
- if( index == 0 ){
- setSEXP( CDR( m_sexp) ) ;
- SET_TAG(m_sexp, R_NilValue);
- SET_TYPEOF( m_sexp, LANGSXP ) ;
- } else{
- SEXP x = m_sexp ;
- int i=1;
- while( i<index ){ x = CDR(x) ; i++; }
- SETCDR( x, CDDR(x) ) ;
- }
+ void Language::update(){
+ SET_TYPEOF( m_sexp, LANGSXP ) ;
+ SET_TAG( m_sexp, R_NilValue ) ;
}
-
- /* proxy for operator[] */
- Language::Proxy::Proxy(Language& v, const size_t& index) :
- parent(v), index(index) {} ;
-
- Language::Proxy& Language::Proxy::operator=(const Proxy& rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- if( rhs.index < 0 || rhs.index >= rhs.parent.length() ) throw index_out_of_bounds() ;
-
- SEXP target = parent.asSexp() ;
- SEXP origin = rhs.parent.asSexp();
- size_t i=0;
- while( i < index ){
- target = CDR(target) ;
- i++;
- }
- i=0;
- while( i < rhs.index ){
- origin = CDR(origin) ;
- i++;
- }
- SETCAR( target, CAR(origin) );
- if( index != 0 ) SET_TAG( target, TAG(origin) );
- return *this ;
- }
-
- Language::Proxy& Language::Proxy::operator=(const Named& rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- size_t i = 0 ;
- SEXP x = parent.asSexp() ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- SETCAR( x, rhs.getSEXP() ) ;
- if( index != 0 ) SET_TAG( x, Symbol( rhs.getTag() ) ) ;
- return *this ;
- }
-
- Language::Proxy& Language::Proxy::operator=(SEXP rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- SETCAR( x, rhs) ;
- return *this ;
- }
-
-
- /* rvalue uses */
-
- Language::Proxy::operator SEXP() const{
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- return CAR(x) ;
- }
-
- Language::Proxy::operator RObject() const{
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- return wrap( CAR(x) ) ;
- }
-
- const Language::Proxy Language::operator[](int i) const {
- return Proxy( const_cast<Language&>(*this), i) ;
- }
-
- Language::Proxy Language::operator[](int i){
- return Proxy( *this, i );
- }
-
-
-
-
} // namespace Rcpp
Deleted: pkg/src/Pairlist.cpp
===================================================================
--- pkg/src/Pairlist.cpp 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Pairlist.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -1,145 +0,0 @@
-// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
-//
-// Language.cpp: Rcpp R/C++ interface class library -- Language objects ( calls )
-//
-// 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/Pairlist.h>
-
-namespace Rcpp {
-
- Pairlist::Pairlist( ): RObject::RObject(){}
-
- Pairlist::Pairlist( SEXP x = R_NilValue ) throw(not_compatible) : RObject::RObject( ){
- if( x != R_NilValue ){
- switch( TYPEOF(x) ){
- case LANGSXP:
- case LISTSXP:
- setSEXP( x) ;
- break ;
- default:
- {
- SEXP res= R_NilValue;
- try{
- res = Evaluator::run( Rf_lang2( Rf_install("as.pairlist"), x ) ) ;
- } catch( const Evaluator::eval_error& ex){
- throw not_compatible( "cannot convert to call (LANGSXP)" ) ;
- }
- setSEXP( res ) ;
- }
- }
- }
- };
-
- Pairlist::~Pairlist(){}
-
- void Pairlist::remove( const int& index ) throw(index_out_of_bounds){
- if( index < 0 || index >= Rf_length(m_sexp) ) throw index_out_of_bounds() ;
- if( index == 0 ){
- setSEXP( CDR( m_sexp) ) ;
- } else{
- SEXP x = m_sexp ;
- int i=1;
- while( i<index ){ x = CDR(x) ; i++; }
- SETCDR( x, CDDR(x) ) ;
- }
- }
-
- Pairlist::Proxy::Proxy(Pairlist& v, const size_t& index) :
- parent(v), index(index) {} ;
-
- Pairlist::Proxy& Pairlist::Proxy::operator=(const Proxy& rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- if( rhs.index < 0 || rhs.index >= rhs.parent.length() ) throw index_out_of_bounds() ;
-
- SEXP target = parent.asSexp() ;
- SEXP origin = rhs.parent.asSexp();
- size_t i=0;
- while( i < index ){
- target = CDR(target) ;
- i++;
- }
- i=0;
- while( i < rhs.index ){
- origin = CDR(origin) ;
- i++;
- }
- SETCAR( target, CAR(origin) );
- SET_TAG( target, TAG(origin) );
- return *this ;
- }
-
- Pairlist::Proxy& Pairlist::Proxy::operator=(const Named& rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- size_t i = 0 ;
- SEXP x = parent.asSexp() ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- SETCAR( x, rhs.getSEXP() ) ;
- SET_TAG( x, Symbol( rhs.getTag() ) ) ;
- return *this ;
- }
-
- Pairlist::Proxy& Pairlist::Proxy::operator=(SEXP rhs){
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- SETCAR( x, rhs) ;
- return *this ;
- }
-
- Pairlist::Proxy::operator SEXP() const{
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- return CAR(x) ;
- }
-
- Pairlist::Proxy::operator RObject() const{
- if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
- SEXP x = parent.asSexp() ;
- size_t i = 0 ;
- while( i < index ) {
- x = CDR(x) ;
- i++ ;
- }
- return wrap( CAR(x) ) ;
- }
-
- const Pairlist::Proxy Pairlist::operator[](int i) const {
- return Proxy( const_cast<Pairlist&>(*this), i) ;
- }
-
- Pairlist::Proxy Pairlist::operator[](int i){
- return Proxy( *this, i );
- }
-
-
- SEXP pairlist(){ return R_NilValue ; }
-
-} // namespace Rcpp
Added: pkg/src/Rcpp/DottedPair.h
===================================================================
--- pkg/src/Rcpp/DottedPair.h (rev 0)
+++ pkg/src/Rcpp/DottedPair.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -0,0 +1,245 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// DottedPair.h: Rcpp R/C++ interface class library -- dotted pair list template
+//
+// 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_DottedPair_h
+#define Rcpp_DottedPair_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+#include <Rcpp/Symbol.h>
+#include <Rcpp/grow.h>
+#include <Rcpp/wrap.h>
+
+namespace Rcpp{
+
+template <int RTYPE> class DottedPair : public RObject{
+public:
+
+ DottedPair() : RObject(){}
+
+ DottedPair(SEXP x) throw(not_compatible) : RObject(){
+ setSEXP( r_cast<RTYPE>(x) ) ;
+ }
+
+#ifdef HAS_VARIADIC_TEMPLATES
+template<typename... Args>
+ DottedPair( const Args&... args) : RObject() {
+ setSEXP( pairlist(args...) ) ;
+ }
+#endif
+
+ /**
+ * wraps an object and add it at the end of the pairlist
+ * (this require traversing the entire pairlist)
+ *
+ * @param object anything that can be wrapped by one
+ * of the wrap functions, or an object of class Named
+ */
+ template <typename T>
+ void push_back( const T& object){
+ if( isNULL() ){
+ setSEXP( grow( object, m_sexp ) ) ;
+ } else {
+ SEXP x = m_sexp ;
+ /* traverse the pairlist */
+ while( !Rf_isNull(CDR(x)) ){
+ x = CDR(x) ;
+ }
+ SEXP tail = PROTECT( pairlist( object ) );
+ SETCDR( x, tail ) ;
+ UNPROTECT(1) ;
+ }
+ }
+
+ /**
+ * wraps an object and add it in front of the pairlist.
+ *
+ * @param object anything that can be wrapped by one
+ * of the wrap functions, or an object of class Named
+ */
+ template <typename T>
+ void push_front( const T& object){
+ setSEXP( grow(object, m_sexp) ) ;
+ }
+
+ /**
+ * insert an object at the given position, pushing other objects
+ * to the tail of the list
+ *
+ * @param index index (0-based) where to insert
+ * @param object object to wrap
+ */
+ template <typename T>
+ void insert( const int& index, const T& object) throw(index_out_of_bounds) {
+ if( index == 0 ) {
+ push_front( object ) ;
+ } else{
+ if( index < 0 ) throw index_out_of_bounds() ;
+ if( isNULL( ) ) throw index_out_of_bounds() ;
+
+ if( index < 0 || index > ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
+
+ int i=1;
+ SEXP x = m_sexp ;
+ while( i < index ){
+ x = CDR(x) ;
+ i++;
+ }
+ SEXP tail = PROTECT( grow( object, CDR(x) ) ) ;
+ SETCDR( x, tail ) ;
+ UNPROTECT(1) ;
+ }
+ }
+
+ /**
+ * replaces an element of the list
+ *
+ * @param index position
+ * @param object object that can be wrapped
+ */
+ template <typename T>
+ void replace( const int& index, const T& object ) throw(index_out_of_bounds){
+ if( index < 0 || index >= ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
+
+ /* pretend we do a pairlist so that we get Named to work for us */
+ SEXP x = PROTECT(pairlist( object ));
+ SEXP y = m_sexp ;
+ int i=0;
+ while( i<index ){ y = CDR(y) ; i++; }
+
+ SETCAR( y, CAR(x) );
+ SET_TAG( y, TAG(x) );
+ UNPROTECT(1) ;
+ }
+
+ inline size_t length() const { return ::Rf_length(m_sexp) ; }
+ inline size_t size() const { return ::Rf_length(m_sexp) ; }
+
+ /**
+ * Remove the element at the given position
+ *
+ * @param index position where the element is to be removed
+ */
+ void remove( const int& index ) throw(index_out_of_bounds){
+ if( index < 0 || index >= Rf_length(m_sexp) ) throw index_out_of_bounds() ;
+ if( index == 0 ){
+ setSEXP( CDR( m_sexp) ) ;
+ } else{
+ SEXP x = m_sexp ;
+ int i=1;
+ while( i<index ){ x = CDR(x) ; i++; }
+ SETCDR( x, CDDR(x) ) ;
+ }
+ }
+
+ class Proxy {
+ public:
+ Proxy( DottedPair<RTYPE>& v, const size_t& index_ ) : parent(v), index(index_){}
+
+ /* lvalue uses */
+ Proxy& operator=(const Proxy& rhs){
+ if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
+ size_t i = 0 ;
+ SEXP x = parent.asSexp() ;
+ while( i < index ) {
+ x = CDR(x) ;
+ i++ ;
+ }
+ SEXP y = rhs ;
+ SETCAR( x, y ) ;
+ // if( index != 0 ) SET_TAG( x, Rf_install( rhs.getTag() ) ) ;
+ return *this ;
+ }
+ Proxy& operator=(SEXP rhs){
+ if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
+ SEXP x = parent.asSexp() ;
+ size_t i = 0 ;
+ while( i < index ) {
+ x = CDR(x) ;
+ i++ ;
+ }
+ SETCAR( x, rhs) ;
+ return *this ;
+ }
+
+ template <typename T>
+ Proxy& operator=(const T& rhs){
+ parent.replace( index, rhs ) ;
+ return *this ;
+ }
+ Proxy& operator=(const Named& rhs){
+ if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
+ size_t i = 0 ;
+ SEXP x = parent.asSexp() ;
+ while( i < index ) {
+ x = CDR(x) ;
+ i++ ;
+ }
+ SEXP y = rhs ;
+ SETCAR( x, y ) ;
+ // if( index != 0 ) SET_TAG( x, Symbol( rhs.getTag() ) ) ;
+ return *this ;
+ }
+
+ /* rvalue use */
+ operator SEXP() {
+ if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
+ SEXP x = parent.asSexp() ;
+ size_t i = 0 ;
+ while( i < index ) {
+ x = CDR(x) ;
+ i++ ;
+ }
+ return CAR(x) ;
+ }
+
+ template <typename T> operator T() const {
+ if( index < 0 || index >= parent.length() ) throw index_out_of_bounds() ;
+ SEXP x = parent.asSexp() ;
+ size_t i = 0 ;
+ while( i < index ) {
+ x = CDR(x) ;
+ i++ ;
+ }
+ return as<T>( CAR(x) ) ;
+ }
+
+ private:
+ DottedPair<RTYPE>& parent;
+ size_t index ;
+ } ;
+
+ const Proxy operator[]( int i ) const {
+ return Proxy( const_cast<DottedPair<RTYPE>&>(*this), i) ;
+ }
+ Proxy operator[]( int i ) {
+ return Proxy( *this, i );
+ }
+
+ friend class Proxy;
+
+ virtual ~DottedPair() {};
+
+};
+
+} // namespace Rcpp
+
+#endif
Modified: pkg/src/Rcpp/Language.h
===================================================================
--- pkg/src/Rcpp/Language.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp/Language.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -23,21 +23,27 @@
#define Rcpp_Language_h
#include <RcppCommon.h>
+#include <Rcpp/DottedPair.h>
#include <Rcpp/RObject.h>
#include <Rcpp/Symbol.h>
-#include <Rcpp/Pairlist.h>
+#include <Rcpp/grow.h>
#include <Rcpp/wrap.h>
namespace Rcpp{
+/* lazy typedef */
+typedef DottedPair<LANGSXP> Language_Base ;
+
/**
* C++ wrapper around calls (LANGSXP SEXP)
*
* This represents calls that can be evaluated
*/
-class Language : public RObject{
+class Language : public Language_Base {
public:
+ Language() ;
+
/**
* Attempts to convert the SEXP to a call
*
@@ -86,79 +92,11 @@
*/
#ifdef HAS_VARIADIC_TEMPLATES
template<typename... Args>
- Language( const std::string& symbol, const Args&... args) : RObject() {
- /* TODO: should we first allocate and protect the list ?*/
- setSEXP( Rf_lcons( Symbol(symbol), pairlist( args... ) ) );
+Language( const std::string& symbol, const Args&... args) : Language_Base(Rf_install(symbol.c_str()), args...) {
+ update() ;
}
#endif
-
- /**
- * wraps an object and add it at the end of the pairlist
- * (this require traversing the entire pairlist)
- *
- * @param object anything that can be wrapped by one
- * of the wrap functions, or an object of class Named
- */
- template <typename T>
- void push_back( const T& object){
- if( isNULL() ){
- setSEXP( grow( object, m_sexp ) ) ;
- } else {
- SEXP x = m_sexp ;
- /* traverse the pairlist */
- while( !Rf_isNull(CDR(x)) ){
- x = CDR(x) ;
- }
- SEXP tail = PROTECT( pairlist( object ) );
- SETCDR( x, tail ) ;
- UNPROTECT(1) ;
- }
- }
-
- /**
- * wraps an object and add it in front of the pairlist.
- * in addition, the tag is set to NULL and the SEXPTYPE to LANGSXP
- *
- * @param object anything that can be wrapped by one
- * of the wrap functions, or an object of class Named
- */
- template <typename T>
- void push_front( const T& object){
- setSEXP( grow(object, m_sexp) ) ;
- SET_TAG(m_sexp, R_NilValue);
- SET_TYPEOF(m_sexp, LANGSXP);
- }
-
- /**
- * insert an object at the given position, pushing other objects
- * to the tail of the list
- *
- * @param index index (0-based) where to insert
- * @param object object to wrap
- */
- template <typename T>
- void insert( const int& index, const T& object) throw(index_out_of_bounds) {
- if( index == 0 ) {
- push_front( object ) ;
- } else{
- if( index < 0 ) throw index_out_of_bounds() ;
- if( isNULL( ) ) throw index_out_of_bounds() ;
-
- if( index < 0 || index > ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
-
- int i=1;
- SEXP x = m_sexp ;
- while( i < index ){
- x = CDR(x) ;
- i++;
- }
- SEXP tail = PROTECT( grow( object, CDR(x) ) ) ;
- SETCDR( x, tail ) ;
- UNPROTECT(1) ;
- }
- }
-
/**
* sets the symbol of the call
*/
@@ -169,76 +107,11 @@
*/
void setSymbol( const Symbol& symbol ) ;
- /**
- * replaces an element of the list
- *
- * @param index position
- * @param object object that can be wrapped
- */
- template <typename T>
- void replace( const int& index, const T& object ) throw(index_out_of_bounds){
- if( index < 0 || index >= ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
-
- if( index == 0 ){
- /* special handling */
- SEXP x = PROTECT(pairlist( object ));
- SETCAR( m_sexp, CAR(x) );
- UNPROTECT(1) ;
- } else{
- /* pretend we do a pairlist so that we get Named to work for us */
- SEXP x = PROTECT(pairlist( object ));
- SEXP y = m_sexp ;
- int i=0;
- while( i<index ){ y = CDR(y) ; i++; }
-
- SETCAR( y, CAR(x) );
- SET_TAG( y, TAG(x) );
- UNPROTECT(1) ;
- }
- }
-
- inline size_t length() const { return ::Rf_length(m_sexp) ; }
- inline size_t size() const { return ::Rf_length(m_sexp) ; }
+ ~Language() ;
- /**
- * Remove the element at the given position
- *
- * @param index position where the element is to be removed
- */
- void remove( const int& index ) throw(index_out_of_bounds) ;
-
- class Proxy {
- public:
- Proxy( Language& v, const size_t& index ) ;
+private:
+ virtual void update() ;
- /* lvalue uses */
- Proxy& operator=(const Proxy& rhs) ;
- Proxy& operator=(SEXP rhs) ;
-
- template <typename T>
- Proxy& operator=(const T& rhs){
- parent.replace( index, rhs ) ;
- return *this ;
- }
-
- Proxy& operator=(const Named& rhs) ;
-
- /* rvalue use */
- operator SEXP() const ;
- operator RObject() const ;
-
- private:
- Language& parent;
- size_t index ;
- } ;
-
- const Proxy operator[]( int i ) const ;
- Proxy operator[]( int i ) ;
-
- friend class Proxy;
-
-
- ~Language() ;
};
} // namespace Rcpp
Modified: pkg/src/Rcpp/Pairlist.h
===================================================================
--- pkg/src/Rcpp/Pairlist.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp/Pairlist.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -23,195 +23,9 @@
#define Rcpp_Pairlist_h
#include <RcppCommon.h>
-#include <Rcpp/RObject.h>
-#include <Rcpp/Named.h>
-#include <Rcpp/Evaluator.h>
+#include <Rcpp/DottedPair.h>
-namespace Rcpp{
-
-/**
- * C++ wrapper around pair lists (LISTSXP SEXP)
- *
- * This represents dotted pair lists
- */
-class Pairlist : public RObject{
-public:
-
- /**
- * Attempts to convert the SEXP to a pair list
- *
- * @throw not_compatible if the SEXP could not be converted
- * to a pair list using as.pairlist
- */
- Pairlist(SEXP lang) throw(not_compatible) ;
-
-
- Pairlist() ;
-
- /**
- * Creates a pairlist by wrapping the variable number of arguments
- * using the pairlist template
- *
- * @param ...Args variable length argument list. The type of each
- * argument must be wrappable, meaning there need to be
- * a wrap function that takes this type as its parameter
- *
- * @example Pairlist( 10, std::string("foobar"), "rnorm" )
- * will create the same pair list as
- * > pairlist( 10L, "foobar", "rnorm" )
- */
-#ifdef HAS_VARIADIC_TEMPLATES
-template<typename... Args>
- Pairlist( const Args&... args) : RObject() {
- /* TODO: should we first allocate and protect the list ?*/
- setSEXP( pairlist( args... ) );
- }
-#endif
-
- ~Pairlist() ;
-
- /**
- * wraps an object and add it in front of the pairlist
- *
- * @param object anything that can be wrapped by one
- * of the wrap functions, or an object of class Named
- */
- template <typename T>
- void push_front( const T& object){
- setSEXP( grow(object, m_sexp) ) ;
- }
-
- /**
- * wraps an object and add it at the end of the pairlist
- * (this require traversing the entire pairlist)
- *
- * @param object anything that can be wrapped by one
- * of the wrap functions, or an object of class Named
- */
- template <typename T>
- void push_back( const T& object){
- if( isNULL() ){
- setSEXP( grow( object, m_sexp ) ) ;
- } else {
- SEXP x = m_sexp ;
- /* traverse the pairlist */
- while( !Rf_isNull(CDR(x)) ){
- x = CDR(x) ;
- }
- SEXP tail = PROTECT( pairlist( object ) );
- SETCDR( x, tail ) ;
- UNPROTECT(1) ;
- }
- }
-
- /**
- * insert an object at the given position, pushing other objects
- * to the tail of the list
- *
- * @param index index (0-based) where to insert
- * @param object object to wrap
- */
- template <typename T>
- void insert( const int& index, const T& object) throw(index_out_of_bounds) {
- if( index == 0 ) {
- push_front( object ) ;
- } else{
- if( index < 0 ) throw index_out_of_bounds() ;
- if( isNULL( ) ) throw index_out_of_bounds() ;
-
- if( index < 0 || index > ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
-
- int i=1;
- SEXP x = m_sexp ;
- while( i < index ){
- x = CDR(x) ;
- i++;
- }
- SEXP tail = PROTECT( grow( object, CDR(x) ) ) ;
- SETCDR( x, tail ) ;
- UNPROTECT(1) ;
- }
- }
-
- /**
- * replaces an element of the list
- *
- * @param index position
- * @param object object that can be wrapped
- */
- template <typename T>
- void replace( const int& index, const T& object ) throw(index_out_of_bounds){
- if( index < 0 || index >= ::Rf_length(m_sexp) ) throw index_out_of_bounds() ;
-
- /* pretend we do a pairlist so that we get Named to work for us */
- SEXP x = PROTECT(pairlist( object ));
- SEXP y = m_sexp ;
- int i=0;
- while( i<index ){ y = CDR(y) ; i++; }
-
- SETCAR( y, CAR(x) );
- SET_TAG( y, TAG(x) );
- UNPROTECT(1) ;
- }
-
- inline size_t length() const { return ::Rf_length(m_sexp) ; }
- inline size_t size() const { return ::Rf_length(m_sexp) ; }
-
- /**
- * Remove the element at the given position
- *
- * @param index position where the element is to be removed
- */
- void remove( const int& index ) throw(index_out_of_bounds) ;
-
- class Proxy {
- public:
- Proxy( Pairlist& v, const size_t& index ) ;
-
- /* lvalue uses */
- Proxy& operator=(const Proxy& rhs) ;
- Proxy& operator=(SEXP rhs) ;
-
- template <typename T>
- Proxy& operator=(const T& rhs){
- parent.replace( index, rhs ) ;
- return *this ;
- }
-
- Proxy& operator=(const Named& rhs) ;
-
- /* rvalue use */
- operator SEXP() const ;
- operator RObject() const ;
-
- private:
- Pairlist& parent;
- size_t index ;
- } ;
-
- const Proxy operator[]( int i ) const ;
- Proxy operator[]( int i ) ;
-
- friend class Proxy;
-
-};
-
- SEXP pairlist() ;
-
- /* end of the recursion, wrap first to make the CAR and use
- R_NilValue as the CDR of the list */
- template<typename T>
- SEXP pairlist( const T& first){
- return grow(first, R_NilValue ) ;
- }
-
-#ifdef HAS_VARIADIC_TEMPLATES
- template<typename T, typename... Args>
- SEXP pairlist( const T& first, const Args&... args ){
- return grow(first, pairlist(args...) ) ;
- }
+namespace Rcpp{
+ typedef DottedPair<LISTSXP> Pairlist ;
+}
#endif
-
-} // namespace Rcpp
-
-#endif
Modified: pkg/src/Rcpp/SimpleVector.h
===================================================================
--- pkg/src/Rcpp/SimpleVector.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp/SimpleVector.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -30,6 +30,20 @@
namespace Rcpp{
+template <int RTYPE,typename CTYPE> CTYPE get_zero(){ return static_cast<CTYPE>(0) ; } ;
+// template<> double get_zero<REALSXP,double>() ;
+// template<> int get_zero<INTSXP,int>() ;
+// template<> int get_zero<LGLSXP,int>() ;
+template<> Rcomplex get_zero<CPLXSXP,Rcomplex>() ;
+// template<> Rbyte get_zero<RAWSXP,Rbyte>() ;
+
+template <int sexptype, typename T> T* get_pointer(SEXP x){ throw std::exception( "not implemented" ) ; return static_cast<T*>(0); }
+template<> double* get_pointer<REALSXP,double>(SEXP x) ;
+template<> int* get_pointer<INTSXP,int>(SEXP x) ;
+template<> int* get_pointer<LGLSXP,int>(SEXP x) ;
+template<> Rcomplex* get_pointer<CPLXSXP,Rcomplex>(SEXP x) ;
+template<> Rbyte* get_pointer<RAWSXP,Rbyte>(SEXP x) ;
+
template <int RTYPE, typename CTYPE>
class SimpleVector : public VectorBase {
public:
@@ -94,7 +108,8 @@
virtual void update(){ start = get_pointer<RTYPE,CTYPE>(m_sexp) ; }
void init(){
- init( static_cast<CTYPE>(0) ) ;
+ CTYPE zero = get_zero<RTYPE,CTYPE>() ;
+ init( zero ) ;
}
void init( const CTYPE& value){
std::fill( start, start+length(), value ) ;
Modified: pkg/src/Rcpp/VectorBase.h
===================================================================
--- pkg/src/Rcpp/VectorBase.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp/VectorBase.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -65,13 +65,6 @@
} ;
-template <int sexptype, typename T> T* get_pointer(SEXP x){ throw std::exception( "not implemented" ) ; return static_cast<T*>(0); }
-template<> double* get_pointer<REALSXP,double>(SEXP x) ;
-template<> int* get_pointer<INTSXP,int>(SEXP x) ;
-template<> int* get_pointer<LGLSXP,int>(SEXP x) ;
-template<> Rcomplex* get_pointer<CPLXSXP,Rcomplex>(SEXP x) ;
-template<> Rbyte* get_pointer<RAWSXP,Rbyte>(SEXP x) ;
-
} // namespace
#endif
Modified: pkg/src/Rcpp/grow.h
===================================================================
--- pkg/src/Rcpp/grow.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp/grow.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -27,6 +27,23 @@
namespace Rcpp{
+SEXP pairlist() ;
+
+/* end of the recursion, wrap first to make the CAR and use
+ R_NilValue as the CDR of the list */
+template<typename T>
+SEXP pairlist( const T& first){
+ return grow(first, R_NilValue ) ;
+}
+
+#ifdef HAS_VARIADIC_TEMPLATES
+template<typename T, typename... Args>
+SEXP pairlist( const T& first, const Args&... args ){
+ return grow(first, pairlist(args...) ) ;
+}
+#endif
+
+
/**
* grows a pairlist. First wrap the head into a SEXP, then
* grow the tail pairlist
@@ -37,6 +54,7 @@
}
SEXP grow(const Named& head, SEXP tail) ;
+
} // namespace Rcpp
#endif
Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/Rcpp.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -59,6 +59,7 @@
#include <Rcpp/Symbol.h>
#include <Rcpp/Language.h>
#include <Rcpp/Named.h>
+#include <Rcpp/DottedPair.h>
#include <Rcpp/Pairlist.h>
#include <Rcpp/Function.h>
#include <Rcpp/IntegerVector.h>
Modified: pkg/src/RcppCommon.h
===================================================================
--- pkg/src/RcppCommon.h 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/RcppCommon.h 2010-01-28 17:06:45 UTC (rev 508)
@@ -106,9 +106,7 @@
class Environment;
class Evaluator ;
class Symbol ;
- class Language ;
class Named ;
- class Pairlist ;
class Function ;
class WeakReference;
Added: pkg/src/SimpleVector.cpp
===================================================================
--- pkg/src/SimpleVector.cpp (rev 0)
+++ pkg/src/SimpleVector.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -0,0 +1,41 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// SimpleVector.h: Rcpp R/C++ interface class library -- simple vectors
+//
+// 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 <RcppCommon.h>
+#include <Rcpp/SimpleVector.h>
+
+namespace Rcpp{
+
+ template<> double* get_pointer<REALSXP,double>(SEXP x){ return REAL(x) ; }
+ template<> int* get_pointer<INTSXP,int>(SEXP x){ return INTEGER(x) ; }
+ template<> int* get_pointer<LGLSXP,int>(SEXP x){ return LOGICAL(x) ; }
+ template<> Rcomplex* get_pointer<CPLXSXP,Rcomplex>(SEXP x){ return COMPLEX(x) ; }
+ template<> Rbyte* get_pointer<RAWSXP,Rbyte>(SEXP x){ return RAW(x) ; }
+
+ template<> Rcomplex get_zero<CPLXSXP,Rcomplex>(){
+ Rcomplex x ;
+ x.r = 0.0 ;
+ x.i = 0.0 ;
+ return x ;
+ }
+
+
+} // namespace
Modified: pkg/src/VectorBase.cpp
===================================================================
--- pkg/src/VectorBase.cpp 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/VectorBase.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -42,11 +42,5 @@
if( i >= static_cast<size_t>(Rf_length(m_sexp)) ) throw RObject::index_out_of_bounds() ;
return i ;
}
-
- template<> double* get_pointer<REALSXP,double>(SEXP x){ return REAL(x) ; }
- template<> int* get_pointer<INTSXP,int>(SEXP x){ return INTEGER(x) ; }
- template<> int* get_pointer<LGLSXP,int>(SEXP x){ return LOGICAL(x) ; }
- template<> Rcomplex* get_pointer<CPLXSXP,Rcomplex>(SEXP x){ return COMPLEX(x) ; }
- template<> Rbyte* get_pointer<RAWSXP,Rbyte>(SEXP x){ return RAW(x) ; }
} // namespace
Modified: pkg/src/grow.cpp
===================================================================
--- pkg/src/grow.cpp 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/grow.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -23,6 +23,8 @@
namespace Rcpp{
+SEXP pairlist(){ return R_NilValue ; }
+
SEXP grow(const Named& head, SEXP tail){
SEXP x;
x = PROTECT( Rf_cons( head.getSEXP(), tail) ) ;
Modified: pkg/src/r_cast.cpp
===================================================================
--- pkg/src/r_cast.cpp 2010-01-28 15:53:09 UTC (rev 507)
+++ pkg/src/r_cast.cpp 2010-01-28 17:06:45 UTC (rev 508)
@@ -117,10 +117,45 @@
}
template<> SEXP r_true_cast<LISTSXP>(SEXP x){
- return convert_using_rfunction(x, "as.pairlist" ) ;
+ switch( TYPEOF(x) ){
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rcpp -r 508
More information about the Rcpp-commits
mailing list