From d8991db65640c005d7d1b526d0422a36327b5937 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 16 Jun 2026 16:45:25 -0700 Subject: [PATCH 01/11] use namespace_env to access nCompiler from Rcpp. Fix value<- return object. --- nCompiler/R/NC_SimpleInterface.R | 10 ++++++---- .../nC_inter/post_Rcpp/loadedObjectHookC_impl.h | 4 ++-- nCompiler/inst/nCompLocal_files/loadedObjectEnv.cpp | 2 +- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/nCompiler/R/NC_SimpleInterface.R b/nCompiler/R/NC_SimpleInterface.R index 06430e70..d1a94a2d 100644 --- a/nCompiler/R/NC_SimpleInterface.R +++ b/nCompiler/R/NC_SimpleInterface.R @@ -46,13 +46,15 @@ value <- function(obj, name) { #' @export `value<-` <- function(obj, name = NULL, value) { - if(inherits(obj, "nClass")) + if(inherits(obj, "nClass")) { if(obj$isCompiled()) - obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj + work_obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj else stop("value<-() can only be used on compiled nClass objects.") - DLLenv <- get_DLLenv(obj) - extptr <- getExtptr(obj) + } else + work_obj <- obj # should be a loadedObjectEnv (we lack error-trapping to confirm this.) + DLLenv <- get_DLLenv(work_obj) + extptr <- getExtptr(work_obj) DLLenv$set_value(extptr, name, value) obj } diff --git a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/loadedObjectHookC_impl.h b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/loadedObjectHookC_impl.h index 2748bbd0..a317734c 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/loadedObjectHookC_impl.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/loadedObjectHookC_impl.h @@ -10,12 +10,12 @@ class loadedObjectHookC : public loadedObjectHookBaseC { static void set_CnClass_env(Rcpp::Environment env) {CnClass_env = env;} static Rcpp::Environment get_CnClass_env() {return CnClass_env;} static SEXP setup_R_return_object_full(SEXP Xptr) { - Rcpp::Environment nc("package:nCompiler"); + Rcpp::Environment nc = Rcpp::Environment::namespace_env("nCompiler"); Rcpp::Function newLOE(nc["new.loadedObjectEnv_full"]); return newLOE(Xptr, CnClass_env); }; static SEXP setup_R_return_object(SEXP Xptr) { - Rcpp::Environment nc("package:nCompiler"); + Rcpp::Environment nc = Rcpp::Environment::namespace_env("nCompiler"); Rcpp::Function newLOE(nc["new.loadedObjectEnv"]); return newLOE(Xptr, CnClass_env); }; diff --git a/nCompiler/inst/nCompLocal_files/loadedObjectEnv.cpp b/nCompiler/inst/nCompLocal_files/loadedObjectEnv.cpp index db44112f..2731cea3 100644 --- a/nCompiler/inst/nCompLocal_files/loadedObjectEnv.cpp +++ b/nCompiler/inst/nCompLocal_files/loadedObjectEnv.cpp @@ -5,7 +5,7 @@ // [[Rcpp::depends(nCompiler)]] SEXP loadedObjectEnv(SEXP Xptr) { - Rcpp::Environment nc("package:nCompiler"); + Rcpp::Environment nc = Rcpp::Environment::namespace_env("nCompiler"); Rcpp::Function newLOE = nc["new.loadedObjectEnv"]; return newLOE(Xptr); } From 5a103d99c6cfb360f7226e2638cd119fa140dcd2 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 22 Jun 2026 14:06:41 -0700 Subject: [PATCH 02/11] Add NFinternals$update_code. Do not assume obj$v has known v in labelAbstractTypes --- nCompiler/R/NF_InternalsClass.R | 9 ++++++++- nCompiler/R/compile_labelAbstractTypes.R | 25 ++++++++++++------------ nCompiler/R/cppDefs_variables.R | 2 +- nCompiler/R/symbolTable.R | 1 + 4 files changed, 23 insertions(+), 14 deletions(-) diff --git a/nCompiler/R/NF_InternalsClass.R b/nCompiler/R/NF_InternalsClass.R index 63a4265c..64a9ac09 100644 --- a/nCompiler/R/NF_InternalsClass.R +++ b/nCompiler/R/NF_InternalsClass.R @@ -120,7 +120,7 @@ NF_InternalsClass <- R6::R6Class( ## changeKeywords.R self$code <- body(fun_to_use) if(code[[1]] != '{') - self$code <- substitute({CODE}, list(CODE=code)) + self$code <- substitute({CODE}, list(CODE=self$code)) ## check all code except.nCompiler package nFunctions ## if(check && "package.nCompiler" %in% search()) ## nf_checkDSLcode(code, methodNames, setupVarNames) @@ -194,6 +194,13 @@ NF_InternalsClass <- R6::R6Class( } } }, + updateCode = function(newCode) { + self$code <- newCode + if(self$code[[1]] != '{') + self$code <- substitute({CODE}, list(CODE=self$code)) + if(isTRUE(self$control$changeKeywords)) + self$code <- nf_changeKeywords(self$code) + }, getFunction = function() { #functionAsList <- list(as.name('function')) #functionAsList[2] <- list(NULL) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 9e62a7df..38d9c47f 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -284,18 +284,19 @@ nCompiler:::inLabelAbstractTypesEnv( inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo, useArgs = useArgs) if(inherits(code$args[[1]]$type, "symbolNC")) { - if(isTRUE(code$args[[2]]$isLiteral)) { - # This case is from the end of DollarSign (could be combined) - innerName <- as.character(code$args[[2]]$name) - symbol <- NCinternals(code$args[[1]]$type$NCgenerator)$symbolTable$getSymbol(innerName, inherits=TRUE) - if(is.null(symbol)) - stop(exprClassProcessingErrorMsg( - code, - paste0('member variable ', innerName, ' of ', code$args[[1]]$name, ' could not be found.') - ), call. = FALSE) - code$type <- symbol$clone(deep = TRUE) - code$name <- '->member' - } else { + # if(isTRUE(code$args[[2]]$isLiteral)) { + # # This case is from the end of DollarSign (could be combined) + # innerName <- as.character(code$args[[2]]$name) + # symbol <- NCinternals(code$args[[1]]$type$NCgenerator)$symbolTable$getSymbol(innerName, inherits=TRUE) + # if(is.null(symbol)) + # stop(exprClassProcessingErrorMsg( + # code, + # paste0('member variable ', innerName, ' of ', code$args[[1]]$name, ' could not be found.') + # ), call. = FALSE) + # code$type <- symbol$clone(deep = TRUE) + # code$name <- '->member' + # } else { + { code$type <- symbolETaccBase$new(name = '') code$name <- '->method' insertArg(code, 2, exprClass$new(name = 'access', isName = TRUE, isCall = FALSE, diff --git a/nCompiler/R/cppDefs_variables.R b/nCompiler/R/cppDefs_variables.R index 3db21e4d..ab0e1317 100644 --- a/nCompiler/R/cppDefs_variables.R +++ b/nCompiler/R/cppDefs_variables.R @@ -198,7 +198,7 @@ cppNcppVec <- function(name = character(), cppETaccBase <- function(name = character(), ...) { cppVarFullClass$new(name = name, baseType = "std::unique_ptr", - templateArgs = list("ETaccessorBase"), + templateArgs = list("ETaccessorBase"), ...) } diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index a8bf1b86..e55560fe 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -501,6 +501,7 @@ symbolETaccBase <- R6::R6Class( public = list( initialize = function(...) { super$initialize(...) + self$interface <- FALSE self$type <- "ETaccessorBase" }, print = function() { From 8e314948e1eec9a5799429f3cfcc008f6c2f907e Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 24 Jun 2026 14:25:53 -0700 Subject: [PATCH 03/11] Enhance type declarations to allow a call like "env$nctype()" --- nCompiler/R/NC_InternalsClass.R | 1 - nCompiler/R/typeDeclarations.R | 26 ++++++++++++++----- .../tests/testthat/types_tests/test-types.R | 12 +++++++++ 3 files changed, 31 insertions(+), 8 deletions(-) diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index fbf0354f..eac9a87d 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -130,7 +130,6 @@ NC_InternalsClass <- R6::R6Class( if(!isNCgenerator(inherit_obj)) stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") self$inheritNCinternals <- NCinternals(inherit_obj) - message("add check that base class has interface 'none'") if(!self$inherit_base_provided) { self$compileInfo$nClass_inherit$base <- self$inheritNCinternals$cpp_classname # don't paste "public" because it will go in interface_resolver< } diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 16ca0666..3e361374 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -28,13 +28,15 @@ nTypeSpec <- function(type = NULL) { } ## allow e.g. 'scalarInteger' to become scalarInteger() if(is.name(typeToUse)) { + funExpr <- typeToUse funName <- deparse(typeToUse) args <- list() } else { - funName <- deparse(typeToUse[[1]]) + funExpr <- typeToUse[[1]] + funName <- deparse(funExpr) args <- typeToUse[-1] |> as.list() } - list(funName = funName, args = args, inputAsCharacter = inputAsCharacter) |> + list(funName = funName, args = args, inputAsCharacter = inputAsCharacter, funExpr = funExpr) |> structure(class = "nTypeSpec") } @@ -829,13 +831,18 @@ check_unknown_types <- function(type, where = parent.frame(), if(is.null(typeSpec)) { typeSpec <- nTypeSpec(ttype) } - funName <- typeSpec$funName if(!identical(rlang::quo_get_env(ttype), emptyenv())) { where <- rlang::quo_get_env(ttype) } - candidate <- nGet(funName, - where = where, - project_env = project_env) # project_env should not be relevant but can be checked in case of trickiness + funName <- typeSpec$funName + funExpr <- typeSpec$funExpr + if(!is.name(funExpr)) { + candidate <- eval(funExpr, env = where) + } else { + candidate <- nGet(funName, + where = where, + project_env = project_env) + } if(!isNCgenerator(candidate)) { candidate2 <- check_built_types(candidate = candidate, typeSpec = typeSpec, where = where, @@ -863,8 +870,13 @@ check_built_types <- function(Rexpr = NULL, candidate = NULL, } ttype <- nType(expr = Rexpr, env = where) typeSpec <- nTypeSpec(ttype) - if(!is.null(candidate)) + if(is.null(candidate)) + funExpr <- typeSpec$funExpr + if(!is.name(funExpr)) { + candidate <- rlang::eval(funExpr, env = where) + } else { candidate <- nGet(typeSpec$funName, where = where) #project_env not useful here + } } if(inherits(candidate, "nClassBuilder")) { diff --git a/nCompiler/tests/testthat/types_tests/test-types.R b/nCompiler/tests/testthat/types_tests/test-types.R index 4c684ec0..5d65afeb 100644 --- a/nCompiler/tests/testthat/types_tests/test-types.R +++ b/nCompiler/tests/testthat/types_tests/test-types.R @@ -566,6 +566,18 @@ test_that("symbolTBD works", "std::shared_ptr nc1obj") }) +test_that("symbolTBD works with a function from a call", { + nCompiler:::resetLabelFunctionCreators() + myenv <- new.env() + myenv$nc1 <- nClass( + Cpublic = list(a = 'numericScalar') + ) +# sym_nc1 <- nCompiler:::type2symbol("myenv$nc1", "nc1obj") + sym_nc1 <- nCompiler:::type2symbol("myenv$nc1()", "nc1obj") + debug(nCompiler:::check_unknown_types) + res <- sym_nc1$resolveSym() +}) + cat("\nSee test-types.R for notes on remaining issues to test.\n") ## Need to make refs work with slices and blocks ## Need to enforce that with isRef=TRUE, no form of default value is valid, From 06e2b063506d41285e2c2d140bb01932f13a789e Mon Sep 17 00:00:00 2001 From: perrydv Date: Sat, 11 Jul 2026 12:30:32 -0700 Subject: [PATCH 04/11] Provide RuntimeFlatView to support values() in nimble2 --- nCompiler/R/NC_InternalsClass.R | 6 + .../post_Rcpp/ETaccessor_post_Rcpp.h | 19 ++ .../nCompiler/ET_ext/RuntimeFlatView.h | 225 ++++++++++++++++++ .../tests/testthat/cpp_tests/test-ETaccess.R | 24 ++ .../specificOp_tests/test-ETaccess-DSL.R | 2 +- .../tests/testthat/types_tests/test-types.R | 4 +- 6 files changed, 277 insertions(+), 3 deletions(-) create mode 100644 nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index eac9a87d..f6054827 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -93,6 +93,12 @@ NC_InternalsClass <- R6::R6Class( for(mN in methodNames) { self$orig_methodName_to_cpp_code_name[[mN]] <- NFinternals(Cpublic[[mN]])$cpp_code_name } + # The next three are normally set up during inheritance processing below, + # but if an nClass is predefined and used in wierd compilation workflow + # like in nimble2, then we need defaults set up, and here they are: + # self$allMethodNames <- self$allMethodNames_self. # already done above + self$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name + # self$allFieldNames <- self$allFieldNames_self. # already done above } # An over-riding base class can be provided either through inherit or nClass_inherit. if(!is.null(self$compileInfo$inherit$base) || !is.null(self$compileInfo$nClass_inherit$base)) diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h index 63b92c4c..8fd4b7c1 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ETaccessor_post_Rcpp.h @@ -5,6 +5,7 @@ #include #include #include +#include #include #include @@ -103,6 +104,12 @@ class ETaccessorBase { template Scalar &scalar(); + // Flattened get/set view of the whole object (ss empty, the default) or + // a strided subview of it (ss: one b__ block per raw dimension), without + // needing to know the object's rank at compile time. See RuntimeFlatView.h. + template + RuntimeFlatView flatten(const std::vector &ss = {}); + virtual ~ETaccessorBase(){}; }; @@ -214,6 +221,11 @@ class ETaccessorTyped : public ETaccessorBase { set_output_dims(this->intDims(), outDim, output_nDim); return ETM(data(), outDim); } + + RuntimeFlatView flattenTyped(const std::vector &ss = {}) { + return RuntimeFlatView(data(), RuntimeSubviewInfo(this->intDims(), ss)); + } + ~ETaccessorTyped(){}; }; @@ -238,6 +250,13 @@ Scalar& ETaccessorBase::scalar() { return castptr->scalarTyped(); } +template +RuntimeFlatView ETaccessorBase::flatten(const std::vector &ss) { + auto castptr = dynamic_cast* >(this); + if(castptr == nullptr) Rcpp::stop("Problem creating a flatten() view from some form of access().\n"); + return castptr->flattenTyped(ss); +} + // default to throwing an error // then specialize to allow valid types (Eigen::Tensor's or true scalars) // These are supported as run-time errors because the genericInterfaceC diff --git a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h new file mode 100644 index 00000000..0c7fc105 --- /dev/null +++ b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h @@ -0,0 +1,225 @@ +// Flattened get/set access to an arbitrary-rank tensor (rank known only at +// run time) and/or a strided subview of it, without ever instantiating an +// Eigen::Tensor/StridedTensorMap templated on that rank. +// +// StridedTensorMap solves a different problem: an arbitrary *subview* whose +// compile-time output rank equals the number of kept (non-single) input +// dimensions, with each output dimension still corresponding to exactly one +// input dimension. It deliberately does not merge independently-strided +// dimensions into fewer output dimensions, and its setup (createSubTensorInfo*) +// is templated on that output rank. Flattening to 1D when 2+ kept dimensions +// have real sub-ranges requires unflattening a linear index against their +// sizes, which is exactly what is reimplemented here -- over std::vector +// instead of Eigen::array<_, N>, so the input rank never needs to be a +// template parameter or a runtime-to-compile-time dispatch. +// +// Intended use: build a RuntimeSubviewInfo/RuntimeFlatView once (this does +// the per-dimension fold/offset work) and hold onto it for the lifetime of +// the underlying object's stable storage; every subsequent get/set/copy is +// then just additions, no division, no rebuilding strides. + +#ifndef NCOMPILER_RUNTIME_FLAT_VIEW_H_ +#define NCOMPILER_RUNTIME_FLAT_VIEW_H_ + +#include +#include +#include "index_block.h" + +// Per-dimension (size, native stride) for the dimensions kept after applying +// a selection, plus a single combined offset absorbing every fixed-index +// ("single") dimension's contribution and every kept dimension's start. +// Column-major: sizes[0]/strides[0] is the fastest-varying kept dimension. +struct RuntimeSubviewInfo { + std::vector sizes; + std::vector strides; + long baseOffset = 0; + long totalSize = 1; + + RuntimeSubviewInfo() = default; + + // input_sizes: native size of every raw dimension (e.g. ETaccessorBase::intDims()). + // ss: one block per raw dimension. A block beyond ss.size(), or a + // default-constructed (empty) block, selects the whole dimension (kept, + // not dropped). No bounds checking is performed. + template + RuntimeSubviewInfo(const SizesT &input_sizes, const std::vector &ss) { + const size_t rawN = input_sizes.size(); + long nativeStride = 1; + for (size_t k = 0; k < rawN; ++k) { + const b__ &block = (k < ss.size()) ? ss[k] : b__(); + if (block.isSingle()) { + baseOffset += block.start() * nativeStride; + } else { + const long extent = block.isEmpty() ? static_cast(input_sizes[k]) : block.extent(); + const long start = block.isEmpty() ? 0 : block.start(); + baseOffset += start * nativeStride; + sizes.push_back(extent); + strides.push_back(nativeStride); + totalSize *= extent; + } + nativeStride *= input_sizes[k]; + } + } + + size_t nDim() const { return sizes.size(); } +}; + +// Visits every multi-index combination over `sizes` exactly once (column- +// major: dimension 0 fastest), maintaining one native offset via pure +// addition/subtraction -- no division anywhere, regardless of rank. Calls +// fn(offset) per element. Used when the other side of a copy is a plain +// contiguous buffer, so it just needs its own pointer incremented once per +// call rather than tracked through this same carry logic. +template +void walkStrided1(const std::vector &sizes, + const std::vector &strides, long base, + Fn fn) { + const size_t n = sizes.size(); + if (n == 0) { + fn(base); + return; + } + std::vector idx(n, 0); + long off = base; + for (;;) { + fn(off); + size_t k = 0; + for (; k < n; ++k) { + off += strides[k]; + if (++idx[k] < sizes[k]) break; + off -= strides[k] * sizes[k]; + idx[k] = 0; + } + if (k == n) break; // every dimension carried: done + } +} + +// Scalar* + RuntimeSubviewInfo. Cheap to copy (a pointer and a couple of +// small vectors); meant to be built once and cached for repeated get/set, +// e.g. across the millions of iterations of a Monte Carlo loop, as long as +// the underlying storage is stable (does not move/reallocate). +template +class RuntimeFlatView { +public: + RuntimeFlatView() : data_(nullptr) {} + RuntimeFlatView(Scalar *data, RuntimeSubviewInfo info) + : data_(data), info_(std::move(info)) {} + + long size() const { return info_.totalSize; } + size_t nDim() const { return info_.nDim(); } + const RuntimeSubviewInfo &info() const { return info_; } + Scalar *data() const { return data_; } + + // Random access by flat (linear) index: unflattens against info_.sizes + // each call (one division per kept dimension). Prefer copyInto/copyFrom + // for sequential access -- those avoid the per-call unflattening entirely. + Scalar &at(long flatIndex) const { + long offset = info_.baseOffset; + for (size_t k = 0; k < info_.sizes.size(); ++k) { + const long idx = flatIndex % info_.sizes[k]; + flatIndex /= info_.sizes[k]; + offset += idx * info_.strides[k]; + } + return data_[offset]; + } + + // dest[0..size()-1] = this view, in canonical (column-major over kept + // dims) order, via incremental offset updates only. + void copyIntoVector(Scalar *dest) const { + walkStrided1(info_.sizes, info_.strides, info_.baseOffset, + [&](long off) { *dest++ = data_[off]; }); + } + + Eigen::Tensor copyIntoVector() const { + Eigen::Tensor out(size()); + copyIntoVector(out.data()); + return out; + } + + void copyIntoVector(Eigen::Tensor &dest) const { + dest.resize(size()); + copyIntoVector(dest.data()); + } + + // this view = src[0..size()-1], inverse of copyInto. + void copyFromVector(const Scalar *src) { + walkStrided1(info_.sizes, info_.strides, info_.baseOffset, + [&](long off) { data_[off] = *src++; }); + } + + void copyFromVector(Eigen::Tensor &dest) const { + copyFromVector(dest.data()); + } + + // Element-wise copy to/from another object with the exact same raw shape + // and the exact same selection applied (e.g. the same subview of two + // 10x10x10 objects) -- so info_ itself (sizes, strides, baseOffset) is + // guaranteed identical on both sides; only the data pointer differs. No + // flattening, no synthetic linear index, no second stride descriptor. + void copyToSameShape(Scalar *dstData) const { + walkStrided1(info_.sizes, info_.strides, info_.baseOffset, + [&](long off) { dstData[off] = data_[off]; }); + } + + void copyFromSameShape(const Scalar *srcData) { + walkStrided1(info_.sizes, info_.strides, info_.baseOffset, + [&](long off) { data_[off] = srcData[off]; }); + } + +private: + Scalar *data_; + RuntimeSubviewInfo info_; +}; + +// Holds several RuntimeFlatViews and gathers/scatters them contiguously +// into/out of one shared buffer (e.g. a single parameter vector spanning +// several distinct, independently-shaped objects). Built once outside the +// hot loop, same as RuntimeFlatView itself. +template +class RuntimeFlatViewGroup { +public: + void add(RuntimeFlatView view) { + offsets_.push_back(totalSize_); + totalSize_ += view.size(); + views_.push_back(std::move(view)); + } + + long totalSize() const { return totalSize_; } + size_t numViews() const { return views_.size(); } + const RuntimeFlatView &view(size_t i) const { return views_[i]; } + long offset(size_t i) const { return offsets_[i]; } + + Eigen::Tensor copyIntoVector() const { + Eigen::Tensor out(totalSize()); + copyIntoVector(out.data()); + return out; + } + + void copyIntoVector(Eigen::Tensor &dest) const { + dest.resize(totalSize()); + copyIntoVector(dest.data()); + } + + void copyIntoVector(Scalar *dest) const { + for (size_t i = 0; i < views_.size(); ++i) + views_[i].copyIntoVector(dest + offsets_[i]); + } + + void copyFromVector(const Scalar *src) { + for (size_t i = 0; i < views_.size(); ++i) + views_[i].copyFromVector(src + offsets_[i]); + } + + void copyFromVector(Eigen::Tensor &src) { + if(src.size() != totalSize()) + throw std::runtime_error("RuntimeFlatViewGroup::copyFromVector: src.size() != totalSize()"); + copyFromVector(src.data()); + } + +private: + std::vector> views_; + std::vector offsets_; + long totalSize_ = 0; +}; + +#endif // NCOMPILER_RUNTIME_FLAT_VIEW_H_ diff --git a/nCompiler/tests/testthat/cpp_tests/test-ETaccess.R b/nCompiler/tests/testthat/cpp_tests/test-ETaccess.R index 90ee616a..7f88eb3d 100644 --- a/nCompiler/tests/testthat/cpp_tests/test-ETaccess.R +++ b/nCompiler/tests/testthat/cpp_tests/test-ETaccess.R @@ -718,3 +718,27 @@ test_that("ETaccess copies data and isolates from original", { expect_equal(obj$DV_copy_expr(DV), DV * 2) rm(obj); gc() }) + +test_that("ETaccess flattening works", { + + nc <- nClass( + Cpublic = list( + flatten_2D = nFunction( + function(x = 'numericMatrix') { + cppLiteral("auto acc = ETaccess(x)") + cppLiteral("ETaccessorBase* accptr = static_cast(&acc)") + cppLiteral("auto flattener = accptr->flatten()") + res <- numeric(length = 12) + cppLiteral("flattener.copyIntoVector(res)") + return(res) + returnType(double(1)) + } + ) + ) + ) + comp <- nCompile(nc) + x <- matrix(seq(1.1, 12.1, by = 1), nrow = 4) + storage.mode(x) + obj <- comp$new() + obj$flatten_2D(x) +}) diff --git a/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R b/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R index 5bea0146..bfc09169 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R @@ -45,7 +45,7 @@ test_that("ETaccessor type works", { } ) ), - compileInfo=list(interfaceMembers = c("s","v","m", "get")) + compileInfo=list(interfaceInclude = c("s","v","m", "get")) ) cnc <- nCompile(nc) diff --git a/nCompiler/tests/testthat/types_tests/test-types.R b/nCompiler/tests/testthat/types_tests/test-types.R index 5d65afeb..8c59429b 100644 --- a/nCompiler/tests/testthat/types_tests/test-types.R +++ b/nCompiler/tests/testthat/types_tests/test-types.R @@ -572,10 +572,10 @@ test_that("symbolTBD works with a function from a call", { myenv$nc1 <- nClass( Cpublic = list(a = 'numericScalar') ) -# sym_nc1 <- nCompiler:::type2symbol("myenv$nc1", "nc1obj") sym_nc1 <- nCompiler:::type2symbol("myenv$nc1()", "nc1obj") - debug(nCompiler:::check_unknown_types) res <- sym_nc1$resolveSym() + expect_true(inherits(res, "symbolNC")) + expect_equal(res$type, myenv$nc1$classname) }) cat("\nSee test-types.R for notes on remaining issues to test.\n") From cd2615ebdca45ab5b4da44a61dad3a1cc62fc623 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 13 Jul 2026 12:06:53 -0700 Subject: [PATCH 05/11] allow rvalue as input for setting in RuntimeFlatViewGroup --- .../nCompiler/ET_ext/RuntimeFlatView.h | 24 ++++++++++++++++- .../testthat/nCompile_tests/test-userOps.R | 27 +++++++++++++++++++ 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h index 0c7fc105..7a75a769 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h @@ -184,6 +184,12 @@ class RuntimeFlatViewGroup { views_.push_back(std::move(view)); } + void clear() { + views_.clear(); + offsets_.clear(); + totalSize_ = 0; + } + long totalSize() const { return totalSize_; } size_t numViews() const { return views_.size(); } const RuntimeFlatView &view(size_t i) const { return views_[i]; } @@ -210,12 +216,28 @@ class RuntimeFlatViewGroup { views_[i].copyFromVector(src + offsets_[i]); } - void copyFromVector(Eigen::Tensor &src) { + void copyFromVector(const Eigen::Tensor &src) { if(src.size() != totalSize()) throw std::runtime_error("RuntimeFlatViewGroup::copyFromVector: src.size() != totalSize()"); copyFromVector(src.data()); } + // Proxy returned by setValues() so `group.setValues() = input;` reads as an + // assignment while dispatching to copyFromVector. Overloads mirror + // copyFromVector's own parameter types. + class SetValuesProxy { + public: + explicit SetValuesProxy(RuntimeFlatViewGroup &group) : group_(group) {} + + void operator=(const Scalar *src) { group_.copyFromVector(src); } + void operator=(const Eigen::Tensor &src) { group_.copyFromVector(src); } + + private: + RuntimeFlatViewGroup &group_; + }; + + SetValuesProxy setValues_() { return SetValuesProxy(*this); } + private: std::vector> views_; std::vector offsets_; diff --git a/nCompiler/tests/testthat/nCompile_tests/test-userOps.R b/nCompiler/tests/testthat/nCompile_tests/test-userOps.R index 2b4b225d..209cfbce 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-userOps.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-userOps.R @@ -284,6 +284,12 @@ test_that("nClass custom opDefs of 3 kinds works through a sequence of changes a }, argTypes=list(), returnType=quote(double()) ) + # compiling call_foo uses opDef for foo, which is in the nFunction's compileInfo + # This emits two messages and replaces foo with foo2, which is handled next. + # The foo2 opDef is in the nClass' compileInfo, and that emits a msg and replaces + # foo2 with foo3, which has a handler in the nClass and doesn't even exist + # as a method. This emits a message and replaces foo3 with foo4, which does + # not emit a message but does modify the genCpp stage so we get a specific bit of math. foo_class <- nClass( Cpublic = list( foo = foo, @@ -318,4 +324,25 @@ test_that("nClass custom opDefs of 3 kinds works through a sequence of changes a obj <- comp$foo_class$new() expect_equal(obj$call_foo(), 10*3.4 + 4.5) rm(obj); gc() + + cat("Need extension of custom opDefs in nClasses to work in obj$op() calls\n") + + # Next check that the various opDefs above are used when called as obj$op() from another nFunction. + ## use_foo_class <- nFunction( + ## function(my_foo_class = 'foo_class()') { + ## res1 <- my_foo_class$foo() + ## res2 <- my_foo_class$foo2() + ## res3 <- my_foo_class$foo3() + ## res4 <- my_foo_class$call_foo() + ## return(res1) + ## returnType("numericScalar") + ## } + ## ) + + ## debug(nCompiler:::compile_labelAbstractTypes) + ## debug(nCompiler:::labelAbstractTypesEnv$ChainedCall) + ## debug(nCompiler:::labelAbstractTypesEnv$DollarSign) + ## comp <- nCompile(use_foo_class, foo_class, foo) + ## my_foo_class <- comp$foo_class$new() + ## comp$use_foo_class() }) From ff5625ed6c97d531ca8f7c6597a92399f7ce45cf Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 14 Jul 2026 10:54:35 -0700 Subject: [PATCH 06/11] fix bug in insertArg for mix of NULL and non-NULL names --- nCompiler/R/compile_exprClass.R | 5 ++- nCompiler/R/compile_simpleTransformations.R | 1 - .../testthat/nCompile_tests/test-exprClass.R | 31 +++++++++++++++++++ 3 files changed, 35 insertions(+), 2 deletions(-) create mode 100644 nCompiler/tests/testthat/nCompile_tests/test-exprClass.R diff --git a/nCompiler/R/compile_exprClass.R b/nCompiler/R/compile_exprClass.R index 49565624..d50d8d4d 100644 --- a/nCompiler/R/compile_exprClass.R +++ b/nCompiler/R/compile_exprClass.R @@ -274,8 +274,11 @@ insertArg <- function(expr, ID, value, name = NULL) { if(is.null(name)) if(!is.null(names(expr$args))) name <- "" - if(!is.null(name)) + if(!is.null(name)) { + if(is.null(names(expr$args))) + names(expr$args) <- rep("", length(expr$args)) names(expr$args)[ID] <- name + } invisible(value) } diff --git a/nCompiler/R/compile_simpleTransformations.R b/nCompiler/R/compile_simpleTransformations.R index 9c6100d1..3e993cda 100644 --- a/nCompiler/R/compile_simpleTransformations.R +++ b/nCompiler/R/compile_simpleTransformations.R @@ -118,7 +118,6 @@ inSimpleTransformationsEnv( assign_name <- paste0(name, "<-") code$name <- assign_name arg2 <- code$args[[2]] - code$args <- list() arg1names <- names(arg1$args) code$args <- list() # rebuild from scratch for(i in seq_along(arg1$args)) { diff --git a/nCompiler/tests/testthat/nCompile_tests/test-exprClass.R b/nCompiler/tests/testthat/nCompile_tests/test-exprClass.R new file mode 100644 index 00000000..f56e6690 --- /dev/null +++ b/nCompiler/tests/testthat/nCompile_tests/test-exprClass.R @@ -0,0 +1,31 @@ +library(testthat) + +test_that("insertArg name updating works", { + # Case 0: inserting an unnamed arg when other args are unnamed + expr <- nParse("foo(a)") + expect_equal(names(expr$args), NULL) + expect_no_error(out <- capture_output(expr$print())) + newArg <- nParse("x") + nCompiler:::insertArg(expr, 2, newArg) + expect_equal(names(expr$args), NULL) + expect_no_error(out <- capture_output(expr$print())) + # Case 1: inserting an unnamed arg when there are already named args + expr <- nParse("foo(a = 1)") + expect_equal(names(expr$args), "a") + expect_no_error(out <- capture_output(expr$print())) + newArg <- nParse("x") + nCompiler:::insertArg(expr, 2, newArg) + expect_equal(names(expr$args), c("a", "")) + expect_no_error(out <- capture_output(expr$print())) + # Case 2: inserting a named argument when others are unnamed + # This is a regression test for a bug where inserting an argument with a name + # when there were not other named arguments created an error + # in exprClass_print + expr <- nParse("foo(a)") + expect_equal(names(expr$args), NULL) + expect_no_error(out <- capture_output(expr$print())) + newArg <- nParse("x") + nCompiler:::insertArg(expr, 2, newArg, "b") + expect_equal(names(expr$args), c("", "b")) + expect_no_error(out <- capture_output(expr$print())) +}) From 737bdcd63dbf46142b31ee1a7cc42faf7183a6bf Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 14 Jul 2026 11:44:44 -0700 Subject: [PATCH 07/11] disable a test of obj[["x"]] due to changed intended behavior --- .../specificOp_tests/test-ETaccess-DSL.R | 72 ++++++++++--------- 1 file changed, 40 insertions(+), 32 deletions(-) diff --git a/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R b/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R index bfc09169..c074d73d 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-ETaccess-DSL.R @@ -60,38 +60,46 @@ test_that("ETaccessor type works", { rm(obj); gc() }) -test_that("obj[['x']] works like obj$x", { - nc <- nClass( - Cpublic = list( - x = 'numericVector' - ) - ) - nc2 <- nClass( - Cpublic = list( - nf = nFunction( - function(obj = 'nc') { - v <- obj[["x"]] - return(v) - returnType('numericVector') - } - ) - ) - ) - for(mode in c("R","non-pkg", "pkg")) { - if(mode == "R") { - obj <- nc$new() - obj2 <- nc2$new() - } else { - package <- mode=="pkg" - comp <- nCompile(nc, nc2, package = package) - obj <- comp$nc$new() - obj2 <- comp$nc2$new() - } - obj$x <- c(1.2, 2.3) - expect_equal(obj2$nf(obj), obj$x) - rm(obj); gc() - } -}) +## This test is disabled because we have for now +## changed the design decision about how this should work +## It should work like obj[[varName]] even if varName "x" +## so that `[[` always returns the same type. +## This is a real point of debate and may be reconsidered +## again. +## There was some problem encountered that led to this change. +## +## test_that("obj[['x']] works like obj$x", { +## nc <- nClass( +## Cpublic = list( +## x = 'numericVector' +## ) +## ) +## nc2 <- nClass( +## Cpublic = list( +## nf = nFunction( +## function(obj = 'nc') { +## v <- obj[["x"]] +## return(v) +## returnType('numericVector') +## } +## ) +## ) +## ) +## for(mode in c("R","non-pkg", "pkg")) { +## if(mode == "R") { +## obj <- nc$new() +## obj2 <- nc2$new() +## } else { +## package <- mode=="pkg" +## comp <- nCompile(nc, nc2, package = package) +## obj <- comp$nc$new() +## obj2 <- comp$nc2$new() +## } +## obj$x <- c(1.2, 2.3) +## expect_equal(obj2$nf(obj), obj$x) +## rm(obj); gc() +## } +## }) test_that("obj[[var_name]] works", { From 9e3da927f0933c9cad2e682de332223801edd79a Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 15 Jul 2026 09:42:21 -0700 Subject: [PATCH 08/11] renovate how nClass inheritance is processed so inheritInfo is held in project_env$known_nClasses --- nCompiler/R/NC_Compile.R | 6 +- nCompiler/R/NC_CompilerClass.R | 22 ++-- nCompiler/R/NC_InternalsClass.R | 102 +++++++++------- nCompiler/R/NC_Utils.R | 24 ++-- nCompiler/R/NF_CompilerClass.R | 3 +- nCompiler/R/compile_labelAbstractTypes.R | 7 +- nCompiler/R/cppDefs_core.R | 3 +- nCompiler/R/cppDefs_nClass.R | 3 +- nCompiler/R/nCompile.R | 112 +++++++++++++----- nCompiler/R/typeDeclarations.R | 14 ++- .../test-nCompile_auto_include.R | 3 +- 11 files changed, 202 insertions(+), 97 deletions(-) diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index bbc3acfa..44e416ef 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -70,7 +70,8 @@ nCompile_nClass <- function(NC, regular_filename <- NCinternals(NC)$cpp_classname if(gather_needed_units) needed_units <- nCompile_process_manual_needed_units(NCinternals(NC), - NC$parent_env, isNC = TRUE) + NC$parent_env, isNC = TRUE, + project_env = project_env) allow_write_predefined <- !isTRUE(compileInfo$auto_included) } if(is_predefined && (isFALSE(controlFull$generate_predefined) || !allow_write_predefined)) { @@ -82,7 +83,8 @@ nCompile_nClass <- function(NC, if(is.null(compileInfo)) compileInfo <- NCinternals(NC)$compileInfo ## Make a new compiler object NC_Compiler <- NC_CompilerClass$new(NC, - compileInfo = compileInfo) + compileInfo = compileInfo, + project_env = project_env) ## Use the compiler to generate a cppDef class_env <- new.env() NC_Compiler$createCpp(control = controlFull, diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index 0d3fdb1b..3c4f33d3 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -6,6 +6,7 @@ NC_CompilerClass <- R6::R6Class( portable = FALSE, public = list( NCgenerator = NULL + , inheritInfo = NULL , NFcompilers = list() ## list of NF_CompilerClass objects for methods , symbolTable = NULL , cppDef = NULL @@ -14,7 +15,8 @@ NC_CompilerClass <- R6::R6Class( , neededTypes = list(), initialize = function(NC = NULL, className = NULL, - compileInfo = NULL) { + compileInfo = NULL, + project_env = new.env()) { if(!isNCgenerator(NC)) { if(isNC(NC)) stop(paste0("nClass object was provided to NCvirtual_CompilerClass. ", @@ -25,6 +27,8 @@ NC_CompilerClass <- R6::R6Class( call. = FALSE) } NCgenerator <<- NC + nClass_info <- register_known_nClass(NCgenerator, project_env = project_env) + inheritInfo <<- nClass_info$inheritInfo myNCinternals <- NCinternals(NCgenerator) if(is.null(className)) { name <<- myNCinternals$cpp_classname @@ -32,7 +36,7 @@ NC_CompilerClass <- R6::R6Class( name <<- className } if(is.null(compileInfo)) - self$compileInfo <- myNCinternals$compileInfo + self$compileInfo <- myNCinternals$compileInfo # will fail if there is inheritance, but normally compileInfo is provided else self$compileInfo <- compileInfo if(length(compileInfo$exportName)==0) { @@ -56,7 +60,7 @@ NC_CompilerClass <- R6::R6Class( #NFinternals(thisMethod)$cpp_code_name <- self$name NFinternals(thisMethod)$cpp_code_name <- self$name } else { - thisName <- myNCinternals$all_methodName_to_cpp_code_name[[m]] + thisName <- self$inheritInfo$all_methodName_to_cpp_code_name[[m]] } NFcompilers[[m]] <<- NF_CompilerClass$new(f = thisMethod, name = thisName) @@ -121,11 +125,13 @@ NC_CompilerClass <- R6::R6Class( }, makeSymbolTables = function(project_env = new.env()) { if(is.null(symbolTable)) { - symbolTable <<- NCinternals(NCgenerator)$symbolTable$clone(deep = TRUE) - ## Update any symbolTBD symbols by scoped lookup - resolveTBDsymbols(symbolTable, - NCgenerator, - project_env = project_env) + nClass_info <- register_known_nClass(self$NCgenerator, project_env = project_env) + symbolTable <<- nClass_info$symbolTable + # symbolTable <<- NCinternals(NCgenerator)$symbolTable$clone(deep = TRUE) + # ## Update any symbolTBD symbols by scoped lookup + # resolveTBDsymbols(symbolTable, + # NCgenerator, + # project_env = project_env) ## Add 'self' so method bodies can reference the current object. ## genCppVar() gives a special cppVar case where generate() returns "" ## and generateUse returns "nC_shared_from_this()". diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index f6054827..7c2aebf2 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -6,14 +6,14 @@ NC_InternalsClass <- R6::R6Class( symbolTable = NULL, cppSymbolNames = NULL, methodNames = character(), - allMethodNames = character(), # including inherited methods + #allMethodNames = character(), # including inherited methods allMethodNames_self = character(), # not including inherited methods fieldNames = character(), - allFieldNames = character(), # including inherited methods + #allFieldNames = character(), # including inherited methods allFieldNames_self = character(), # not including inherited methods classname = character(), cpp_classname = character(), - all_methodName_to_cpp_code_name = list(), + #all_methodName_to_cpp_code_name = list(), orig_methodName_to_cpp_code_name = list(), compileInfo = list(), inherit_base_provided = FALSE, @@ -25,13 +25,13 @@ NC_InternalsClass <- R6::R6Class( enableDerivs = NULL, enableSaving = NULL, predefined = FALSE, # directory for reading and (default) writing predefined nClass saved RcppPacket. Writing location can be over-ridden by compileInfo$predefined_output_dir - inheritNCinternals = NULL, + # inheritNCinternals = NULL, env = NULL, inheritQ = NULL, # quoted inherit expression, to defer access to the inherited nClass generator itself. - process_inherit_done = FALSE, + # process_inherit_done = FALSE, virtualMethodNames_self = character(), # will be used when checking inherited method validity, only for locally implemented methods - virtualMethodNames = character(), - check_inherit_done = FALSE, + # virtualMethodNames = character(), + #check_inherit_done = FALSE, classID = NULL, #Cpub_class_code = NULL, #main_class_code = NULL, @@ -71,7 +71,7 @@ NC_InternalsClass <- R6::R6Class( } } has_Cpublic_init <- "initialize" %in% names(Cpublic) - self$virtualMethodNames <- names(Cpublic)[isVirtual] + #self$virtualMethodNames <- names(Cpublic)[isVirtual] self$symbolTable <- typeList2symbolTable(Cpublic[!isMethod], where = env) self$cppSymbolNames <- Rname2CppName(symbolTable$getSymbolNames()) self$methodNames <- names(Cpublic)[isMethod] @@ -83,11 +83,11 @@ NC_InternalsClass <- R6::R6Class( } self$allMethodNames_self <- methodNames self$virtualMethodNames_self <- names(Cpublic)[isVirtual] - self$allMethodNames <- methodNames + #self$allMethodNames <- methodNames self$fieldNames <- names(Cpublic)[!isMethod] if(has_Cpublic_init) self$fieldNames <- setdiff(self$fieldNames, "initialize") self$allFieldNames_self <- fieldNames - self$allFieldNames <- fieldNames + #self$allFieldNames <- fieldNames self$orig_methodName_to_cpp_code_name <- structure(vector("list", length=length(methodNames)), names = methodNames) for(mN in methodNames) { @@ -97,7 +97,7 @@ NC_InternalsClass <- R6::R6Class( # but if an nClass is predefined and used in wierd compilation workflow # like in nimble2, then we need defaults set up, and here they are: # self$allMethodNames <- self$allMethodNames_self. # already done above - self$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name + #self$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name # self$allFieldNames <- self$allFieldNames_self. # already done above } # An over-riding base class can be provided either through inherit or nClass_inherit. @@ -128,42 +128,64 @@ NC_InternalsClass <- R6::R6Class( self$predefined <- predefined self$enableSaving <- enableSaving }, - connect_inherit = function() { - # These are steps that need to be done after all classes are defined - # and do not require recursion up the inheritance tree. - if(!is.null(self$inheritQ)) { - inherit_obj <- eval(self$inheritQ, envir = self$env) #inheritQ can be an expression but it must always return the same generator object - if(!isNCgenerator(inherit_obj)) - stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") - self$inheritNCinternals <- NCinternals(inherit_obj) - if(!self$inherit_base_provided) { - self$compileInfo$nClass_inherit$base <- self$inheritNCinternals$cpp_classname # don't paste "public" because it will go in interface_resolver< - } - } - self$process_inherit_done <- FALSE - self$check_inherit_done <- FALSE - }, - process_inherit = function() { + # connect_inherit = function(inheritInfo, symbolTable, project_env) { + # # These are steps that need to be done after all classes are defined + # # and do not require recursion up the inheritance tree. + # if(!is.null(self$inheritQ)) { + # inherit_obj <- eval(self$inheritQ, envir = self$env) #inheritQ can be an expression but it must always return the same generator object + # if(!isNCgenerator(inherit_obj)) + # stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") + # # self$inheritNCinternals <- NCinternals(inherit_obj) + # parent_nClass_Info <- register_known_nClass(inherit_obj, project_env) + # symbolTable$setParentST(parent_nClass_Info$symbolTable) + # inheritInfo$inheritNCinternals <- NCinternals(inherit_obj) + # inheritInfo$nClass_inherit <- self$compileInfo$nClass_inherit + # if(!self$inherit_base_provided) { + # #self$compileInfo$nClass_inherit$base <- self$inheritNCinternals$cpp_classname # don't paste "public" because it will go in interface_resolver< + # inheritInfo$nClass_inherit$base <- self$inheritNCinternals$cpp_classname + # } + # } + # inheritInfo$process_inherit_done <- FALSE + # inheritInfo$check_inherit_done <- FALSE + # }, + process_inherit = function(inheritInfo, symbolTable, project_env) { # These are steps that need to be done after connect_inherit # and require recursion up the inheritance tree, using flags. # TO-DO: Error trap in methods of same name but different argument signatures. - if(self$process_inherit_done) return() + if(isTRUE(inheritInfo$process_inherit_done)) return() if(!is.null(self$inheritQ)) { - self$inheritNCinternals$process_inherit() - self$symbolTable$setParentST(self$inheritNCinternals$symbolTable) + inherit_obj <- eval(self$inheritQ, envir = self$env) #inheritQ can be an expression but it must always return the same generator object + if(!isNCgenerator(inherit_obj)) + stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") + # self$inheritNCinternals <- NCinternals(inherit_obj) + parent_nClass_Info <- register_known_nClass(inherit_obj, project_env) + symbolTable$setParentST(parent_nClass_Info$symbolTable) + inheritInfo$inheritNCinternals <- NCinternals(inherit_obj) + inheritInfo$nClass_inherit <- self$compileInfo$nClass_inherit + # if(!self$inherit_base_provided) { + # #self$compileInfo$nClass_inherit$base <- self$inheritNCinternals$cpp_classname # don't paste "public" because it will go in interface_resolver< + # inheritInfo$nClass_inherit$base <- inheritInfo$inheritNCinternals$cpp_classname + # } + #self$inheritNCinternals$process_inherit() + #self$symbolTable$setParentST(self$inheritNCinternals$symbolTable) newMethodNames <- setdiff(self$allMethodNames_self, - self$inheritNCinternals$allMethodNames) - self$allMethodNames <- c(newMethodNames, self$inheritNCinternals$allMethodNames) - self$all_methodName_to_cpp_code_name <- c(self$orig_methodName_to_cpp_code_name[newMethodNames], - self$inheritNCinternals$all_methodName_to_cpp_code_name) - self$allFieldNames <- c(self$allFieldNames_self, self$inheritNCinternals$allFieldNames) + parent_nClass_Info$inheritInfo$allMethodNames) + inheritInfo$allMethodNames <- c(newMethodNames, parent_nClass_Info$inheritInfo$allMethodNames) + inheritInfo$all_methodName_to_cpp_code_name <- c(self$orig_methodName_to_cpp_code_name[newMethodNames], + parent_nClass_Info$inheritInfo$all_methodName_to_cpp_code_name) + inheritInfo$allFieldNames <- c(self$allFieldNames_self, parent_nClass_Info$inheritInfo$allFieldNames) + # self$allMethodNames <- c(newMethodNames, self$inheritNCinternals$allMethodNames) + # self$all_methodName_to_cpp_code_name <- c(self$orig_methodName_to_cpp_code_name[newMethodNames], + # self$inheritNCinternals$all_methodName_to_cpp_code_name) + # self$allFieldNames <- c(self$allFieldNames_self, self$inheritNCinternals$allFieldNames) } else { - self$allMethodNames <- self$allMethodNames_self - self$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name - self$allFieldNames <- self$allFieldNames_self - self$symbolTable$setParentST(NULL) + inheritInfo$allMethodNames <- self$allMethodNames_self + inheritInfo$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name + inheritInfo$allFieldNames <- self$allFieldNames_self + symbolTable$setParentST(NULL) } - self$process_inherit_done <- TRUE + inheritInfo$process_inherit_done <- TRUE + inheritInfo$check_inherit_done <- FALSE } ) ) diff --git a/nCompiler/R/NC_Utils.R b/nCompiler/R/NC_Utils.R index 8e4ca333..aa7ab726 100644 --- a/nCompiler/R/NC_Utils.R +++ b/nCompiler/R/NC_Utils.R @@ -158,7 +158,7 @@ NC_find_method <- function(NCgenerator, name, inherits=TRUE) { # the case in an R6 class hierarchy, so we disallow it unless a user allows it by option). # # The previous calls will have initialized NCint$check_inherit_done to FALSE -NC_check_inheritance <- function(NCgenerator) { +NC_check_inheritance <- function(NCgenerator, inheritInfo, project_env) { allow_method_overloading <- isTRUE(get_nOption('allow_method_overloading')) allow_inherited_field_duplicates <- isTRUE(get_nOption('allow_inherited_field_duplicates')) if(allow_method_overloading && allow_inherited_field_duplicates) return(invisible(NULL)) @@ -168,29 +168,31 @@ NC_check_inheritance <- function(NCgenerator) { NCint <- NCinternals(NCgenerator) if(is.null(NCint$inheritQ)) { - NCint$check_inherit_done <- TRUE - NCint$virtualMethodNames <- NCint$virtualMethodNames_self - return(NCint$virtualMethodNames_self) + inheritInfo$check_inherit_done <- TRUE + inheritInfo$virtualMethodNames <- NCint$virtualMethodNames_self + return(inheritInfo$virtualMethodNames) } - if(NCint$check_inherit_done) return(NCint$virtualMethodNames) + if(inheritInfo$check_inherit_done) return(inheritInfo$virtualMethodNames) # At this point, we have inheritance and have checked this NCgenerator yet. - inheritNCinternals <- NCint$inheritNCinternals + inheritNCinternals <- inheritInfo$inheritNCinternals inheritNCgenerator <- eval(NCint$inheritQ, envir = NCint$env) + parent_nClass_Info <- register_known_nClass(inheritNCgenerator, project_env = project_env) # Recurse up the inheritance ladder # A design dilemma here was that the virtual marker is in the NFinternals, # which can be accessed from the NCgenerator but not the NCinternals. # That is why this function is not a method of NCinternals. - inherit_virtualMethodNames <- NC_check_inheritance(inheritNCgenerator) + inherit_virtualMethodNames <- NC_check_inheritance(inheritNCgenerator, parent_nClass_Info$inheritInfo, + project_env = project_env) new_virtualMethodNames <- character() if(!allow_method_overloading) { local_virtualMethodNames <- NCint$virtualMethodNames_self # default: check for disallowed method overloading - allMethodNames <- NCint$allMethodNames + allMethodNames <- inheritInfo$allMethodNames for(mN in allMethodNames) { # if a method is not in the self method names, it was inherited, so there is nothing to check if(!(mN %in% NCint$allMethodNames_self)) next - if(!(mN %in% inheritNCinternals$allMethodNames)) { + if(!(mN %in% parent_nClass_Info$inheritInfo$allMethodNames)) { # current level is the first one with this method name, so here we tag its virtual status new_virtualMethodNames <- c(new_virtualMethodNames, mN) next @@ -223,7 +225,7 @@ NC_check_inheritance <- function(NCgenerator) { # # If any of my own field names already existed from my inherited classes, # that's not allowed - badFields <- NCint$allFieldNames_self %in% inheritNCinternals$allFieldNames + badFields <- NCint$allFieldNames_self %in% parent_nClass_Info$inheritInfo$allFieldNames if(any(badFields)) stop(paste0("Problem with field(s): ", paste(NCint$allFieldNames_self[badFields], collapse = ", "), ". Fields with the same name are not allowed in base and inherited classes.", @@ -231,7 +233,7 @@ NC_check_inheritance <- function(NCgenerator) { " set nOptions(allow_inherited_field_duplicates=TRUE)"), call. = FALSE ) } - NCint$check_inherit_done <- TRUE + inheritInfo$check_inherit_done <- TRUE c(new_virtualMethodNames, inherit_virtualMethodNames) } diff --git a/nCompiler/R/NF_CompilerClass.R b/nCompiler/R/NF_CompilerClass.R index 499002d4..4c3eab37 100644 --- a/nCompiler/R/NF_CompilerClass.R +++ b/nCompiler/R/NF_CompilerClass.R @@ -306,7 +306,8 @@ processNFstages <- function(NFcompiler, env = NFcompiler$auxEnv[['where']], project_env = project_env) NFcompiler$returnSymbol <- resolveOneTBDsymbol(NFcompiler$returnSymbol, - env = NFcompiler$auxEnv[['where']]) + env = NFcompiler$auxEnv[['where']], + project_env = project_env) if(inherits(NFcompiler$returnSymbol, "symbolNC")) { NFcompiler$auxEnv$needed_nClasses <- c(NFcompiler$auxEnv$needed_nClasses, NFcompiler$returnSymbol$NCgenerator) } diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 38d9c47f..5308344e 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -45,6 +45,7 @@ compile_labelAbstractTypes <- function(code, obj <- nGet(code$name, where = auxEnv$where, project_env = auxEnv$project_env) if(!is.null(obj)) { if(isNCgenerator(obj)) { + register_known_nClass(obj, project_env = auxEnv$project_env) newSym <- symbolNCgenerator$new(name = code$name, type = code$name, NCgenerator = obj) @@ -358,6 +359,7 @@ inLabelAbstractTypesEnv( ## 2. Check if RHS is a field innerName <- code$args[[2]]$name method <- NC_find_method(code$args[[1]]$type$NCgenerator, innerName, inherits=TRUE) + nClass_info <- register_known_nClass(code$args[[1]]$type$NCgenerator, project_env = auxEnv$project_env) if(!is.null(method)) { ## Is RHS a method? obj_internals <- NFinternals(method) returnSym <- symbolNF$new( @@ -372,11 +374,12 @@ inLabelAbstractTypesEnv( code$name <- '->member' code$args[[2]]$aux$obj_internals <- obj_internals code$args[[2]]$aux$nFunctionName <- innerName - code$args[[2]]$name <- NCinternals(code$args[[1]]$type$NCgenerator)$all_methodName_to_cpp_code_name[[innerName]] + code$args[[2]]$name <- nClass_info$inheritInfo$all_methodName_to_cpp_code_name[[innerName]] obj_internals <- NULL } else { ## Is RHS a field? - symbol <- NCinternals(code$args[[1]]$type$NCgenerator)$symbolTable$getSymbol(innerName, inherits=TRUE) + obj_symbolTable <- nClass_info$symbolTable + symbol <- obj_symbolTable$getSymbol(innerName, inherits=TRUE) if(is.null(symbol)) stop(exprClassProcessingErrorMsg( code, diff --git a/nCompiler/R/cppDefs_core.R b/nCompiler/R/cppDefs_core.R index 0e767d20..b172382c 100644 --- a/nCompiler/R/cppDefs_core.R +++ b/nCompiler/R/cppDefs_core.R @@ -382,7 +382,8 @@ addGenericInterface_impl <- function(self) { outputMethodNames[iOut] <- mName # This line should give the same result as the next line. # outputCppMethodNames[iOut] <- NFint$cpp_code_name - outputCppMethodNames[iOut] <- NCint$all_methodName_to_cpp_code_name[[mName]] + outputCppMethodNames[iOut] <- self$Compiler$inheritInfo$all_methodName_to_cpp_code_name[[mName]] +# outputCppMethodNames[iOut] <- NCint$all_methodName_to_cpp_code_name[[mName]] outputMethodClassNames[iOut] <- NCint$cpp_classname iOut <- iOut + 1 } diff --git a/nCompiler/R/cppDefs_nClass.R b/nCompiler/R/cppDefs_nClass.R index 6e0d6087..68d542a1 100644 --- a/nCompiler/R/cppDefs_nClass.R +++ b/nCompiler/R/cppDefs_nClass.R @@ -230,7 +230,8 @@ cpp_nClassClass <- R6::R6Class( } self$add_nClass_inheritance(oneInheritance) } - inheritNCinternals <- NCinternals(self$Compiler$NCgenerator)$inheritNCinternals + inheritNCinternals <- Compiler$inheritInfo$inheritNCinternals +# inheritNCinternals <- NCinternals(self$Compiler$NCgenerator)$inheritNCinternals if(!is.null(inheritNCinternals)) { include_filebase <- make_cpp_filebase(inheritNCinternals$cpp_classname) self$Hincludes <- c(self$Hincludes, paste0("\"",include_filebase, ".h", "\"")) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index b9e6de28..6ad88c97 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -142,6 +142,15 @@ nCompile_createCppDefsInfo <- function(units, project_env = project_env) cpp_names[i] <- NFinternals(units[[i]])$cpp_code_name } else if(unitTypes[i] == "nCgen") { + # update compileInfo for explicit inheritance base class if provided. + nClass_info <- register_known_nClass(units[[i]], project_env) + NCint <- NCinternals(units[[i]]) + if(!is.null(NCint$inheritQ)) { + if(!NCint$inherit_base_provided) { + compileInfo$nClass_inherit$base <- + nClass_info$inheritInfo$inheritNCinternals$cpp_classname + } + } oneResult <- nCompile_nClass(units[[i]], stopAfterCppDef = TRUE, env = env, @@ -273,18 +282,21 @@ nCompile_prepare_units <- function(..., # to be called with inherit = some_nClass before some_nClass is defined. # Note that each step must be done for all units before the next step is done # for all units. - for(i in seq_along(units)) { - if(unitTypes[i] == "nCgen") - NCinternals(units[[i]])$connect_inherit() - } - for(i in seq_along(units)) { - if(unitTypes[i] == "nCgen") - NCinternals(units[[i]])$process_inherit() - } - for(i in seq_along(units)) { - if(unitTypes[i] == "nCgen") - NC_check_inheritance(units[[i]]) - } + # + # These are being replaced in the register_known_nClass system. + # for(i in seq_along(units)) { + # if(unitTypes[i] == "nCgen") + # NCinternals(units[[i]])$connect_inherit() + # } + # for(i in seq_along(units)) { + # if(unitTypes[i] == "nCgen") + # NCinternals(units[[i]])$process_inherit() + # } + # for(i in seq_along(units)) { + # if(unitTypes[i] == "nCgen") + # NC_check_inheritance(units[[i]]) + # } + # set up exportNames, returnNames, and packageNames # exportNames: These appear in C++ as [[Rcpp::export(exportName = )]]. # Thus they give the name of the R function that will call the C++ version of the nFunction or nClass generator function. @@ -465,16 +477,51 @@ nCompile_prepare_units <- function(..., packageNames = packageNames) } -update_built_types <- function(new_units, new_unitTypes, cppDefs_project_env) { - built_types <- cppDefs_project_env$built_types +update_known_nClasses <- function(new_units, new_unitTypes, project_env) { for(i in seq_along(new_units)) { if(new_unitTypes[i] == "nCgen") { - classID <- NCinternals(new_units[[i]])$classID - if(exists(classID, envir = built_types, inherits = FALSE)) next - built_types[[classID]] <- new_units[[i]] + register_known_nClass(new_units[[i]], project_env) } } - built_types +} + +register_known_nClass <- function(NCgenerator, project_env, classID = NULL) { + # classID will be non-null when called to register a built type such as an nList. + known_nClasses <- project_env$known_nClasses + if(is.null(classID)) { + classID <- NCinternals(NCgenerator)$classID + } + if(exists(classID, envir = known_nClasses, inherits = FALSE)) + return(known_nClasses[[classID]]) + # creating an entry before the next step is needed to avoid + # infinite recursion potential from resolving TBD symbols. + known_nClasses[[classID]] <- list2env(list(NCgenerator = NCgenerator, + symbolTable = NULL, + inheritInfo = NULL)) + update_known_nClass_info(NCgenerator, classID, project_env = project_env) + known_nClasses[[classID]] +} + +process_inheritance <- function(NCgenerator, symbolTable, project_env = new.env()) { + inheritInfo <- new.env() + NCint <- NCinternals(NCgenerator) + NCint$process_inherit(inheritInfo = inheritInfo, symbolTable = symbolTable, project_env = project_env) + NC_check_inheritance(NCgenerator, inheritInfo = inheritInfo, project_env = project_env) + inheritInfo +} + +update_known_nClass_info <- function(NCgenerator, classID, project_env = new.env()) { + symbolTable <- NCinternals(NCgenerator)$symbolTable$clone(deep = TRUE) + ## Update any symbolTBD symbols by scoped lookup + known_nClasses <- project_env$known_nClasses + resolveTBDsymbols(symbolTable, + NCgenerator, + project_env = project_env) + inheritInfo <- process_inheritance(NCgenerator, + symbolTable = symbolTable, + project_env = project_env) + known_nClasses[[classID]]$symbolTable <- symbolTable + known_nClasses[[classID]]$inheritInfo <- inheritInfo } #' @export @@ -530,13 +577,24 @@ nCompile <- function(..., # to decide whether it is allowed to generate predefined code. For auto_included units, NO. new_compileInfos <- new_compileInfos |> lapply(\(x) {x$auto_included <- FALSE; x}) - cppDefs_project_env <- new.env() - cppDefs_project_env$built_types <- new.env() + project_env <- new.env() + # # built_types is for types created by nClassBuilders. + # # It uses key-value pairs with key being the unique classID and value being the nClass generator. + # # (key is a name in the environment; object is its value) + # project_env$built_types <- new.env() + # known_nClasses is a registry for nClass generators that are known to the project. + # It also holds symbol tables with TBD symbols resolved and inheritance-related content. + # It uses key-value pairs with key being the unique classID and value being a list with + # - NCgenerator: the nClass generator + # - symbolTable: the symbol table with resolved TBD symbols + # - inheritInfo: an environment with inheritance-related content + project_env$known_nClasses <- new.env() while(!done_finding_units) { - update_built_types(new_units, new_unitTypes, cppDefs_project_env) - existing_built_type_names <- ls(cppDefs_project_env$built_types) - cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos, cppDefs_project_env) + update_known_nClasses(new_units, new_unitTypes, project_env) + existing_known_nClass_names <- ls(project_env$known_nClasses) + cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, + new_compileInfos, project_env) new_cppDefs <- cppDefs_info$cppDefs new_cpp_names <- cppDefs_info$cpp_names @@ -555,15 +613,15 @@ nCompile <- function(..., #names(new_needed_nClasses) <- new_needed_nClasses |> lapply(\(x) x$classname) names(new_needed_nFunctions) <- new_needed_nFunctions |> lapply(\(x) NFinternals(x)$uniqueName) # - updated_built_type_names <- ls(cppDefs_project_env$built_types) - new_needed_built_nClasses <- lapply(setdiff(updated_built_type_names, existing_built_type_names), - \(x) cppDefs_project_env$built_types[[x]]) + updated_known_nClass_names <- ls(project_env$known_nClasses) + new_needed_known_nClasses <- lapply(setdiff(updated_known_nClass_names, existing_known_nClass_names), + \(x) project_env$known_nClasses[[x]]$NCgenerator) # names(new_needed_built_nClasses) <- new_needed_built_nClasses |> lapply(\(x) x$classname) # A bit of design irony: At this point, the needed units are # nicely organized into nClasses and nFunctions, # but we are going to mix them together as if they were an arbitrary # input list because that's what nCompiler_prepare_units and nCompile_createCppDefsInfo uses. - new_needed_nClasses <- c(new_needed_nClasses, new_needed_built_nClasses) |> unique_units() + new_needed_nClasses <- c(new_needed_nClasses, new_needed_known_nClasses) |> unique_units() new_units <- c(new_needed_nClasses, new_needed_nFunctions) ## Use unit_is_duplicate() rather than identical() so that parameterised nClass ## types (e.g. nList) are correctly identified as duplicates even when they diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 3e361374..6fb7100f 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -843,18 +843,21 @@ check_unknown_types <- function(type, where = parent.frame(), where = where, project_env = project_env) } + candidate2 <- NULL if(!isNCgenerator(candidate)) { candidate2 <- check_built_types(candidate = candidate, typeSpec = typeSpec, where = where, project_env = project_env, returnID = returnID) - if(returnID) return(candidate2) # candidate2 *can* be NULL. + if(returnID) return(candidate2) # candidate2 *can* be NULL. We are *checking*, not gauranteed we'll find one. candidate <- candidate2 %||% candidate } if(isNCgenerator(candidate)) { if(returnID) { return(NCinternals(candidate)$classID) } + if(is.null(candidate2)) + register_known_nClass(candidate, project_env = project_env) # return(candidate) } candidate @@ -884,10 +887,15 @@ check_built_types <- function(Rexpr = NULL, candidate = NULL, args2 <- c(args, .ID=TRUE) ID <- do.call(candidate, args2, envir = where) # get the classID for this type if(returnID) return(ID) - NCgen <- project_env$built_types[[ID]] + NCgen <- NULL + nClass_info <- project_env$known_nClasses[[ID]] + if(!is.null(nClass_info)) { + NCgen <- nClass_info$NCgenerator + } if(is.null(NCgen)) { NCgen <- do.call(candidate, args, envir = where) # get the NCgenerator for this type - project_env$built_types[[ID]] <- NCgen + register_known_nClass(NCgen, project_env = project_env, classID = ID) + # project_env$built_types[[ID]] <- NCgen } ##cpp_classname <- NCinternals(NCgen)$cpp_classname ##list(NCgen) |> setNames(cpp_classname) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R index 17fda412..1ebd6299 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R @@ -473,7 +473,8 @@ test_that("One predefined nClass can use another, separately and by inheritance, dir <- file.path(tempdir(), "use_predefined_nC_testdir2") - expect_no_error(comp <- with(my_defs, + expect_no_error( + comp <- with(my_defs, nCompile(use_foo, foo, foo_base, dir=dir, control=list(generate_predefined=TRUE), From 4f7dba8b3bab2679d769e8cf278671e3e455110c Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 15 Jul 2026 10:26:00 -0700 Subject: [PATCH 09/11] clean up some uses of project_env and tests --- nCompiler/R/typeDeclarations.R | 17 ++++++---- .../tests/testthat/types_tests/test-types.R | 33 ++++++++++++++++--- 2 files changed, 39 insertions(+), 11 deletions(-) diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 6fb7100f..fdefc194 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -824,7 +824,7 @@ typeList2symbolTable <- function(typeList, # take a type (quosure or ready to become one) # and look for NCgenerator or nClassBuilder check_unknown_types <- function(type, where = parent.frame(), - project_env = new.env(), returnID = FALSE, + project_env = NULL, returnID = FALSE, typeSpec = NULL) { ttype <- nCaptureType(type) @@ -856,7 +856,7 @@ check_unknown_types <- function(type, where = parent.frame(), if(returnID) { return(NCinternals(candidate)$classID) } - if(is.null(candidate2)) + if(is.null(candidate2) && !is.null(project_env)) register_known_nClass(candidate, project_env = project_env) # return(candidate) } @@ -866,7 +866,7 @@ check_unknown_types <- function(type, where = parent.frame(), check_built_types <- function(Rexpr = NULL, candidate = NULL, typeSpec = NULL, where = parent.frame(), - project_env = new.env(), returnID = FALSE) { + project_env = NULL, returnID = FALSE) { if(!is.null(Rexpr)) { if(!is.null(typeSpec)) { stop("In check_built_types, either Rexpr or typeSpec should be NULL.") @@ -888,13 +888,16 @@ check_built_types <- function(Rexpr = NULL, candidate = NULL, ID <- do.call(candidate, args2, envir = where) # get the classID for this type if(returnID) return(ID) NCgen <- NULL - nClass_info <- project_env$known_nClasses[[ID]] + nClass_info <- + if(!is.null(project_env)) project_env$known_nClasses[[ID]] + else NULL if(!is.null(nClass_info)) { NCgen <- nClass_info$NCgenerator } if(is.null(NCgen)) { NCgen <- do.call(candidate, args, envir = where) # get the NCgenerator for this type - register_known_nClass(NCgen, project_env = project_env, classID = ID) + if(!is.null(project_env)) + register_known_nClass(NCgen, project_env = project_env, classID = ID) # project_env$built_types[[ID]] <- NCgen } ##cpp_classname <- NCinternals(NCgen)$cpp_classname @@ -917,14 +920,14 @@ type2cpp_typename <- function(type, where = parent.frame()) { } resolveOneTBDsymbol <- function(symbol, env = parent.frame(), - project_env = new.env()) { + project_env = NULL) { symbol <- symbol$resolveSym(project_env = project_env) symbol #return unmodified symbol if nothing to do } resolveTBDsymbols <- function(symTab, env = parent.frame(), - project_env = new.env()) { + project_env = NULL) { for(i in seq_along(symTab$symbols)) { symTab$symbols[[i]] <- resolveOneTBDsymbol(symTab$symbols[[i]], env, project_env) } diff --git a/nCompiler/tests/testthat/types_tests/test-types.R b/nCompiler/tests/testthat/types_tests/test-types.R index 8c59429b..26dbdcbb 100644 --- a/nCompiler/tests/testthat/types_tests/test-types.R +++ b/nCompiler/tests/testthat/types_tests/test-types.R @@ -554,14 +554,27 @@ test_that("list arguments handled correctly", test_that("symbolTBD works", { - `:::`("nCompiler", "resetLabelFunctionCreators")() + nCompiler:::resetLabelFunctionCreators() nc1 <- nClass( Cpublic = list(a = 'numericScalar') ) - sym_nc1 <- `:::`("nCompiler", "type2symbol")('nc1', 'nc1obj') - symTab <- `:::`("nCompiler", "symbolTableClass")$new() + sym_nc1 <- nCompiler:::type2symbol('nc1', 'nc1obj') + symTab <- nCompiler:::symbolTableClass$new() + symTab$addSymbol(sym_nc1) + nCompiler:::resolveTBDsymbols(symTab) + expect_equal(symTab$getSymbol("nc1obj")$genCppVar()$generate(), + "std::shared_ptr nc1obj") + + nCompiler:::resetLabelFunctionCreators() + nc1 <- nClass( + Cpublic = list(a = 'numericScalar') + ) + sym_nc1 <- nCompiler:::type2symbol('nc1', 'nc1obj') + symTab <- nCompiler:::symbolTableClass$new() symTab$addSymbol(sym_nc1) - `:::`("nCompiler", "resolveTBDsymbols")(symTab) + project_env <- new.env() + project_env$known_nClasses <- new.env() + nCompiler:::resolveTBDsymbols(symTab, project_env = project_env) expect_equal(symTab$getSymbol("nc1obj")$genCppVar()$generate(), "std::shared_ptr nc1obj") }) @@ -576,6 +589,18 @@ test_that("symbolTBD works with a function from a call", { res <- sym_nc1$resolveSym() expect_true(inherits(res, "symbolNC")) expect_equal(res$type, myenv$nc1$classname) + + nCompiler:::resetLabelFunctionCreators() + myenv <- new.env() + myenv$nc1 <- nClass( + Cpublic = list(a = 'numericScalar') + ) + sym_nc1 <- nCompiler:::type2symbol("myenv$nc1()", "nc1obj") + project_env <- new.env() + project_env$known_nClasses <- new.env() + res <- sym_nc1$resolveSym(project_env) + expect_true(inherits(res, "symbolNC")) + expect_equal(res$type, myenv$nc1$classname) }) cat("\nSee test-types.R for notes on remaining issues to test.\n") From 5c6b152b6868ebc176cecd1296571663f3a37924 Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 15 Jul 2026 18:30:27 -0700 Subject: [PATCH 10/11] complete the get_interface_ptr feature of C++ generic interfaces. Move nList's getLength and setLength to base class. --- generatePredefinedCpp.R | 0 nCompiler/R/compile_labelAbstractTypes.R | 166 +++++++++--------- nCompiler/R/nCppVec.R | 57 ++++-- nCompiler/include | 1 + nCompiler/inst/generate_predefined.R | 15 ++ .../nC_inter/generic_class_interface.h | 14 ++ .../generic_class_interface_Rcpp_steps.h | 9 + .../nListBase_nClass_cppContent.cpp | 14 +- .../nListBase_nC/nListBase_nClass_hContent.h | 6 +- .../nListBase_nClass_manifest.txt | 8 +- .../nListBase_nClass_preamble.cpp | 1 - .../nClass_tests/test-nClass_interface.R | 89 +++++++++- .../nClass_tests/test-nClass_nested.R | 51 ++++++ 13 files changed, 328 insertions(+), 103 deletions(-) delete mode 100644 generatePredefinedCpp.R create mode 120000 nCompiler/include create mode 100644 nCompiler/inst/generate_predefined.R diff --git a/generatePredefinedCpp.R b/generatePredefinedCpp.R deleted file mode 100644 index e69de29b..00000000 diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 5308344e..4b9a9815 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -3,14 +3,14 @@ labelAbstractTypesEnv$.debug <- FALSE compile_labelAbstractTypes <- function(code, symTab, - auxEnv) { + auxEnv) { nErrorEnv$stateInfo <- paste0("handling labelAbstractTypes for ", code$name, ".") logging <- get_nOption('compilerOptions')[['logging']] if (logging) appendToLog(paste('###', nErrorEnv$stateInfo, '###')) - + if(isTRUE(auxEnv$onLHS)) code$aux$onLHS <- TRUE if(code$isLiteral) { @@ -32,7 +32,7 @@ compile_labelAbstractTypes <- function(code, warnings("Type labeling of a literal string is not handled yet in labelAbstractTypes.") } } - + if(code$isName) { ## If it doesn't exist and must exist, stop if(code$name != "") { ## e.g. In A[i,], second index gives name=="" @@ -81,7 +81,7 @@ compile_labelAbstractTypes <- function(code, stop(paste0("variable '", code$name, "' has not been created yet."), - call.=FALSE) + call.=FALSE) } } } @@ -123,7 +123,7 @@ compile_labelAbstractTypes <- function(code, if(!is.null(handlingInfo)) handler <- handlingInfo[['handler']] } - + # if(!is.null(handlingInfo)) { # handler <- handlingInfo[['handler']] if(!is.null(handler)) { @@ -300,7 +300,7 @@ nCompiler:::inLabelAbstractTypesEnv( { code$type <- symbolETaccBase$new(name = '') code$name <- '->method' - insertArg(code, 2, exprClass$new(name = 'access', isName = TRUE, isCall = FALSE, + insertArg(code, 2, exprClass$new(name = 'access', isName = TRUE, isCall = FALSE, isLiteral = FALSE, isAssign = FALSE)) } return(if(length(inserts) == 0) NULL else inserts) @@ -343,7 +343,7 @@ inLabelAbstractTypesEnv( code$type <- newSym return(if(length(inserts) == 0) NULL else inserts) } - + if(!inherits(code$args[[1]]$type, 'symbolNC')) stop(exprClassProcessingErrorMsg( code, @@ -375,7 +375,7 @@ inLabelAbstractTypesEnv( code$args[[2]]$aux$obj_internals <- obj_internals code$args[[2]]$aux$nFunctionName <- innerName code$args[[2]]$name <- nClass_info$inheritInfo$all_methodName_to_cpp_code_name[[innerName]] - + obj_internals <- NULL } else { ## Is RHS a field? obj_symbolTable <- nClass_info$symbolTable @@ -393,37 +393,37 @@ inLabelAbstractTypesEnv( ) ## Called by main compile_labelAbstractTypes loop -## This converts use of the function foo as an object to +## This converts use of the function foo as an object to ## nFunctionRef(foo, namespace) ## if foo is either an nFunction or a method of the current class ## I think this could be moved to the normalizeCalls compile stage inLabelAbstractTypesEnv( reference_nFunction_or_method_AST <- function(code, obj) { - + if(isFALSE(code$isName)) { stop(exprClassProcessingErrorMsg( - code, paste('In reference_nFunction_or_method_AST: the nFunction ', + code, paste('In reference_nFunction_or_method_AST: the nFunction ', code$name, ' is not used as an object', sep = '') )) } - + # access nFunction tgt <- NC_find_method(obj, code$name, inherits=TRUE) if(is.null(tgt)) { stop(exprClassProcessingErrorMsg( - code, paste('In reference_nFunction_or_method_AST: the nFunction ', + code, paste('In reference_nFunction_or_method_AST: the nFunction ', code$name, ' is not a method for nClass "obj"', sep = '') )) } - + # wrap the nFunction usage wrapExprClassOperator(code = code, funName = 'nFunctionRef') - + # name substitution # cpp_code_name <- tgt$cpp_code_name cpp_code_name <- NCinternals(obj)$all_methodName_to_cpp_code_name[[code$name]] code$name <- cpp_code_name - + # class in which function is defined namespaceExpr <- exprClass$new( name = obj$classname, isName = TRUE, isCall = FALSE, isLiteral = FALSE, @@ -433,14 +433,14 @@ inLabelAbstractTypesEnv( name = obj$classname, type = obj$classname, NCgenerator = obj ) insertArg(code$caller, 2, namespaceExpr) - + ## TO-DO: Add error-trapping of argument types returnSym <- tgt$returnSym if(is.null(returnSym)) stop( exprClassProcessingErrorMsg( code, paste('In reference_nFunction_or_method_AST: the nFunction (or method) ', - code$name, + code$name, ' does not have a valid returnType.') ), call. = FALSE ) @@ -451,7 +451,7 @@ inLabelAbstractTypesEnv( ) nCompiler:::inLabelAbstractTypesEnv( - custom_call <- + custom_call <- function(code, symTab, auxEnv, handlingInfo) { recurse <- isTRUE(handlingInfo[['recurse']]) if(recurse) { @@ -545,7 +545,7 @@ inLabelAbstractTypesEnv( if(arg$type$nDim == 0) { # wrap the scalar in a vector newExpr <- wrapExprClassOperator( - code = arg, + code = arg, funName = 'nNumeric', type = typeDeclarationList$nNumeric() ) @@ -658,7 +658,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - Assign <- + Assign <- function(code, symTab, auxEnv, handlingInfo) { auxEnv$.AllowUnknowns <- FALSE inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, @@ -686,7 +686,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - AssignAfterRecursing <- + AssignAfterRecursing <- function(code, symTab, auxEnv, handlingInfo) { LHS <- code$args[[1]] RHS <- code$args[[2]] @@ -762,7 +762,7 @@ inLabelAbstractTypesEnv( nDim = 0, type = code$args[[2]]$type$type) if (!symTab$symbolExists(code$args[[1]]$name, inherits = TRUE)) - if (TRUE) + if (TRUE) symTab$addSymbol(code$args[[1]]$type) ## Now the 3rd arg, the body of the loop, can be processed @@ -774,7 +774,7 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( ParallelFor <- function(code, symTab, auxEnv, handlingInfo) { - if(length(code$args) != 5) + if(length(code$args) != 5) stop(exprClassProcessingErrorMsg( code, paste('In labelAbstractTypes handler ParallelFor:', @@ -787,21 +787,21 @@ inLabelAbstractTypesEnv( 'range to be an expression (exprClass).') ), call. = FALSE ) - + inserts <- compile_labelAbstractTypes(code$args[[2]], symTab, auxEnv) - + code$args[[1]]$type <- symbolBasic$new(name = code$args[[1]]$name, nDim = 0, type = code$args[[2]]$type$type) - + ## If index is unknown, create it in typeEnv and in the symTab (old nimble comment) if (!symTab$symbolExists(code$args[[1]]$name, inherits = TRUE)) - if (TRUE) + if (TRUE) symTab$addSymbol(code$args[[1]]$type) ## Now the 3rd arg, the body of the loop, can be processed inserts <- c(inserts, compile_labelAbstractTypes(code$args[[3]], symTab, auxEnv)) - + auxEnv$uses_TBB <- TRUE nCompiler_pluginEnv$uses_TBB <- TRUE ## I think there shouldn't be any inserts returned since the body should be a bracket expression. @@ -860,7 +860,7 @@ inLabelAbstractTypesEnv( call. = FALSE) code$type <- symbolBasic$new(name = code$name, nDim = 0, type = code$args[[3]]$type$type) - + auxEnv$uses_TBB <- TRUE nCompiler_pluginEnv$uses_TBB <- TRUE return(if (length(inserts) == 0) invisible(NULL) else inserts) @@ -882,7 +882,7 @@ inLabelAbstractTypesEnv( "size for ':' without two arguments." ) ), call. = FALSE - ) + ) # Check: Is recurse=FALSE ever used. Why was this here? inserts <- @@ -994,7 +994,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - BinaryUnaryCwise <- + BinaryUnaryCwise <- function(code, symTab, auxEnv, handlingInfo) { if(length(code$args) == 1) return(UnaryCwise(code, symTab, auxEnv, handlingInfo)) @@ -1038,7 +1038,7 @@ inLabelAbstractTypesEnv( ## Handler for binary component-wise operators inLabelAbstractTypesEnv( - BinaryCwise <- + BinaryCwise <- function(code, symTab, auxEnv, handlingInfo) { if(length(code$args) != 2) stop(exprClassProcessingErrorMsg( @@ -1058,7 +1058,7 @@ inLabelAbstractTypesEnv( a2Type <- a2$type nDim <- max(a1Type$nDim, a2Type$nDim) - + # except for matrix-vector like ops, tensor args must have same nDims if(all(c(a1Type$nDim, a2Type$nDim) > 1)) { if(a1Type$nDim != a2Type$nDim) { @@ -1070,7 +1070,7 @@ inLabelAbstractTypesEnv( call. = FALSE) } } - + resultScalarType <- arithmeticOutputType( a1Type$type, a2Type$type, handlingInfo$returnTypeCode ) @@ -1084,7 +1084,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - BinaryCwiseLogical <- + BinaryCwiseLogical <- function(code, symTab, auxEnv, handlingInfo) { ans <- BinaryCwise(code, symTab, auxEnv, handlingInfo) code$type$type <- 'logical' @@ -1101,16 +1101,16 @@ inLabelAbstractTypesEnv( 'BinaryReduction called with argument length != 2.' ), call. = FALSE) - + inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) - + ## pull out the two arguments a1 <- code$args[[1]] a2 <- code$args[[2]] a1Type <- a1$type a2Type <- a2$type - + # tensor args must have same nDims if(a1Type$nDim != a2Type$nDim) { stop(exprClassProcessingErrorMsg( @@ -1145,9 +1145,9 @@ inLabelAbstractTypesEnv( 'unaryReduction called with argument length != 1.' ), call. = FALSE) - + inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) - + ## Kludgy catch of var case here. ## Can't do var(matrix) because in R that is interpreted as cov(data.frame) if(!(code$args[[1]]$isLiteral)) { @@ -1156,7 +1156,7 @@ inLabelAbstractTypesEnv( stop(exprClassProcessingErrorMsg( code, 'nCompiler compiler does not support var with a matrix (or higher dimensional) argument.'), - call. = FALSE) + call. = FALSE) } } } @@ -1168,7 +1168,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - LengthAssign <- + LengthAssign <- function(code, symTab, auxEnv, handlingInfo) { # We have `length<-`(x, v) from length(x) <- v inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) @@ -1202,7 +1202,7 @@ inLabelAbstractTypesEnv( if(arg$type$nDim == 0) { # wrap the scalar in a vector newExpr <- wrapExprClassOperator( - code = arg, + code = arg, funName = 'nNumeric', type = typeDeclarationList$nNumeric() ) @@ -1232,7 +1232,7 @@ inLabelAbstractTypesEnv( if(arg$type$nDim == 0) { # wrap the scalar in a vector newExpr <- wrapExprClassOperator( - code = arg, + code = arg, funName = 'nNumeric', type = typeDeclarationList$nNumeric() ) @@ -1356,7 +1356,7 @@ inLabelAbstractTypesEnv( ## we can handle it by making sure the expression resulting in that gets ## knownSize == 1. if(isTRUE(nOptions("nimble")) || isTRUE(nOptions("dropSingleSizes"))) { - if(is.numeric(index_args[[i]]$type$knownSize) + if(is.numeric(index_args[[i]]$type$knownSize) && index_args[[i]]$type$knownSize == 1) { nDrop <- nDrop + 1 } @@ -1413,13 +1413,15 @@ inLabelAbstractTypesEnv( } ) -inLabelAbstractTypesEnv( +nCompiler:::inLabelAbstractTypesEnv( Literal <- function(code, symTab, auxEnv, handlingInfo) { if(!is.null(code$aux$compileArgs)) { types <- code$aux$compileArgs$types if(!is.null(types)) { if(!is.list(types)) types <- eval(types) - symbols <- typeList2symbolTable(types, where=auxEnv$closure)$getSymbols() + newSymTab <- typeList2symbolTable(types, where=auxEnv$where) + resolveTBDsymbols(newSymTab, auxEnv$where, project_env = auxEnv$project_env) + symbols <- newSymTab$getSymbols() for (sym in symbols) symTab$addSymbol(sym) } } @@ -1428,7 +1430,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - Return <- + Return <- function(code, symTab, auxEnv, handlingInfo) { if(length(code$args) > 1) stop(exprClassProcessingErrorMsg( @@ -1446,7 +1448,7 @@ inLabelAbstractTypesEnv( code$type <- code$args[[1]]$type # see if the returned object differs from the nFunction's return type # To-do: We could look at the NCgenerator class hierarchy to actually - # determine validity of returned type. Instead here we just + # determine validity of returned type. Instead here we just # see if both are symbolNC, with a special-case check for a symbolSelf (or other case) # that inherits from symbolNC if(inherits(auxEnv$returnSymbol, "symbolNC")) { @@ -1469,7 +1471,7 @@ inLabelAbstractTypesEnv( # problem if number of dimensions differs if(auxEnv$returnSymbol$nDim != code$type$nDim) { warning(exprClassProcessingErrorMsg( - code, + code, paste0( "Dimension (", code$type$nDim, ") for return() does not match ", "the nFunction's dimension (", auxEnv$returnSymbol$nDim, ").", @@ -1501,7 +1503,7 @@ inLabelAbstractTypesEnv( } if(type_mismatch) { warning(exprClassProcessingErrorMsg( - code, + code, paste0( "Scalar type (", code$type$type, ") for return() does not perfectly match ", "the nFunction's return type (", auxEnv$returnSymbol$type, ").", @@ -1521,9 +1523,9 @@ inLabelAbstractTypesEnv( VectorReturnType <- function(code, symTab, auxEnv, handlingInfo) { inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) returnType <- setReturnType(handlingInfo, code$args[[1]]$type$type) - # TODO: double check the assumption that output will always be a - # symbolBasic type as it is understood today. Is a Vector always a dense - # vector? Or do we really need a separate handler for vectors stored in + # TODO: double check the assumption that output will always be a + # symbolBasic type as it is understood today. Is a Vector always a dense + # vector? Or do we really need a separate handler for vectors stored in # different datastructures, such as SparseVectors, hashmaps, or lists? code$type <- symbolBasic$new(nDim = 1, type = returnType) invisible(inserts) @@ -1535,9 +1537,9 @@ inLabelAbstractTypesEnv( MatrixReturnType <- function(code, symTab, auxEnv, handlingInfo) { inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) returnType <- setReturnType(handlingInfo, code$args[[1]]$type$type) - # TODO: double check the assumption that output will always be a - # symbolBasic type as it is understood today. Is a Vector always a dense - # vector? Or do we really need a separate handler for vectors stored in + # TODO: double check the assumption that output will always be a + # symbolBasic type as it is understood today. Is a Vector always a dense + # vector? Or do we really need a separate handler for vectors stored in # different datastructures, such as SparseVectors, hashmaps, or lists? code$type <- symbolBasic$new(nDim = 2, type = returnType) invisible(inserts) @@ -1549,8 +1551,8 @@ inLabelAbstractTypesEnv( nMul <- function(code, symTab, auxEnv, handlingInfo) { inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) returnType <- setReturnType(handlingInfo, code$args[[1]]$type$type) - # R's matrix-multiplication promotes all output types to matrices; also - # important b/c matrix multiplication could be used to implement an outer + # R's matrix-multiplication promotes all output types to matrices; also + # important b/c matrix multiplication could be used to implement an outer # product between two input vectors, which returns a matrix resDim <- 2 # return a dense object if any arguments are dense, o/w return sparse @@ -1669,9 +1671,9 @@ inLabelAbstractTypesEnv( } # create type object returnType <- setReturnType(handlingInfo, code$args[[1]]$type$type) - # TODO: double check the assumption that output will always be a - # symbolBasic type as it is understood today. Is a Vector always a dense - # vector? Or do we really need a separate handler for vectors stored in + # TODO: double check the assumption that output will always be a + # symbolBasic type as it is understood today. Is a Vector always a dense + # vector? Or do we really need a separate handler for vectors stored in # different datastructures, such as SparseVectors, hashmaps, or lists? code$type <- symbolBasic$new(nDim = 2, type = returnType) invisible(insertions) @@ -1686,7 +1688,7 @@ inLabelAbstractTypesEnv( # extract or construct a sparse type for argument if(!inherits(argType, 'symbolSparse')) { code$type <- symbolNC$new( - name = code$name, type = 'EigenDecomp', NCgenerator = EigenDecomp, + name = code$name, type = 'EigenDecomp', NCgenerator = EigenDecomp, isArg = FALSE ) auxEnv$needed_nClasses <- c(auxEnv$needed_nClasses, EigenDecomp) # To handle cases like nEigen(x)$vectors. @@ -1713,7 +1715,7 @@ inLabelAbstractTypesEnv( # extract or construct a sparse type for argument if(!inherits(argType, 'symbolSparse')) { code$type <- symbolNC$new( - name = code$name, type = 'SVDDecomp', NCgenerator = SVDDecomp, + name = code$name, type = 'SVDDecomp', NCgenerator = SVDDecomp, isArg = FALSE ) auxEnv$needed_nClasses <- c(auxEnv$needed_nClasses, SVDDecomp) # To handle cases like nSvd(x)$u. @@ -1731,10 +1733,10 @@ inLabelAbstractTypesEnv( # check type that specifies singular vector calculation if(F) { if(length(code$args) == 2) { - argType <- code$args[[2]]$type + argType <- code$args[[2]]$type if(argType$nDim != 0 || argType$type != 'integer') { stop(exprClassProcessingErrorMsg( - code, + code, 'compiled code must use an integer `vectors` argument' )) } @@ -1746,10 +1748,10 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( Diag <- function(code, symTab, auxEnv, handlingInfo) { - + # recurse arguments inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) - + # handle "diag(x)" when x is a matrix, and goal is to extract diagonal if(length(code$args) == 1) { if(code$args[[1]]$type$nDim == 2) { @@ -1758,20 +1760,20 @@ inLabelAbstractTypesEnv( return(invisible(inserts)) } } - + # # handle "diag()" when used to create dense matrices # - + # validate type for argument valArg <- function(argName, maxDim, missingAllowed) { # validate type for argument argName. validation fails if the argument - # does not inherit from symbolBasic, or if the argument has nDim > maxDim. + # does not inherit from symbolBasic, or if the argument has nDim > maxDim. # skips validation if arg is missing and missingAllowed = TRUE - + # extract argument arg <- code$args[[argName]] - + # make sure argument exists if required, or skip processing if(missingAllowed == TRUE) { if(is.null(arg)) { @@ -1785,31 +1787,31 @@ inLabelAbstractTypesEnv( )) } } - + # check inheritance - make sure object has dense storage if(!inherits(arg$type, 'symbolBasic')) { stop(exprClassProcessingErrorMsg( code, paste('Argument', argName, 'must be a symbolBasic type') )) } - + # check dimensions if(arg$type$nDim > maxDim) { stop(exprClassProcessingErrorMsg( code, paste('Argument', argName, 'must have nDim less than', maxDim) )) } - + NULL } # valArg - + # validate arguments valArg(argName = 'x', maxDim = 1, missingAllowed = TRUE) valArg(argName = 'nrow', maxDim = 0, missingAllowed = TRUE) valArg(argName = 'ncol', maxDim = 0, missingAllowed = TRUE) - + returnType <- 'double' - + if(code$name == 'nDiag') { # output will be a symbolBasic type, representing a dense matrix code$type <- symbolBasic$new(nDim = 2, type = returnType) @@ -1818,11 +1820,11 @@ inLabelAbstractTypesEnv( code$type <- symbolSparse$new(type = returnType, nDim = 2) } else { stop(exprClassProcessingErrorMsg( - code, paste('Not sure what symbol type should be returned for', + code, paste('Not sure what symbol type should be returned for', code$name) )) } - + invisible(inserts) } ) diff --git a/nCompiler/R/nCppVec.R b/nCompiler/R/nCppVec.R index 1a1753cd..95178cf4 100644 --- a/nCompiler/R/nCppVec.R +++ b/nCompiler/R/nCppVec.R @@ -50,6 +50,32 @@ nListBase_nClass <- NLdevel %||% nClass( name = "ping", function() {return(TRUE); returnType(logical())}, compileInfo = list(virtual=TRUE) + ), + setLength = nFunction( + name = "setLength", + function(length) { + stop("Uncompiled base class setLength should not be called.") + }, + returnType = "integerScalar()", + compileInfo = list( + C_fun = function(length='integerScalar') { + cppLiteral('std::cout<<"Compiled base class setLength should not be called."<"), #needed_units = list("nListBase_nClass"), + cpp_classname = "nListBase_nClass", exportName = "nListBase_nClass_new", - packageNames = c(uncompiled="nListBase_nClass", compiled="nListBase_nClass_C") + packageNames = c(uncompiled="nListBase_nClass", compiled="nListBase_nClass_C"), + overloadDefs = list( + length = list( + labelAbstractTypes = list(handler = nList_length_labelAbsTypes), + eigenImpl = list(handler = 'PtrMethod', methodName = "getLength") + ), + "length<-" = list( + labelAbstractTypes = list(handler = nList_length_labelAbsTypes ), + eigenImpl = list(handler = 'LengthAssign', ptr=TRUE, methodName = "setLength") + ) ) + ) ) # Manually add # #include # to the nListBase_nClass header file after the class declaration. - rm(NLdevel) #' @export @@ -319,15 +355,16 @@ nList_nClass <- function(type, env = parent.frame()) { "[[<-" = list( labelAbstractTypes = list(handler = nList_doubleBracket_labelAbsTypes), eigenImpl = list(handler = 'PtrMethod', methodName = 'doubleBracket_set_cpp') - ), - length = list( - labelAbstractTypes = list(handler = nList_length_labelAbsTypes), - eigenImpl = list(handler = 'PtrMethod', methodName = "getLength") - ), - "length<-" = list( - labelAbstractTypes = list(handler = nList_length_labelAbsTypes ), - eigenImpl = list(handler = 'LengthAssign', ptr=TRUE, methodName = "setLength") ) + # , + # length = list( + # labelAbstractTypes = list(handler = nList_length_labelAbsTypes), + # eigenImpl = list(handler = 'PtrMethod', methodName = "getLength") + # ), + # "length<-" = list( + # labelAbstractTypes = list(handler = nList_length_labelAbsTypes ), + # eigenImpl = list(handler = 'LengthAssign', ptr=TRUE, methodName = "setLength") + # ) ) ) ), diff --git a/nCompiler/include b/nCompiler/include new file mode 120000 index 00000000..a0d7c12b --- /dev/null +++ b/nCompiler/include @@ -0,0 +1 @@ +inst/include \ No newline at end of file diff --git a/nCompiler/inst/generate_predefined.R b/nCompiler/inst/generate_predefined.R new file mode 100644 index 00000000..5d28424b --- /dev/null +++ b/nCompiler/inst/generate_predefined.R @@ -0,0 +1,15 @@ +# instructions for re-generating predefined files. +library(nCompiler) + +nCompile(nListBase_nClass, control = list(generate_predefined = TRUE)) +# Manually add +# #include +# to the nListBase_nClass header file after the class declaration. +# +# optional code to test +nL1 <- nList("integerVector()") +comp <- nCompile(nL1) +obj <- comp$new() +length(obj) <- 3 +obj[[1]] <- 1:3 +obj |> as.list() diff --git a/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h b/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h index 2e057340..695deb8e 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h @@ -65,6 +65,14 @@ class genericInterfaceBaseC { return std::unique_ptr(nullptr); } + // return a named member that is itself a genericInterfaceBaseC-derived + // (nClass) object, as a shared_ptr to its generic interface base. + // Derived classes should provide valid implementations. + virtual std::shared_ptr get_interface_ptr(const std::string &name) { + std::cout<<"Error: you should be in a derived genericInterfaceC class for get_interface_ptr"< access(const std::string &name) override { return FirstFound::access(name); } + std::shared_ptr get_interface_ptr(const std::string &name) override { + return FirstFound::get_interface_ptr(name); + } SEXP get_value(const std::string &name) const override { return FirstFound::get_value(name); } @@ -209,6 +220,9 @@ class interface_resolver : std::unique_ptr access(const std::string &name) override { return FirstFound::access(name); } + std::shared_ptr get_interface_ptr(const std::string &name) override { + return FirstFound::get_interface_ptr(name); + } SEXP get_value(const std::string &name) const override { return FirstFound::get_value(name); } diff --git a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h index 8a6a7d26..dbe4b9df 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h @@ -207,6 +207,15 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { return (access->second->ETaccess(this)); } + std::shared_ptr get_interface_ptr(const std::string &name) { + name2access_type::iterator access = name2access.find(name); + if(access == name2access.end()) { + std::cout<<"Problem: \""<second->getInterfacePtr(this)); + } + // SEXP& value(const std::string &name) { // name2access_type::iterator access = name2access.find(name); // access->second; diff --git a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_cppContent.cpp index 5d467094..d1191c8b 100644 --- a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_cppContent.cpp @@ -16,6 +16,16 @@ using namespace Rcpp; bool nListBase_nClass::ping ( ) { RESET_EIGEN_ERRORS return(true); +} + int nListBase_nClass::setLength ( int length ) { +RESET_EIGEN_ERRORS +std::cout<<"Compiled base class setLength should not be called."< +#include "nListBase_nClass_c_.h" class nListBase_nClass : public interface_resolver< genericInterfaceC >, public loadedObjectHookC { public: virtual bool ping ( ) ; + virtual int setLength ( int length ) ; + virtual int getLength ( ) ; nListBase_nClass ( ) ; + }; void set_CnClass_env_nListBase_nClass ( SEXP env ) ; @@ -18,6 +22,4 @@ class nListBase_nClass : public interface_resolver< genericInterfaceC - - #endif diff --git a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_manifest.txt index d0d6236e..7d045c06 100644 --- a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_manifest.txt @@ -1,7 +1,7 @@ -list(saved_at = structure(1772480823.32226, class = c("POSIXct", +list(saved_at = structure(1784160419.65154, class = c("POSIXct", "POSIXt")), packet_name = "nListBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" -), files = list(preamble = "nListBase_nClass_preamble.cpp", - cppContent = "nListBase_nClass_cppContent.cpp", hContent = "nListBase_nClass_hContent.h", - filebase = "nListBase_nClass_filebase.txt", post_cpp_compiler = "nListBase_nClass_post_cpp_compiler.txt", +), files = list(preamble = "nListBase_nClass_preamble.cpp", cppContent = "nListBase_nClass_cppContent.cpp", + hContent = "nListBase_nClass_hContent.h", filebase = "nListBase_nClass_filebase.txt", + post_cpp_compiler = "nListBase_nClass_post_cpp_compiler.txt", copyFiles = "nListBase_nClass_copyFiles.txt")) diff --git a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_preamble.cpp b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_preamble.cpp index 494e8c39..1a92ce31 100644 --- a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_preamble.cpp +++ b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_preamble.cpp @@ -1,6 +1,5 @@ #define NCOMPILER_HANDLE_EIGEN_ERRORS #define NCOMPILER_USES_EIGEN -// #define NCOMPILER_USES_TBB #define NCOMPILER_USES_NCPPVEC #define USES_NCOMPILER #define NCOMPILER_USES_NCLASS_INTERFACE diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R index 24b26021..f40d425f 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R @@ -29,7 +29,7 @@ test_that( value(obj, 'Ca') <- c(2.3, 3.4, 4.5) check <- value(obj, 'Ca') expect_equal(check, c(2.3, 3.4, 4.5), info = "vector value() and `value()<-`") - + check <- method(obj, 'Cfoo')(3.4) expect_equal(check, 4.4, info = "method()") @@ -74,11 +74,94 @@ test_that( obj$Cv <- 2.3 check <- obj$Cv expect_equal(check, 2.3, info = "scalar set and get from a full interface") - + obj$Ca <- c(2.3, 3.4, 4.5) check <- obj$Ca expect_equal(check, c(2.3, 3.4, 4.5), info = "vector set and get from a full interface") - + check <- obj$Cfoo(3.4) expect_equal(check, 4.4, info = "method from a full interface") }) + +test_that("getting a generic interface pointer within C++ works", { + nc1 <- nList("integerVector()") + nc2 <- nClass( + classname = "nc2", + Cpublic = list( + nc1obj = "nc1()", + x = "integerVector", + nc2 = nFunction( + function() { + # The following is not (yet) supported + # nc1obj <- nList("integerVector()")$new() + nc1obj <- nc1$new() + }, + compileInfo = list(constructor = TRUE) + ) + ) + ) + nc3 <- nClass( + classname = "nc3", + Cpublic = list( + nc2obj = "nc2()", + nc1obj = "nc1()", + check1 = nFunction( + function() { + cppLiteral("auto basePtr = this->get_interface_ptr(\"nc2obj\")") + #derivedPtr <- nc2$new() + cppLiteral("derivedPtr = std::dynamic_pointer_cast(basePtr);", + types = list(derivedPtr = "nc2()")) + ans <- derivedPtr$x + return(ans) + returnType("integerVector") + } + ), + check2 = nFunction( + function() { + cppLiteral("auto basePtr = this->get_interface_ptr(\"nc1obj\")") + cppLiteral("nListBasePtr = std::dynamic_pointer_cast(basePtr);", + types = list(nListBasePtr = "nListBase_nClass()")) + cppLiteral("bool ok; if(nListBasePtr) {ok=true;} else {ok=false;} ") + cppLiteral("std::cout<< ok << std::endl;") + length(nListBasePtr) <- 3 + } + ), + check3 = nFunction( + function() { + cppLiteral("auto basePtr = nc2obj->get_interface_ptr(\"nc1obj\")") + cppLiteral("nListBasePtr = std::dynamic_pointer_cast(basePtr);", + types = list(nListBasePtr = "nListBase_nClass()")) + cppLiteral("{bool ok; if(nListBasePtr) {ok=true;} else {ok=false;} ") + cppLiteral("std::cout<< ok << std::endl;}") + + length(nListBasePtr) <- 2 + # N.B. The name "nList_I1" can be found from the NCinternals of nc1. + # It is the classID. + cppLiteral("nListDerPtr = std::dynamic_pointer_cast(nListBasePtr);", + types = list(nListDerPtr = "nc1()")) + cppLiteral("bool ok; if(nListDerPtr) {ok=true;} else {ok=false;} ") + cppLiteral("std::cout< as.list() |> length(), 3) + obj$check3() + expect_equal(obj$nc2obj$nc1obj |> as.list() |> length(), 2) + expect_equal(obj$nc2obj$nc1obj[[1]], 1L:3L) +}) diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R index 2f650df4..0e04311c 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R @@ -115,3 +115,54 @@ test_that("One nClass holds another by a base class and uses it", { gc() } }) + +test_that("TBD type in a nested class is resolved correctly", { + # In nc3, the go() function will only compile correctly + # if "nc2obj$nc1obj" resolves correctly, meaning that a symbolTable for + # nc2 is being used that has already had TBD types resolved. + # This test checks that. + nc1 <- nClass( + Cpublic = list( + foo = nFunction( + function() {return(1.2); returnType("numericScalar")} + ) + ) + ) + + nc2 <- nClass( + classname = "nc2", + Cpublic = list( + nc1obj = 'nc1()', + nc2 = nFunction( + function() { + nc1obj <- nc1$new() + }, + compileInfo = list(constructor = TRUE) + ) + ) + ) + + nc3 <- nClass( + classname = "nc3", + Cpublic = list( + nc2obj = 'nc2()', + nc3 = nFunction( + function() { + nc2obj <- nc2$new() + }, + compileInfo = list(constructor = TRUE) + ), + go = nFunction( + function() { + ans <- nc2obj$nc1obj$foo() + return(ans) + returnType(double(0)) + } + ) + ) + ) + + comp <- nCompile(nc1, nc2, nc3) + nc3obj <- comp$nc3$new() + expect_equal(nc3obj$go(), 1.2) +}) From 0aff688af501ae8d81a81054b61b9a87f6b10a86 Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 15 Jul 2026 20:15:44 -0700 Subject: [PATCH 11/11] fix problem introduced in last commit in labelAbstractTypes$Literal --- .gitignore | 2 ++ nCompiler/.Rbuildignore | 1 + nCompiler/R/compile_labelAbstractTypes.R | 2 +- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index fd9c5ccb..50249152 100644 --- a/.gitignore +++ b/.gitignore @@ -35,3 +35,5 @@ nCompiler.Rproj sketches/ .vscode/ .positai +# devtools::load_all() convenience symlink (inst/include -> include) +nCompiler/include diff --git a/nCompiler/.Rbuildignore b/nCompiler/.Rbuildignore index 91114bf2..ee20bcfe 100644 --- a/nCompiler/.Rbuildignore +++ b/nCompiler/.Rbuildignore @@ -1,2 +1,3 @@ ^.*\.Rproj$ ^\.Rproj\.user$ +^include$ diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 4b9a9815..36d98136 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -1419,7 +1419,7 @@ nCompiler:::inLabelAbstractTypesEnv( types <- code$aux$compileArgs$types if(!is.null(types)) { if(!is.list(types)) types <- eval(types) - newSymTab <- typeList2symbolTable(types, where=auxEnv$where) + newSymTab <- typeList2symbolTable(types, where=auxEnv$closure) resolveTBDsymbols(newSymTab, auxEnv$where, project_env = auxEnv$project_env) symbols <- newSymTab$getSymbols() for (sym in symbols) symTab$addSymbol(sym)