support ETaccessorBase as a type with its own symbol

nCompiler/R/compile_aaa_operatorLists.R

@@ -111,6 +111,20 @@ getOperatorDef <- function(op, field = NULL, subfield = NULL) {
   getOperatorField(opDef, field, subfield)
 }
 
+assignOperatorDef(
+  'ETaccess',
+  list(
+    matchDef = function(obj, copy=FALSE) {},
+    compileArgs = "copy",
+    simpleTransformations = list(
+      handler = 'EvalCompileArgs'),
+    labelAbstractTypes = list(
+      handler = 'ETaccess'),
+    cppOutput = list(
+      handler = 'ETaccess')
+  )
+)
+
 assignOperatorDef(
   'nCppVec',
   list(

nCompiler/R/compile_generateCpp.R

@@ -207,6 +207,18 @@ inGenCppEnv(
   }
 )
 
+inGenCppEnv(
+  ETaccess <- function(code, symTab) {
+    copy <- isTRUE(code$aux$compileArgs$copy)
+    copy_piece <- if(copy) '<true>' else ''
+    paste0('ETaccessPtr', copy_piece, '(',
+           paste0(unlist(lapply(code$args,
+                                compile_generateCpp,
+                                symTab,
+                                asArg = TRUE)), collapse=","), ")")
+  }
+)
+
 inGenCppEnv(
   Switch <- function(code, symTab) {
     IDs <- code$aux$compileArgs$IDs

nCompiler/R/compile_labelAbstractTypes.R

@@ -265,6 +265,15 @@ inLabelAbstractTypesEnv(
   }
 )
 
+inLabelAbstractTypesEnv(
+  ETaccess <- function(code, symTab, auxEnv, handlingInfo) {
+    inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv,
+                                          handlingInfo)
+    code$type <- symbolETaccBase$new(name = '') # should never be looked at because ETaccess has no return type
+    if(length(inserts) == 0) NULL else inserts
+  }
+)
+
 nCompiler:::inLabelAbstractTypesEnv(
   DoubleBracket <- function(code, symTab, auxEnv, handlingInfo) {
     # specializations from generic will have already been handled

nCompiler/R/compile_simpleTransformations.R

@@ -156,4 +156,13 @@ inSimpleTransformationsEnv(
     code$aux$compileArgs$IDs <- IDs
     if(code$caller$name != "{") stop("nSwitch can not be used within an expression. It does not return anything.")
   }
+)
+
+inSimpleTransformationsEnv(
+  EvalCompileArgs <- function(code, symTab, auxEnv, info) {
+    for(argname in names(code$aux$compileArgs)) {
+      evaled_arg <- eval(code$aux$compileArgs[[argname]], envir = auxEnv$where)
+      code$aux$compileArgs[[argname]] <- evaled_arg
+    }
+  }
 )

nCompiler/R/cppDefs_variables.R

@@ -26,7 +26,7 @@ cppVarClass <- R6::R6Class(
       if(length(printName) > 0)
         printName <- paste0(printName, collapse = ', ')
       cleanWhite(paste(self$baseType,
-                       self$ptrs,
+                       ptrs,
                        if(isTRUE(self$ref))
                          '&'
                        else
@@ -195,10 +195,11 @@ cppNcppVec <- function(name = character(),
                       templateArgs = list(elementVar))
 }
 
-cppETaccBase <- function(name = character()) {
+cppETaccBase <- function(name = character(), ...) {
   cppVarFullClass$new(name = name,
                       baseType = "std::unique_ptr",
-                      templateArgs = list("ETaccessorBase"))
+                      templateArgs = list("ETaccessorBase"), 
+                      ...)
 }
 
 cppEigenTensorRef <- function(name = character(),

nCompiler/R/symbolTable.R

@@ -499,10 +499,9 @@ symbolETaccBase <- R6::R6Class(
   inherit = symbolBase,
   portable = TRUE,
   public = list(
-    initialize = function(name, isArg = FALSE) {
-      self$name <- name
+    initialize = function(...) {
+      super$initialize(...)
       self$type <- "ETaccessorBase"
-      self$isArg <- isArg
     },
     print = function() {
       writeLines(paste0(self$name, ': symbolETaccBase (ETaccessorBase) '))
@@ -511,7 +510,7 @@ symbolETaccBase <- R6::R6Class(
       paste0("ETaccessorBase")
     },
     genCppVar = function() {
-      cppETaccBase(name = self$name)
+      cppETaccBase(name = self$name, ref = self$isArg)
     }
   )
 )

nCompiler/R/typeDeclarations.R

@@ -366,7 +366,7 @@ typeDeclarationList <- list(
   ##   symbolRcppType$new(RcppType = "Rcpp::Named", ...)
   ## },
   RcppDataFrame = function(...) {
-    symbolRcppType$new(RcppType = "Rcpp::DataFrame")
+    symbolRcppType$new(RcppType = "Rcpp::DataFrame", ...)
   },
   RcppLogicalMatrix = function(...) {
     symbolRcppType$new(RcppType = "Rcpp::LogicalMatrix", ...)
@@ -414,6 +414,9 @@ typeDeclarationList <- list(
     elementSym <- type2symbol({{ttype}}, where = parent.frame())
     symbolNcppVec$new(elementSym = elementSym)
   },
+  ETaccessor = function(...) {
+    symbolETaccBase$new(...)
+  },
   ## determine type from an evaluated object
   typeDeclarationFromObject = function(x) {
     if(inherits(x, 'symbolBasic'))

nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h

@@ -2,6 +2,7 @@
 #define NCOMPILER_ETACCESSOR_POST_RCPP_H_
 
 #include <unsupported/Eigen/CXX11/Tensor>
+#include <memory>
 #include <type_traits>
 #include <nCompiler/ET_ext/StridedTensorMap.h>
 #include <nCompiler/ET_ext/post_Rcpp/tensorUtils.h>
@@ -394,6 +395,18 @@ ETaccess(const T &x) {
   return ETaccessor<T, true>(x);
 }
 
+template<bool copy=false, typename T>
+std::enable_if_t<!copy, std::unique_ptr<ETaccessorBase>>
+ETaccessPtr(T &x) {
+  return std::make_unique<ETaccessor<T, false>>(x);
+}
+
+template<bool copy, typename T>
+std::enable_if_t<copy, std::unique_ptr<ETaccessorBase>>
+ETaccessPtr(const T &x) {
+  return std::make_unique<ETaccessor<T, true>>(x);
+}
+
 // end ETaccess
 
 #endif // NCOMPILER_ETACCESSOR_POST_RCPP_H_

nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R

@@ -1,6 +1,65 @@
 library(nCompiler)
 library(testthat)
 
+test_that("ETaccessor type works", {
+  nc <- nClass(
+    Cpublic = list(
+      s = 'numericScalar',
+      v = 'numericVector',
+      m = 'numericMatrix',
+      get_s = nFunction(
+        function() {
+          ans <- ETaccess(s)
+          return(ans)
+          returnType('ETaccessor')
+        }
+      ),
+      get_inner = nFunction(
+        function(vn = 'string') {
+          ans <- self[[vn]]
+          return(ans)
+          returnType('ETaccessor')
+        }
+      ),
+      use = nFunction(
+        function(acc = 'ETaccessor') {
+          return(as(acc, "numericMatrix"))
+          returnType("numericMatrix")
+        }
+      ),
+      get = nFunction(
+        function(i = 'integerScalar', vn = 'string') {
+          nSwitch(i, 1:4,
+                  eta <- get_s(),
+                  eta <- get_inner(vn),
+                  eta <- self[[vn]],
+                  {
+                    eta <- self[[vn]]
+                    res <- use(eta)
+                  }
+                  )
+          if(i < 4)
+            res <- as(eta, "numericMatrix")
+          return(res)
+          returnType("numericMatrix")
+        }
+      )
+    ),
+    compileInfo=list(interfaceMembers = c("s","v","m", "get"))
+  )
+
+  cnc <- nCompile(nc)
+  obj <- cnc$new()
+  obj$s <- 1.2
+  obj$v <- c(2.3, 3.4)
+  obj$m <- matrix(5:10, nrow = 3)
+  expect_equal(obj$get(1, "not_used"), matrix(1.2))
+  expect_equal(obj$get(2, "v"), matrix(obj$v))
+  expect_equal(obj$get(3, "m"), obj$m)
+  expect_equal(obj$get(4, "v"), matrix(obj$v))
+  rm(obj); gc()
+})
+
 test_that("obj[['x']] works like obj$x", {
   nc <- nClass(
     Cpublic = list(