Passing down unevaluated parameters

dots.cpp

#include <Rcpp.h>
using namespace Rcpp ;

class ExtractArgs {
public:
    
    ExtractArgs( List calls_, List frames_ ) : 
        calls(calls_), frames(frames_), env(0), exprs(0), tags(0)
    {
        init() ;
    }
        
    List eval(){
        int n = exprs.size() ;
        List out(n) ;
        CharacterVector names(n) ; int n_names = 0 ;
        for( int i=0; i<n; i++){
            out[i] = Rf_eval( exprs[i], env[i] ) ;
            SEXP tag = tags[i] ;
            if( tag != R_NilValue ) {
                names[i] = PRINTNAME(tag) ;
                n_names++ ;
            }
        }
        if( n_names ) out.names() = names ;
        return out ;
    }
   
private:
    
    void init(){
        process( frames.size() - 1 ) ;
    }
    
    void process(int i){
        if( i < 0 ) return ;
        SEXP p = calls[i] ;
        if( TYPEOF(p) != LANGSXP ) return ;
        
        p = CDR(p) ;
        SEXP head ;
        while( p != R_NilValue ){
            head = CAR(p) ;
            if( is_ellipsis(head) ) {
                process(i-1) ;
            } else {
                exprs.push_back( head ) ;
                env.push_back( frames[i-1] ) ;
                tags.push_back( TAG(p) );
            }
            p = CDR(p) ;
        }
    }
    
    bool is_ellipsis( SEXP x){
         return x == R_DotsSymbol ;   
    }
    
    List calls, frames ;
    // all of what we put in there is already protected by R. 
    std::vector<SEXP> env ;
    std::vector<SEXP> exprs ;
    std::vector<SEXP> tags ;
    
} ;

// [[Rcpp::export]]
List deal_with__impl( List calls, List frames ){
    ExtractArgs xxx( calls, frames ) ;
    return xxx.eval() ;
}

dots.R

require(Rcpp)
sourceCpp( "dots.cpp" )

x <- 1
f <- function(...) {
  x <- 2 
  g(..., b = x)
}

g <- function(...) {
  x <- 3
  foo <- function(){ 4 }
  deal_with(..., c = x, d = foo() )
}

deal_with <- function(...) {
    calls  <- sys.calls()
    frames <- sys.frames()
    deal_with__impl( calls, frames )
}

x <- 1
foo <- function(x) x*x
f( x, foo(3) )

# expecting : 
# - 1       : coming from the global env  
# - 9       : evaluation of foo in the global env
# - "b" = 2 : coming from the environment of f
# - "c" = 3 : coming from the environment of g
# - "d" = 4 : evaluation of foo in the environment of g

dots.txt

> x <- 1

> f <- function(...) {
+     x <- 2
+     g(..., b = x)
+ }

> g <- function(...) {
+     x <- 3
+     foo <- function() {
+         4
+     }
+     deal_with(..., c = x, d = foo())
+ }

> deal_with <- function(...) {
+     calls <- sys.calls()
+     frames <- sys.frames()
+     deal_with__impl(calls, frames)
+ }

> x <- 1

> foo <- function(x) x * x

> f(x, foo(3))
[[1]]
[1] 1

[[2]]
[1] 9

$b
[1] 2

$c
[1] 3

$d
[1] 4

> with(iris, f(Sepal.Length))
[[1]]
  [1] 5.1 4.9 4.7 4.6 5.0 5.4 4.6 5.0 4.4 4.9 5.4 4.8 4.8 4.3 5.8 5.7 5.4 5.1
 [19] 5.7 5.1 5.4 5.1 4.6 5.1 4.8 5.0 5.0 5.2 5.2 4.7 4.8 5.4 5.2 5.5 4.9 5.0
 [37] 5.5 4.9 4.4 5.1 5.0 4.5 4.4 5.0 5.1 4.8 5.1 4.6 5.3 5.0 7.0 6.4 6.9 5.5
 [55] 6.5 5.7 6.3 4.9 6.6 5.2 5.0 5.9 6.0 6.1 5.6 6.7 5.6 5.8 6.2 5.6 5.9 6.1
 [73] 6.3 6.1 6.4 6.6 6.8 6.7 6.0 5.7 5.5 5.5 5.8 6.0 5.4 6.0 6.7 6.3 5.6 5.5
 [91] 5.5 6.1 5.8 5.0 5.6 5.7 5.7 6.2 5.1 5.7 6.3 5.8 7.1 6.3 6.5 7.6 4.9 7.3
[109] 6.7 7.2 6.5 6.4 6.8 5.7 5.8 6.4 6.5 7.7 7.7 6.0 6.9 5.6 7.7 6.3 6.7 7.2
[127] 6.2 6.1 6.4 7.2 7.4 7.9 6.4 6.3 6.1 7.7 6.3 6.4 6.0 6.9 6.7 6.9 5.8 6.8
[145] 6.7 6.7 6.3 6.5 6.2 5.9

$b
[1] 2

$c
[1] 3

$d
[1] 4