fix C++ handling (Exporter and generic interface set) of new nClass structure

Author: perrydv

nCompiler/R/NC.R

@@ -295,7 +295,7 @@ make_nClass_code <- function(internals,
                 list(isCompiled = function() FALSE)),
       private = list(
         Cpublic_obj = NULL,
-        init_Cpublic_obj_code = quote(.Cpub_class$new()),
+        init_Cpublic_obj_code = quote(.Cpub_class$new(...)),
         initialize_Cpublic_obj = function(...) {
           private$Cpublic_obj <- eval(private$init_Cpublic_obj_code)
         }

nCompiler/R/NC_FullCompiledInterface.R

@@ -156,32 +156,32 @@ build_compiled_nClass <- function(NCgenerator,
   CnCgenerator
 } 
 
-buildActiveBinding_for_compiled_nClass <- function(NCI, fieldNames) {
+# buildActiveBinding_for_compiled_nClass <- function(NCI, fieldNames) {
   #fieldNames <- NCI$fieldNames
-  symTab <- NCI$symbolTable
-  activeBindings <- list()
-  newFields <- list()
-  for(name in fieldNames) {
-    ans <- function(value) {}
-    sym <- symTab$getSymbol(name)
-    if(is.null(sym)) {
-      warning(paste0("Could not find a way to build active binding for field ", name, "."))
-      return(ans)
-    }
-    body(ans) <- substitute(
-    {
-      if(missing(value))
-        private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME)
-      else
-        private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value)
-    },
-    list(NAME = name)
-    )
-    activeBindings[[name]] <- ans
-  }
-  list(activeBindings = activeBindings,
-       newFields = newFields)
-}
+#   symTab <- NCI$symbolTable
+#   activeBindings <- list()
+#   newFields <- list()
+#   for(name in fieldNames) {
+#     ans <- function(value) {}
+#     sym <- symTab$getSymbol(name)
+#     if(is.null(sym)) {
+#       warning(paste0("Could not find a way to build active binding for field ", name, "."))
+#       return(ans)
+#     }
+#     body(ans) <- substitute(
+#     {
+#       if(missing(value))
+#         private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME)
+#       else
+#         private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value)
+#     },
+#     list(NAME = name)
+#     )
+#     activeBindings[[name]] <- ans
+#   }
+#   list(activeBindings = activeBindings,
+#        newFields = newFields)
+# }
 
 make_compiled_nClass_code <- function(NCgenerator) {
   classname <- NCinternals(NCgenerator)$compileInfo$classname
@@ -248,8 +248,10 @@ make_compiled_Cpub_class_code <- function(NCgenerator,
   initialize_fun <- NC_get_Cpub_class(NCgenerator)$public_methods[["initialize"]]
   if(is.null(initialize_fun)) {
     if(!omit_automatic_Cpp_construction) {
+      # The ... argument to initialize is important because it will be called
+      # with ... from the outer R6generator, which might have other arguments embedded in the ...
       Rmethods_code_list[["initialize"]] <- quote(
-        function(CppObj) {self$initializeCpp(CppObj)}
+        function(CppObj, ...) {self$initializeCpp(CppObj)}
       )
     }
   } else {
@@ -276,7 +278,7 @@ make_compiled_Cpub_class_code <- function(NCgenerator,
         private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value)
     },
     list(NAME = name)
-    )
+    ) |> removeSource()
     activeBindings_code_list[[name]] <- ABcode
   }
   activeBindings_code <- do.call("call", c("list",
@@ -291,7 +293,7 @@ make_compiled_Cpub_class_code <- function(NCgenerator,
 
   Cpub_inherit_arg <- if(package) {
     if(is.null(inheritName)) quote(nCompiler::CpubClass)
-    else substitute(IRN$parent_env$.Cpub_class, list(IRN=as.name(paste0(inheritName, "_C_compiled"))))
+    else substitute(IRN$parent_env$.Cpub_class, list(IRN=as.name(paste0(".", inheritName, "_CnCgenerator_CpubGen"))))
   } else {
     if(is.null(inheritName)) quote(nCompiler::CpubClass)
     else quote(.Cpub_base_class)

nCompiler/R/NC_Utils.R

@@ -40,7 +40,7 @@ isNCgenerator <- function(x) {
 #' @export
 isCompiledNCgenerator <- function(x) {
   if(inherits(x, "R6ClassGenerator"))
-    exists(".newCobjFun", x)
+    exists(".newCobjFun", x$parent_env)
   else
     FALSE
 }

nCompiler/R/NF_PassByReference.R

@@ -4,6 +4,8 @@
 passByReference <- function(fun,
                             refArgs = character(),
                             blockRefArgs = character()) {
+  # The format from an NFinternals object is a named list of TRUE/FALSE values,
+  # so convert that to a character vector of names for the TRUE ones.
   if(is.list(refArgs))
     refArgs <- names(refArgs)[ unlist(lapply(refArgs, isTRUE)) ]
 
@@ -16,17 +18,22 @@ passByReference <- function(fun,
   if((length(refArgs)==0) & length(blockRefArgs)==0)
     return(fun)
 
+  # fun can be a function or the body of a function.
   passedAsFunction <- is.function(fun)
   code <- if(passedAsFunction)
             body(fun)
           else
             fun
 
+  # Helper to create a substitution list from argument names
+  # e.g. ("x", "_suffix") -> list(x = as.name("x_suffix"))
   args_2_subList <- function(args, suffix)
     args |>
       lapply(function(x) as.name(paste0(x, suffix))) |>
       structure(names = args)
 
+  # Helper to create lines of code for active bindings
+  # e.g. nCompiler::createRef("x_suffix", x) # either createRef or createBlockRef
   subList_2_lines <- function(subList,
                               fun_name) {
     lines <- list()
@@ -41,12 +48,17 @@ passByReference <- function(fun,
     lines
   }
 
+  # From "x", create lines like
+  # nCompiler::createRef("x_Ref__", x)
   subList <- args_2_subList(refArgs, "_Ref__")
   refArg_activeBinding_lines <- subList_2_lines(subList, "createRef")
 
+  # From "y", create lines like
+  # nCompiler::createBlockRef("y_BlockRef__", y)
   blockSubList <- args_2_subList(blockRefArgs, "_BlockRef__")
   blockRefArg_activeBinding_lines <- subList_2_lines(blockSubList, "createBlockRef")
 
+  # In the original code, replace x with x_Ref__, y with y_BlockRef__, etc.
   code <-
     eval(
       substitute(
@@ -56,6 +68,7 @@ passByReference <- function(fun,
       )
     )
 
+  # Wrap in braces if not already
   if(code[[1]] != '{')
     code <- substitute({CODE}, list(CODE=code))
 
@@ -102,8 +115,7 @@ createRef <- function(innerName,
 createBlockRef <- function(innerName,
                            outerCode,
                            env,
-                           innerEnv,
-                           dummyName = 'DUMMY_FOR_CREATE_BLOCK_REF_') {
+                           innerEnv) {
   # There is potential for more elaborate error-trapping.
   # E.g. we could determine the sizes (or net length) of outerCode (assignment target)
   # and check that v matches it.
@@ -117,19 +129,18 @@ createBlockRef <- function(innerName,
       stop("A block reference argument must be passed as a variable name, e.g. `x`, or an indexed block of a variable, e.g. `x[1:4, 2:3]` or `x[1:4, ]`.")
   }
   outerLen <- eval(substitute(length(OC), list(OC = outerCode)), envir=env)
-  outer_dummy_assign_code <- substitute(L <- R,
-                                        list(L = outerCode,
-                                             R = as.name(dummyName)))
+  assignment_code <- substitute(L <- NULL,
+                                list(L = outerCode))
   binding <-
     function(v)
       if(missing(v))
         eval(outerCode, env)
       else {
         if(outerLen != length(v))
           stop("blockRef assignment must match in length.")
-        assign(dummyName, v, env)
-        on.exit(rm(list = dummyName, envir = env))
-        eval(outer_dummy_assign_code, env)
+        assignment_code[[3]] <<- v
+        eval(assignment_code, env)
+        assignment_code[[3]] <<- NULL
         v
       }
   makeActiveBinding(innerName, binding, innerEnv)

nCompiler/R/compile_labelAbstractTypes.R

@@ -654,6 +654,10 @@ inLabelAbstractTypesEnv(
         if(!symTab$symbolExists(LHS$name, TRUE)) {
           newSym <- RHStype$clone()
           newSym$isArg <- FALSE
+          # Assignment from a reference (could be a refArg) or a blockRef (blockRefArg) should be a plain type
+          newSym$isRef <- FALSE
+          if(!is.null(newSym$isBlockRef))
+            newSym$isBlockRef <- FALSE
           newSym$name <- LHS$name
           symTab$addSymbol(newSym)
           LHS$type <- newSym

nCompiler/R/nCompile.R

@@ -385,6 +385,8 @@ nCompile <- function(...,
                  memberData = list(),
                  roxygen = list()
                  )
+    if(isTRUE(get_nOption('pause_after_writing_files')))
+      browser()
     lib <- file.path(tempdir(), "templib")
     if(!dir.exists(lib)) dir.create(lib, recursive=TRUE)
     pkgDir <- file.path(dir, temppkgname)