[Rcpp-devel] [Rcpp-commits] r259 - in pkg: . R inst inst/unitTests src src/Rcpp
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 3 09:53:20 CET 2010
Author: romain
Date: 2010-01-03 09:53:19 +0100 (Sun, 03 Jan 2010)
New Revision: 259
Added:
pkg/inst/unitTests/runit.Language.R
pkg/inst/unitTests/runit.Symbol.R
pkg/src/Language.cpp
pkg/src/Rcpp/Language.h
pkg/src/Rcpp/Symbol.h
pkg/src/Symbol.cpp
Modified:
pkg/DESCRIPTION
pkg/R/RcppLdpath.R
pkg/inst/ChangeLog
pkg/inst/unitTests/runit.environments.R
pkg/src/Environment.cpp
pkg/src/Evaluator.cpp
pkg/src/Makevars
pkg/src/RObject.cpp
pkg/src/Rcpp.h
pkg/src/Rcpp/Environment.h
pkg/src/Rcpp/Evaluator.h
pkg/src/RcppCommon.cpp
pkg/src/RcppCommon.h
Log:
added Language and Symbol class. use C++0x features
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/DESCRIPTION 2010-01-03 08:53:19 UTC (rev 259)
@@ -1,6 +1,6 @@
Package: Rcpp
Title: Rcpp R/C++ interface package
-Version: 0.7.1
+Version: 0.7.1.1
Date: $Date$
Author: Dirk Eddelbuettel and Romain Francois, with contributions
by Simon Urbanek and David Reiss; based on code written during
Modified: pkg/R/RcppLdpath.R
===================================================================
--- pkg/R/RcppLdpath.R 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/R/RcppLdpath.R 2010-01-03 08:53:19 UTC (rev 259)
@@ -26,9 +26,11 @@
invisible(flags)
}
+canUseCXX0X <- function() .Call( "canUseCXX0X", PACKAGE = "Rcpp" )
+
## Provide compiler flags -- i.e. -I/path/to/Rcpp.h
RcppCxxFlags <- function() {
- paste("-I", RcppLdPath(), sep="")
+ paste("-I", RcppLdPath(), if( canUseCXX0X ) " -std=c++0x" else "", sep="")
}
## Shorter names, and call cat() directly
Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/inst/ChangeLog 2010-01-03 08:53:19 UTC (rev 259)
@@ -1,3 +1,41 @@
+2010-01-03 Romain Francois <francoisromain at free.fr>
+
+ * src/RcppCommon.h: added the CXX0X define that controls whether
+ we can use C++0x features offered by the gcc. currently the define
+ is hardcoded, but this will eventually be a configure guess. The
+ canUseCXX0X function can be called to bring this back to R
+
+ * R/RcppLdPath.R: added the canUseCXX0X R function to query
+ the internal canUseCXX0X function, use this in RcppCxxFlags so that
+ code linking against Rcpp (inline code or packages) can take
+ advantage of it
+
+2010-01-03 Romain Francois <francoisromain at free.fr>
+
+ * src/Rcpp/Language.h : new class Rcpp::Language to manage calls
+ (LANGSXP SEXP)
+
+ * src/Language.cpp : implementation
+
+ * inst/unitTests/runit.Language.R: unit tests
+
+2010-01-03 Romain Francois <francoisromain at free.fr>
+
+ * src/Rcpp/Environment.h : added constructors and made the SEXP based
+ constructor smarter (using as.environment)
+
+ * inst/unitTests/runit.environments.R: more unit tests
+
+2010-01-03 Romain Francois <francoisromain at free.fr>
+
+ * src/Rcpp/Symbol.h: new class Rcpp::Symbol to encapsulate
+ symbols. This allows to use Symbol("rnorm") instead of the most cryptic
+ Rf_install("rnorm")
+
+ * src/Symbol.cpp: implementation
+
+ * inst/unitTests/runit.Symbol.R: unit tests
+
2010-01-03 Dirk Eddelbuettel <edd at debian.org>
* doxyfile: updated to current doxygen standard using -u
Added: pkg/inst/unitTests/runit.Language.R
===================================================================
--- pkg/inst/unitTests/runit.Language.R (rev 0)
+++ pkg/inst/unitTests/runit.Language.R 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,36 @@
+#!/usr/bin/r -t
+#
+# 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/>.
+
+.setUp <- function(){
+ suppressMessages( require( inline ) )
+}
+
+test.Language <- function(){
+ funx <- cfunction(signature(x="ANY"), 'return Language(x) ;', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+ checkEquals( funx( call("rnorm") ), call("rnorm" ), msg = "Language( LANGSXP )" )
+ # checkEquals( funx( list( as.name("rnorm") ) ), call("rnorm" ),
+ # msg = "Language( list with 1st arg symbol )" )
+ checkException( funx(funx), msg = "Language not compatible with function" )
+ checkException( funx(new.env()), msg = "Language not compatible with environment" )
+ checkException( funx(1:10), msg = "Language not compatible with integer" )
+ checkException( funx(TRUE), msg = "Language not compatible with logical" )
+ checkException( funx(1.3), msg = "Language not compatible with numeric" )
+ checkException( funx(as.raw(1) ), msg = "Language not compatible with raw" )
+}
+
Added: pkg/inst/unitTests/runit.Symbol.R
===================================================================
--- pkg/inst/unitTests/runit.Symbol.R (rev 0)
+++ pkg/inst/unitTests/runit.Symbol.R 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,54 @@
+#!/usr/bin/r -t
+#
+# 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/>.
+
+.setUp <- function(){
+ suppressMessages( require( inline ) )
+}
+
+test.Symbol <- function(){
+ funx <- cfunction(signature(), '
+ SEXP res = PROTECT( Rf_allocVector( LGLSXP, 4) ) ;
+ /* SYMSXP */
+ LOGICAL(res)[0] = Symbol( Rf_install("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;
+
+ /* CHARSXP */
+ LOGICAL(res)[1] = Symbol( Rf_mkChar("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;
+
+ /* STRSXP */
+ LOGICAL(res)[2] = Symbol( Rf_mkString("foobar") ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;
+
+ /* std::string */
+ LOGICAL(res)[3] = Symbol( "foobar" ).asSexp() == Rf_install("foobar") ? TRUE : FALSE ;
+
+ UNPROTECT(1) ; /* res */
+ return res ;
+ ', Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+ checkTrue( all( funx() ), msg = "Symbol creation" )
+}
+
+test.Symbol.notcompatible <- function(){
+ funx <- cfunction(signature(x="ANY"), 'return Symbol(x);',
+ Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+ checkException( funx(funx), msg = "Symbol not compatible with function" )
+ checkException( funx(asNamespace("Rcpp")), msg = "Symbol not compatible with environment" )
+ checkException( funx(1:10), msg = "Symbol not compatible with integer" )
+ checkException( funx(TRUE), msg = "Symbol not compatible with logical" )
+ checkException( funx(1.3), msg = "Symbol not compatible with numeric" )
+ checkException( funx(as.raw(1) ), msg = "Symbol not compatible with raw" )
+}
Modified: pkg/inst/unitTests/runit.environments.R
===================================================================
--- pkg/inst/unitTests/runit.environments.R 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/inst/unitTests/runit.environments.R 2010-01-03 08:53:19 UTC (rev 259)
@@ -1,6 +1,6 @@
#!/usr/bin/r -t
#
-# Copyright (C) 2009 - 2010 Romain Francois
+# Copyright (C) 2009 - 2010 Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
@@ -238,5 +238,40 @@
}
+test.environment.constructor.SEXP <- function(){
+ funx <- cfunction(signature( env = "ANY" ), 'return Environment( env ) ;',
+ Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+ checkEquals( funx( globalenv() ), globalenv(), msg = "Environment( environment ) - 1" )
+ checkEquals( funx( baseenv() ), baseenv(), msg = "Environment( environment ) - 2" )
+ checkEquals( funx( asNamespace("Rcpp") ), asNamespace("Rcpp"), msg = "Environment( environment ) - 3" )
+
+ checkEquals( funx( ".GlobalEnv" ), globalenv(), msg = "Environment( character ) - 1" )
+ checkEquals( funx( "package:base" ), baseenv(), msg = "Environment( character ) - 2" )
+ checkEquals( funx( "package:Rcpp" ), as.environment("package:Rcpp") , msg = 'Environment( "package:Rcpp") ' )
+
+ checkEquals( funx(1L), globalenv(), msg = "Environment( SEXP{integer} )" )
+}
+test.environment.constructor.stdstring <- function(){
+ funx <- cfunction(signature( env = "character" ), '
+ std::string st = RObject(env).asStdString() ;
+ return Environment( st ) ; ',
+ Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+
+ checkEquals( funx( ".GlobalEnv" ), globalenv(), msg = "Environment( std::string ) - 1" )
+ checkEquals( funx( "package:base" ), baseenv(), msg = "Environment( std::string ) - 2" )
+ checkEquals( funx( "package:Rcpp" ), as.environment("package:Rcpp") ,
+ msg = 'Environment( std::string ) - 3' )
+
+}
+test.environment.constructor.int <- function(){
+ funx <- cfunction(signature( env = "integer" ), '
+ int pos = RObject(env).asInt() ;
+ return Environment( pos ) ;',
+ Rcpp=TRUE, verbose=FALSE, includes = "using namespace Rcpp;" )
+ for( i in 1:length(search())){
+ checkEquals( funx(i), as.environment(i), msg = sprintf("Environment(int) - %d", i) )
+ }
+}
+
Modified: pkg/src/Environment.cpp
===================================================================
--- pkg/src/Environment.cpp 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Environment.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -2,7 +2,7 @@
//
// Environment.cpp: Rcpp R/C++ interface class library -- Environments
//
-// Copyright (C) 2009 - 2010 Romain Francois
+// Copyright (C) 2009 - 2010 Dirk Eddelbuettel and Romain Francois
//
// This file is part of Rcpp.
//
@@ -20,6 +20,8 @@
// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
#include <Rcpp/Environment.h>
+#include <Rcpp/Evaluator.h>
+#include <Rcpp/Symbol.h>
namespace Rcpp {
@@ -41,13 +43,58 @@
s->val = R_FindNamespace(s->sym);
}
+ Environment::Environment( SEXP x = R_GlobalEnv) throw(not_compatible) : RObject::RObject(x){
+
+ if( Rf_isEnvironment(x) ){
+ /* this is an environment, that's easy */
+ m_sexp = x;
+ } else{
+
+ /* not an environment, but maybe convertible to one using
+ as.environment, try that */
+ Evaluator evaluator( Rf_lang2(Symbol("as.environment"), x ) ) ;
+ evaluator.run() ;
+ if( evaluator.successfull() ){
+ m_sexp = evaluator.getResult() ;
+ preserved = true ;
+ evaluator.getResult().forgetPreserve() ;
+ } else{
+ throw not_compatible( ) ;
+ }
+ }
+ }
- Environment::Environment( SEXP m_sexp = R_GlobalEnv) : RObject::RObject(m_sexp){
- if( TYPEOF(m_sexp) != ENVSXP ){
- throw std::runtime_error( "not an environment" ) ;
- }
+ Environment::Environment( const std::string& name) throw(no_such_env) : RObject(R_EmptyEnv){
+ /* similar to matchEnvir at envir.c */
+ if( name == ".GlobalEnv" ) {
+ m_sexp = R_GlobalEnv ;
+ } else if( name == "package:base" ){
+ m_sexp = R_BaseEnv ;
+ } else{
+ Evaluator evaluator( Rf_lang2(Symbol("as.environment"), Rf_mkString(name.c_str()) ) ) ;
+ evaluator.run() ;
+ if( evaluator.successfull() ){
+ m_sexp = evaluator.getResult() ;
+ preserved = true ;
+ evaluator.getResult().forgetPreserve() ;
+ } else{
+ throw no_such_env(name) ;
+ }
+ }
}
-
+
+ Environment::Environment(int pos) throw(no_such_env) : RObject(R_EmptyEnv){
+ Evaluator evaluator( Rf_lang2(Symbol("as.environment"), Rf_ScalarInteger(pos) ) ) ;
+ evaluator.run() ;
+ if( evaluator.successfull() ){
+ m_sexp = evaluator.getResult() ;
+ preserved = true ;
+ evaluator.getResult().forgetPreserve() ;
+ } else{
+ throw no_such_env(pos) ;
+ }
+ }
+
Environment::~Environment(){
logTxt( "~Environment" ) ;
}
@@ -137,7 +184,7 @@
}
Environment Environment::empty_env() throw() {
- return Environment(R_GlobalEnv) ;
+ return Environment(R_EmptyEnv) ;
}
Environment Environment::base_env() throw(){
@@ -180,5 +227,22 @@
}
Environment::no_such_namespace::~no_such_namespace() throw() {}
+ Environment::no_such_env::no_such_env(const std::string& name) :
+ message("no environment called : '" + name + "'" ) {}
+ Environment::no_such_env::no_such_env(int pos) :
+ message("no environment in the given position" ) {}
+ const char* Environment::no_such_env::what() const throw(){
+ return message.c_str() ;
+ }
+ Environment::no_such_env::~no_such_env() throw() {}
+
+ Environment::not_compatible::not_compatible() throw() {}
+ const char* Environment::not_compatible::what() const throw(){
+ return "cannot convert to environment" ;
+ }
+ Environment::not_compatible::~not_compatible() throw() {}
+
+
+
} // namespace Rcpp
Modified: pkg/src/Evaluator.cpp
===================================================================
--- pkg/src/Evaluator.cpp 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Evaluator.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -32,7 +32,7 @@
Evaluator::~Evaluator(){}
- void Evaluator::run(SEXP env ){
+ void Evaluator::run(SEXP env ) throw() {
Environment rcpp = Environment::namespace_env("Rcpp") ;
SEXP call = Rf_lang3( Rf_install("protectedEval"), expression, env ) ;
result = wrap( Rf_eval( call, rcpp ) );
@@ -43,5 +43,9 @@
error.preserve() ;
}
}
-
+
+ void Evaluator::run() throw() {
+ run( R_GlobalEnv) ;
+ }
+
} // namespace Rcpp
Added: pkg/src/Language.cpp
===================================================================
--- pkg/src/Language.cpp (rev 0)
+++ pkg/src/Language.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,82 @@
+// -*- 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/Language.h>
+#include <Rcpp/Evaluator.h>
+#include <RcppCommon.h>
+
+namespace Rcpp {
+
+ Language::Language( SEXP lang = R_NilValue ) throw(not_compatible) : RObject::RObject(lang){
+ /* if this is not trivially a call, then try to convert it to one */
+ if( m_sexp != R_NilValue && TYPEOF(m_sexp) != LANGSXP ){
+
+ /* taken from do_ascall */
+ switch( TYPEOF(lang) ){
+ case LISTSXP :
+ m_sexp = Rf_duplicate( lang ) ;
+ break ;
+ case VECSXP:
+ case EXPRSXP:
+ {
+ int n = Rf_length(lang) ;
+ if( n == 0 ) throw not_compatible() ;
+ SEXP names = GET_NAMES(lang) ;
+ SEXP ap;
+ PROTECT( ap = m_sexp = 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) ;
+ }
+ default:
+ throw not_compatible() ;
+ }
+ SET_TYPEOF(m_sexp, LANGSXP);
+ SET_TAG(m_sexp, R_NilValue);
+ }
+
+ };
+
+ Language::Language( const std::string& symbol ): RObject::RObject(R_NilValue) {
+ m_sexp = Rf_lcons( Symbol(symbol), R_NilValue ) ;
+ preserve() ;
+ }
+
+ Language::Language( const Symbol& symbol ){
+ m_sexp = Rf_lcons( symbol, R_NilValue ) ;
+ preserve() ;
+ }
+
+ Language::~Language(){}
+
+ Language::not_compatible::not_compatible() throw() {}
+ const char* Language::not_compatible::what() const throw(){
+ return "cannot convert to call" ;
+ }
+ Language::not_compatible::~not_compatible() throw() {}
+
+
+
+} // namespace Rcpp
Modified: pkg/src/Makevars
===================================================================
--- pkg/src/Makevars 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Makevars 2010-01-03 08:53:19 UTC (rev 259)
@@ -25,7 +25,7 @@
USERLIB = libRcpp$(DYLIB_EXT)
USERLIBST = libRcpp.a
-PKG_CPPFLAGS += -I.
+PKG_CPPFLAGS += -I. -std=c++0x
userLibrary: $(USERLIB) $(USERLIBST)
- at if test ! -e $(USERDIR)$(R_ARCH); then mkdir -p $(USERDIR)$(R_ARCH); fi
Modified: pkg/src/RObject.cpp
===================================================================
--- pkg/src/RObject.cpp 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/RObject.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -20,12 +20,22 @@
// along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
#include <Rcpp/RObject.h>
+#include <Rcpp/Environment.h>
+#include <Rcpp/Symbol.h>
#include <algorithm>
namespace Rcpp {
RObject wrap(SEXP m_sexp=R_NilValue){
- return RObject(m_sexp) ;
+ switch( TYPEOF(m_sexp) ){
+ case ENVSXP:
+ return Environment(m_sexp);
+ case SYMSXP:
+ return Symbol(m_sexp) ;
+ default:
+ break ;
+ }
+ return RObject(m_sexp) ;
}
RObject wrap(const bool & v){
Modified: pkg/src/Rcpp/Environment.h
===================================================================
--- pkg/src/Rcpp/Environment.h 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Rcpp/Environment.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -94,15 +94,72 @@
std::string message ;
} ;
+ /**
+ * Exception thrown when attempting to convert a SEXP to
+ * an environment using as.environment
+ */
+ class not_compatible: public std::exception{
+ public:
+ not_compatible() throw() ;
+
+ /**
+ * The message: cannot convert to environment
+ */
+ const char* what() const throw() ;
+
+ ~not_compatible() throw() ;
+
+ } ;
+
+ /**
+ * Exception thrown when attempting to get an environment from a
+ * name
+ */
+ class no_such_env: public std::exception{
+ public:
+ /**
+ * @param name name of the environment, e.g "package:Rcpp"
+ */
+ no_such_env( const std::string& name) ;
+
+ /**
+ * @paral pos search path position where there is no environment
+ */
+ no_such_env(int pos) ;
+
+ /**
+ * The message: no such environment : '{name}'
+ */
+ const char* what() const throw() ;
+
+ ~no_such_env() throw() ;
+ private:
+ std::string message ;
+ } ;
/**
* wraps the given environment
*
* if the SEXP is not an environment, and exception is thrown
*/
- Environment(SEXP m_sexp) ;
+ Environment(SEXP x) throw(not_compatible);
/**
+ * Gets the environment associated with the given name
+ *
+ * @param name name of the environment, e.g "package:Rcpp"
+ */
+ Environment( const std::string& name ) throw(no_such_env) ;
+
+ /**
+ * Gets the environment in the given position of the search path
+ *
+ * @param pos (1-based) position of the environment, e.g pos=1 gives the
+ * global environment
+ */
+ Environment( int pos ) throw(no_such_env) ;
+
+ /**
* Nothing specific
*/
~Environment() ;
Modified: pkg/src/Rcpp/Evaluator.h
===================================================================
--- pkg/src/Rcpp/Evaluator.h 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Rcpp/Evaluator.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -32,10 +32,12 @@
public:
Evaluator(SEXP expression ) ;
~Evaluator() ;
- void run(SEXP env) ;
+ void run(SEXP env) throw() ;
+ void run() throw() ;
inline RObject getResult() const { return result ; }
inline RObject getError() const { return error ; }
-
+ inline bool successfull() const { return !error_occured ; }
+
private:
SEXP expression ;
bool error_occured ;
Added: pkg/src/Rcpp/Language.h
===================================================================
--- pkg/src/Rcpp/Language.h (rev 0)
+++ pkg/src/Rcpp/Language.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,136 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Language.h: 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/>.
+
+#ifndef Rcpp_Language_h
+#define Rcpp_Language_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+#include <Rcpp/Symbol.h>
+
+namespace Rcpp{
+
+/**
+ * C++ wrapper around calls (LANGSXP SEXP)
+ *
+ * This represents calls that can be evaluated
+ */
+class Language : public RObject{
+public:
+ /**
+ * Exception thrown when attempting to convert a SEXP to
+ * a call using as.call
+ */
+ class not_compatible: public std::exception{
+ public:
+ not_compatible() throw() ;
+
+ /**
+ * The message: cannot convert to call
+ */
+ const char* what() const throw() ;
+
+ ~not_compatible() throw() ;
+
+ } ;
+
+ /**
+ * Attempts to convert the SEXP to a call
+ *
+ * @throw not_compatible if the SEXP could not be converted
+ * to a call using as.call
+ */
+ Language(SEXP lang) throw(not_compatible) ;
+
+ /**
+ * Creates a call using the given symbol as the function name
+ *
+ * @param symbol symbol name to call
+ *
+ * Language( "rnorm" ) makes a SEXP similar to this (expressed in R)
+ * > as.call( as.list( as.name( "rnorm") ) )
+ * > call( "rnorm" )
+ */
+ Language( const std::string& symbol );
+
+ /**
+ * Creates a call using the given symbol as the function name
+ *
+ * @param symbol symbol name to call
+ *
+ * Language( Symbol("rnorm") ) makes a SEXP similar to this:
+ * > call( "rnorm" )
+ */
+ Language( const Symbol& symbol );
+
+ /**
+ * Creates a call to the given symbol using variable number of
+ * arguments
+ *
+ * @param symbol symbol
+ * @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 Language( "rnorm", 10, 0.0 )
+ * will create the same call as
+ * > call( "rnorm", 10L, 0.0 )
+ *
+ * 10 is wrapped as an integer vector using wrap( const& int )
+ * 0.0 is wrapped as a numeric vector using wrap( const& double )
+ * ...
+ */
+#ifdef CXX0X
+template<typename... Args>
+ Language( const std::string& symbol, const Args&... args) : RObject(R_NilValue) {
+ SEXP x;
+ PROTECT( x = Rf_lcons( Symbol(symbol), pack( args... ) ) );
+ m_sexp = x ;
+ UNPROTECT(1) ;
+ preserve() ;
+ }
+#endif
+ ~Language() ;
+
+private:
+
+ /* recursive packing of the arguments into a list,
+ use first as the CAR and build the CDR from the remaining args recursively */
+#ifdef CXX0X
+ template<typename T, typename... Args>
+ SEXP pack( const T& first, const Args&... args ){
+ return Rf_cons( wrap(first), pack( args... ) ) ;
+ }
+#endif
+
+ /* end of the recursion, wrap first to make the CAR and use
+ R_NilValue as the CDR of the list */
+#ifdef CXX0X
+template<typename T>
+ SEXP pack( const T& first){
+ return Rf_cons( wrap(first), R_NilValue ) ;
+ }
+#endif
+};
+
+} // namespace Rcpp
+
+#endif
Added: pkg/src/Rcpp/Symbol.h
===================================================================
--- pkg/src/Rcpp/Symbol.h (rev 0)
+++ pkg/src/Rcpp/Symbol.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,75 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Symbol.h: Rcpp R/C++ interface class library -- access R environments
+//
+// 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_Symbol_h
+#define Rcpp_Symbol_h
+
+#include <RcppCommon.h>
+#include <Rcpp/RObject.h>
+
+namespace Rcpp{
+
+class Symbol: public RObject{
+public:
+
+ /**
+ * Exception thrown when attempting to create a Symbol from a
+ * SEXP that is not compatible
+ */
+ class not_compatible: public std::exception{
+ public:
+ not_compatible(int type) throw() ;
+
+ /**
+ * The message: not compatible with Symbol
+ */
+ const char* what() const throw();
+
+ ~not_compatible() throw() ;
+
+ private:
+ int type ;
+ } ;
+
+ /**
+ * wraps the SEXP into a Symbol object.
+ *
+ * @param m_sexp Accepted SEXP types are SYMSXP, CHARSXP and STRSXP
+ * in the last case, the first element of the character vector
+ * is silently used
+ */
+ Symbol(SEXP x) throw(not_compatible) ;
+
+ /**
+ *
+ */
+ Symbol(const std::string& symbol) ;
+
+ /**
+ * Nothing specific
+ */
+ ~Symbol() ;
+
+};
+
+} // namespace Rcpp
+
+#endif
Modified: pkg/src/Rcpp.h
===================================================================
--- pkg/src/Rcpp.h 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/Rcpp.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -45,6 +45,8 @@
#include <Rcpp/RObject.h>
#include <Rcpp/XPtr.h>
#include <Rcpp/Environment.h>
-#include <Rcpp/Evaluator.h>
+#include <Rcpp/Evaluator.h>
+#include <Rcpp/Symbol.h>
+#include <Rcpp/Language.h>
#endif
Modified: pkg/src/RcppCommon.cpp
===================================================================
--- pkg/src/RcppCommon.cpp 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/RcppCommon.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -40,3 +40,32 @@
Rprintf("%s:%d %s\n", file, line, expression);
}
+SEXP test_variadic() {
+ SEXP res = PROTECT( Rf_allocVector(INTSXP, 5) ) ;
+#ifdef CXX0X
+ INTEGER(res)[0] = variadic_length() ;
+ INTEGER(res)[1] = variadic_length(1) ;
+ INTEGER(res)[2] = variadic_length(1, 3.3) ;
+ INTEGER(res)[3] = variadic_length(1, "foo", 'f') ;
+ INTEGER(res)[4] = variadic_length(1, 2, 2.3f, "foo", std::string("foobar") ) ;
+#else
+ INTEGER(res)[0] = 0 ;
+ INTEGER(res)[1] = 1 ;
+ INTEGER(res)[2] = 2 ;
+ INTEGER(res)[3] = 3 ;
+ INTEGER(res)[4] = 4 ;
+#endif
+ UNPROTECT(1) ;
+ return res;
+}
+
+SEXP canUseCXX0X(){
+ SEXP res ;
+#ifdef CXX0X
+ return Rf_ScalarLogical( TRUE ) ;
+#else
+ return Rf_ScalarLogical( FALSE ) ;
+#endif
+}
+
+
Modified: pkg/src/RcppCommon.h
===================================================================
--- pkg/src/RcppCommon.h 2010-01-03 01:24:38 UTC (rev 258)
+++ pkg/src/RcppCommon.h 2010-01-03 08:53:19 UTC (rev 259)
@@ -24,6 +24,10 @@
#ifndef RcppCommon_h
#define RcppCommon_h
+// TODO: need to bring this from the configure step
+// but I have no idea how to do it
+#define CXX0X
+
#include <exception>
#include <iostream>
#include <sstream>
@@ -40,7 +44,9 @@
#include <Rinternals.h>
#include <R_ext/Callbacks.h>
#include <Rversion.h>
+#define GET_NAMES(x) Rf_getAttrib(x, R_NamesSymbol)
+
// #ifdef BUILDING_DLL
// #define RcppExport extern "C" __declspec(dllexport)
// #else
@@ -59,4 +65,13 @@
void forward_uncaught_exceptions_to_r() ;
RcppExport SEXP initUncaughtExceptionHandler() ;
+/* just testing variadic templates */
+#ifdef CXX0X
+template<typename... Args>
+int variadic_length( const Args&... args) { return sizeof...(Args) ; }
#endif
+
+RcppExport SEXP test_variadic() ;
+RcppExport SEXP canUseCXX0X() ;
+
+#endif
Added: pkg/src/Symbol.cpp
===================================================================
--- pkg/src/Symbol.cpp (rev 0)
+++ pkg/src/Symbol.cpp 2010-01-03 08:53:19 UTC (rev 259)
@@ -0,0 +1,61 @@
+// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
+//
+// Symbol.cpp: Rcpp R/C++ interface class library -- Symbols
+//
+// 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/Symbol.h>
+
+namespace Rcpp {
+
+ Symbol::not_compatible::not_compatible(int type) throw() {}
+ Symbol::not_compatible::~not_compatible() throw() {}
+ const char* Symbol::not_compatible::what() const throw() {
+ return "not compatible with Symbol, excepting SYMSXP, CHARSXP or STRSXP" ;
+ }
+
+ Symbol::Symbol( SEXP x = R_NilValue ) throw(not_compatible) : RObject::RObject(x) {
+ if( m_sexp != R_NilValue ){
+ int type = TYPEOF(m_sexp) ;
+ switch( type ){
+ case SYMSXP:
+ break; /* nothing to do */
+ case CHARSXP:
+ m_sexp = Rf_install(CHAR(m_sexp)) ;
+ break ;
+ case STRSXP:
+ {
+ /* FIXME: check that there is at least one element */
+ m_sexp = Rf_install( CHAR(STRING_ELT(m_sexp, 0 )) ) ;
+ break ;
+ }
+ default:
+ throw not_compatible(type) ;
+ }
+ }
+ }
+
+ Symbol::Symbol(const std::string& symbol){
+ m_sexp = Rf_install(symbol.c_str()) ;
+ preserve() ;
+ }
+
+ Symbol::~Symbol(){}
+
+} // namespace 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