From 94413af582d30cdfa4a20508756198039c52bc62 Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 17 Jul 2026 10:59:15 -0700 Subject: [PATCH 01/19] Add access_at and get_interface_ptr_at for nLists, allowing generic use of Elements (in direct C++ only) --- nCompiler/R/nCppVec.R | 27 ++++++ nCompiler/inst/generate_predefined.R | 2 +- .../post_Rcpp/ETaccessor_post_Rcpp.h | 18 ++++ .../nListBase_nClass_cppContent.cpp | 10 +++ .../nListBase_nC/nListBase_nClass_hContent.h | 3 + .../nListBase_nClass_manifest.txt | 2 +- .../include/nCompiler/predef/nList_/nList_.h | 24 ++++++ .../testthat/specificOp_tests/test-nList.R | 86 +++++++++++++++++++ 8 files changed, 170 insertions(+), 2 deletions(-) diff --git a/nCompiler/R/nCppVec.R b/nCompiler/R/nCppVec.R index 95178cf4..76789c65 100644 --- a/nCompiler/R/nCppVec.R +++ b/nCompiler/R/nCppVec.R @@ -76,6 +76,32 @@ nListBase_nClass <- NLdevel %||% nClass( return(0) }, virtual=TRUE) + ), + get_interface_ptr_at = nFunction( + name = "get_interface_ptr_at", + function(i) { + stop("Uncompiled base class get_interface_ptr_at should not be called.") + }, + returnType = 'nCpp("std::shared_ptr")', + compileInfo = list( + C_fun = function(i='integerScalar') { + cppLiteral('Rcpp::stop("nListBase_nClass::get_interface_ptr_at should be called.")') + cppLiteral("return(nullptr)") + }, + virtual=TRUE) + ), + access_at = nFunction( + name = "access_at", + function(i) { + stop("Uncompiled base class access_at should not be called.") + }, + returnType = 'nCpp("std::unique_ptr")', + compileInfo = list( + C_fun = function(i='integerScalar') { + cppLiteral('Rcpp::stop("nListBase_nClass::access_at should be called.")') + cppLiteral("return(nullptr)") + }, + virtual=TRUE) ) ), # See comment above about needing to ensure a virtual destructor @@ -87,6 +113,7 @@ nListBase_nClass <- NLdevel %||% nClass( cpp_classname = "nListBase_nClass", exportName = "nListBase_nClass_new", packageNames = c(uncompiled="nListBase_nClass", compiled="nListBase_nClass_C"), + interfaceExclude = c("get_interface_ptr_at", "access_at"), overloadDefs = list( length = list( labelAbstractTypes = list(handler = nList_length_labelAbsTypes), diff --git a/nCompiler/inst/generate_predefined.R b/nCompiler/inst/generate_predefined.R index 5d28424b..3b4b254c 100644 --- a/nCompiler/inst/generate_predefined.R +++ b/nCompiler/inst/generate_predefined.R @@ -12,4 +12,4 @@ comp <- nCompile(nL1) obj <- comp$new() length(obj) <- 3 obj[[1]] <- 1:3 -obj |> as.list() +expect_equal(obj |> as.list(), list(1:3, integer(), integer()) 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 8fd4b7c1..3471f19b 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 @@ -264,6 +264,10 @@ RuntimeFlatView ETaccessorBase::flatten(const std::vector &ss) { template class ETaccessor : public ETaccessorTyped { public: + // Assignment operators are never inherited: the compiler's implicit + // copy-assignment operator for this class would otherwise hide the + // virtual ETaccessorBase::operator=(SEXP), breaking `ETaccess(x) = SEXP`. + using ETaccessorBase::operator=; using ET = Eigen::Tensor; // I think to compile this all needs to be valid in terms of types but throw run-time errors everywhere. // It should never get past the constructor because that throws an error, but other errors are written @@ -301,6 +305,8 @@ class ETaccessor : public ETaccessorTyped { template class ETaccessor, copy> : public ETaccessorTyped { public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; using ET = Eigen::Tensor; // using Scalar = typename ET::Scalar; typedef typename Eigen::internal::traits::Index Index; @@ -337,6 +343,8 @@ class ETaccessor, true> : private ETaccessorCopyHolder>, public ETaccessor, false> { public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; using ET = Eigen::Tensor; using Holder = ETaccessorCopyHolder; ETaccessor(const ET &obj_) : Holder(obj_), ETaccessor(Holder::obj_copy) {}; @@ -346,6 +354,8 @@ class ETaccessor, true> : template class ETaccessorScalar : public ETaccessorTyped { public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; ETaccessorScalar(Scalar &obj_) : obj(obj_) {}; ~ETaccessorScalar() {}; Scalar *data() override {return &obj;} @@ -365,6 +375,8 @@ class ETaccessorScalar : private ETaccessorCopyHolder, public ETaccessorScalar { public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; using ET = ETaccessorScalar; using Holder = ETaccessorCopyHolder; ETaccessorScalar(const Scalar &obj_) : Holder(obj_), ET(Holder::obj_copy) {}; @@ -375,6 +387,8 @@ template class ETaccessor : public ETaccessorScalar { using Ref = std::conditional_t; public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; ETaccessor(Ref obj_) : ETaccessorScalar(obj_) {}; ~ETaccessor() {}; }; @@ -383,6 +397,8 @@ template class ETaccessor : public ETaccessorScalar { using Ref = std::conditional_t; public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; ETaccessor(Ref obj_) : ETaccessorScalar(obj_) {}; ~ETaccessor() {}; }; @@ -391,6 +407,8 @@ template class ETaccessor : public ETaccessorScalar { using Ref = std::conditional_t; public: + // See note in the ETaccessor primary template above. + using ETaccessorBase::operator=; ETaccessor(Ref obj_) : ETaccessorScalar(obj_) {}; ~ETaccessor() {}; }; 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 d1191c8b..3df1a3be 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 @@ -26,6 +26,16 @@ return(0.0); RESET_EIGEN_ERRORS std::cout<<"Compiled base class getLength should not be called."< nListBase_nClass::get_interface_ptr_at ( int i ) { +RESET_EIGEN_ERRORS +Rcpp::stop("nListBase_nClass::get_interface_ptr_at should be called."); +return(nullptr); +} + std::unique_ptr nListBase_nClass::access_at ( int i ) { +RESET_EIGEN_ERRORS +Rcpp::stop("nListBase_nClass::access_at should be called."); +return(nullptr); } nListBase_nClass::nListBase_nClass ( ) { RESET_EIGEN_ERRORS diff --git a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_hContent.h b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_hContent.h index 7d2be495..953eb198 100644 --- a/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_hContent.h +++ b/nCompiler/inst/include/nCompiler/predef/nListBase_nC/nListBase_nClass_hContent.h @@ -13,6 +13,8 @@ class nListBase_nClass : public interface_resolver< genericInterfaceC get_interface_ptr_at ( int i ) ; + virtual std::unique_ptr access_at ( int i ) ; nListBase_nClass ( ) ; }; @@ -22,4 +24,5 @@ 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 7d045c06..e6b9dacc 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,4 +1,4 @@ -list(saved_at = structure(1784160419.65154, class = c("POSIXct", +list(saved_at = structure(1784310824.66853, 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", diff --git a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h index 50ca4346..e8f82cf1 100644 --- a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h +++ b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h @@ -12,6 +12,30 @@ class nList_ : public nListBase_nClass { virtual int getLength_() { return static_cast(contents_.size()); } + + std::shared_ptr get_interface_ptr_at(int i) override { + if constexpr(is_shared_ptr::value) { + if constexpr(std::is_base_of_v) { + return std::dynamic_pointer_cast(contents_.at(i)); + } else { + Rcpp::stop("nList_::get_interface_ptr: Element's pointee type does not derive from genericInterfaceBaseC."); + return nullptr; + } + } else { + Rcpp::stop("nList_::get_interface_ptr: Element type is not a shared_ptr and has no generic interface."); + return nullptr; + } + } + std::unique_ptr access_at(int i) override { + if constexpr(std::is_same_v, eigenTensor> || + std::is_same_v, trueScalar>) { + return ETaccessPtr(contents_.at(i)); + } else { + Rcpp::stop("nList_::access: Element type is not an Eigen::Tensor or scalar type and has no ETaccessor."); + return nullptr; + } + } + size_t doubleBracket_inds_2_size_t(const Rcpp::RObject &inds, bool check_upper = true) { if (Rf_xlength(inds) != 1) { Rcpp::stop("single-bracket getter expects index of length 1"); diff --git a/nCompiler/tests/testthat/specificOp_tests/test-nList.R b/nCompiler/tests/testthat/specificOp_tests/test-nList.R index 6ede3c7f..1c669b80 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-nList.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-nList.R @@ -1172,3 +1172,89 @@ test_that("nList compiled: set_all_values from uncompiled nList", { for(i in 1:4) expect_equal(obj[[i]], i * 10.0) rm(src, obj); gc() }) + +test_that("nList ETaccess at C++ level works", { + nc_inner <- nClass( + Cpublic = list(x = "numericScalar") + ) + NL1 = nList(nc_inner()) + NL2 = nList("numericVector()") + + nc_outer <- nClass( + classname = "nc_outer", + Cpublic = list( + NLinner = "NL1", + NLvec = "NL2", + nc_outer = nFunction( + function() { + NLinner <<- NL1$new() + NLvec <<- NL2$new() + length(NLinner) <- 2 + length(NLvec) <- 2 + NLinner[[2]] <- nc_inner$new() + NLvec[[2]] <- 1:3 + }, + compileInfo = list(constructor = TRUE) + ), + check1 = nFunction( + function() { + }, + returnType = "numericVector()", + compileInfo = list( + C_fun = function() { + nCpp("acc = NLvec->access_at(2-1)", types = list(acc = "ETaccessor")) + ans <- nAs(acc, "numericVector()") + return(ans) + } + ) + ), + check2 = nFunction( + function() { + }, + returnType = "numericVector()", + compileInfo = list( + C_fun = function() { + ## expect error from this + nCpp("acc = NLinner->access_at(2-1)", types = list(acc = "ETaccessor")) + ans <- nAs(acc, "numericVector()") + return(ans) + } + ) + ), + check3 = nFunction( + function() { + }, + returnType = "SEXP", + compileInfo = list( + C_fun = function() { + nCpp("ptr = NLinner->get_interface_ptr_at(2-1)", types = list(ptr = "nCpp('std::shared_ptr')")) + nCpp("ans = ptr->get_value(\"x\")", types = list(ans = "SEXP")) + return(ans) + } + ) + ), + check4 = nFunction( + function() { + }, + returnType = "SEXP", + compileInfo = list( + C_fun = function() { + ## expect error + nCpp("ptr = NLvec->get_interface_ptr_at(2-1)", types = list(ptr = "nCpp('std::shared_ptr')")) + nCpp("ans = ptr->get_value(\"x\")", types = list(ans = "SEXP")) + return(ans) + } + ) + ) + ) + ) + + comp <- nCompile(nc_outer, nc_inner) + obj <- comp$nc_outer$new() + obj$NLvec |> as.list() + expect_equal(obj$check1(), 1:3) + expect_error(obj$check2()) + obj$NLinner[[2]]$x <- 3 + expect_equal(obj$check3(), 3) + expect_error(obj$check4()) +}) From 395888c54403fbf70096ca5a0743d7f8ec139e93 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 21 Jul 2026 07:30:35 -0700 Subject: [PATCH 02/19] Updates to RuntimeFlatView. Add KnownProxy (TBD). --- .gitignore | 2 + UserManual/.DS_Store | Bin 6148 -> 0 bytes nCompiler/.DS_Store | Bin 6148 -> 0 bytes nCompiler/R/symbolTable.R | 1 - nCompiler/inst/generate_predefined.R | 2 +- nCompiler/inst/include/.DS_Store | Bin 6148 -> 0 bytes nCompiler/inst/include/nCompiler/.DS_Store | Bin 6148 -> 0 bytes .../include/nCompiler/ET_Rcpp_ext/.DS_Store | Bin 6148 -> 0 bytes .../post_Rcpp/ETaccessor_post_Rcpp.h | 6 ++ .../nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h | 66 ++++++++++++++++++ .../nCompiler/ET_ext/RuntimeFlatView.h | 6 +- .../include/nCompiler/ET_ext/index_block.h | 8 +++ .../nCompiler/Rcpp_extensions/.DS_Store | Bin 6148 -> 0 bytes .../inst/include/nCompiler/nC_inter/.DS_Store | Bin 6148 -> 0 bytes .../inst/include/nCompiler/predef/.DS_Store | Bin 6148 -> 0 bytes nCompiler/tests/.DS_Store | Bin 6148 -> 0 bytes nCompiler/tests/testthat/.DS_Store | Bin 6148 -> 0 bytes .../tests/testthat/nCompile_tests/.DS_Store | Bin 6148 -> 0 bytes 18 files changed, 88 insertions(+), 3 deletions(-) delete mode 100644 UserManual/.DS_Store delete mode 100644 nCompiler/.DS_Store delete mode 100644 nCompiler/inst/include/.DS_Store delete mode 100644 nCompiler/inst/include/nCompiler/.DS_Store delete mode 100644 nCompiler/inst/include/nCompiler/ET_Rcpp_ext/.DS_Store delete mode 100644 nCompiler/inst/include/nCompiler/Rcpp_extensions/.DS_Store delete mode 100644 nCompiler/inst/include/nCompiler/nC_inter/.DS_Store delete mode 100644 nCompiler/inst/include/nCompiler/predef/.DS_Store delete mode 100644 nCompiler/tests/.DS_Store delete mode 100644 nCompiler/tests/testthat/.DS_Store delete mode 100644 nCompiler/tests/testthat/nCompile_tests/.DS_Store diff --git a/.gitignore b/.gitignore index 50249152..b14127fb 100644 --- a/.gitignore +++ b/.gitignore @@ -37,3 +37,5 @@ sketches/ .positai # devtools::load_all() convenience symlink (inst/include -> include) nCompiler/include +# macOS Finder metadata +.DS_Store diff --git a/UserManual/.DS_Store b/UserManual/.DS_Store deleted file mode 100644 index 4bc01a0fccc5cc4e9d322e4ea8f1c6c76bde2a64..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~F-`+95JhJoNGs8VE~R^_+`vRj0|iA601816DbYp(3ObjZg==sf4#A%pgIHLJ zE<)&!WPf`+_U=AuJ+_GG>~T328H-4RVye~{Fmn$M?bYBBRDF$`_3d|jFN7|PJB^a<=ocWn9p6u;8oCBHv~ zJrW>+e?~w@?Yy1gqiSyb@p+bO6Ur5enZ*@rz|i(o4E0ouj_o58AB^#2ZH(utCDc|i RzfXtqAmBh)k-!cJyaSu7DrW!y diff --git a/nCompiler/.DS_Store b/nCompiler/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0 as.list(), list(1:3, integer(), integer()) +testthat::expect_equal(obj |> as.list(), list(1:3, integer(), integer())) diff --git a/nCompiler/inst/include/.DS_Store b/nCompiler/inst/include/.DS_Store deleted file mode 100644 index d96ea5aea431a89692a097693d2bb0eec518e3bb..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeHK%}T>S5Z<-5O({YSiXIod7Hlo06fYsx7cim+m70*K!I&*gYY(N6tG*>84!cC#O3e;8xjU4%WxY{r-cipbHZ5Oi0DwoEc2S7Su%K3HbcAdx}E zK!4GN-`-$THe(SBLBD?gdoWGnY~JmD@U2>XyV10oR@=Ju9_7-T`}0NS`m<~7T}YV( zh3yBIakQM+yQeap`*9l0R6!g@kaBYsr=eWBa*>9as`YfhYFVv`y}w!w`yJ8iuRCJZ z8w^JsF*qKr*DY)B@aW`x@{~NM@>TQ5fpR4~1`ButqqL+KZuuGQ!=-@tbpn^Is(1tw6 XV6G8ILBA>oq>F$egc@St7Z~^ip2S5Z<-5O({YS3OxqA7Hl=@!Apqs1&ruHr6we5FlI~AnnNk%tS{t~_&m<+ zZopu`n~0r(*>84!cC#O3e;8xjU4&!COvac2ipbGu5Og<&Hgqx~mt#ciJ}B~8kcgmR zpugzCZ||@f%UHxh(68VB9?X(BpN~c#e52Lg>~xK;(Kl|rM^Silf4<0FKfA`>g%C+l z*?w>tN5$0KJ{9TQkJBiV1#uWb%FR`rhN5uAA`Np{>#2azGkQ~Vuw2?BduZ8*tD&_V zAM782Z6B{zJ!5Bg@8o>?lsu>6RT0U7b17RID|iE=wx$;^OB0bkfWNA#atVn6Vt^PR z2G)-OeHIw~^;3`ieqaFi2MZL@(O4>!TL(0Fea3hj5d~~~OCVYr9gU?zh=6ca z3aCoCeqwM{4t`7LIT}las+@5-GmN8Wt{yL3&JKP{rZes+q?Q;U2I>s7RM*7w{|tVa z#z%g=gnGmPG4RhA;O&VwabZ#VZ2h)8JZmk`J5UtNE71S}yLJhH4(=lZ8B}o#ZOC&p WmI`qc^viNUx(G-@s38V^fq_qH;7k1g diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/.DS_Store b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0 +RuntimeFlatView makeRuntimeFlatView(std::unique_ptr &acc, + const SStype &ss) { + return RuntimeFlatView(acc->template S().data(), acc->intDims(), ss); +} + #endif // NCOMPILER_ETACCESSOR_POST_RCPP_H_ diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h index 0b82774b..54adb604 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/nC_as.h @@ -17,6 +17,12 @@ // RHSCastProxy — cross-scalar RHS; lazy, no allocation // CastingProxy — cross-scalar LHS; eager copy + write-back // RuntimeCastingProxy — runtime-source (ETaccessorBase) +// +// A fifth proxy, KnownProxy, is selected explicitly by +// known_nC() rather than by as_nC(): it is for a runtime source +// (ETaccessorBase&) whose type the caller *guarantees* at the call site, so +// it skips all cast/copy/write-back machinery and just caches a direct +// reference to the source's own storage after a one-time downcast. // --------------------------------------------------------------------------- // EmptyProxy @@ -263,6 +269,66 @@ class RuntimeCastingProxy > { TM operator()() { return TM(data_ptr_, dims_); } }; +// KnownProxy was added using Claude as a potentially useful feature, +// particularly as a target for nimble2 keyword-processing needs. +// At the time of initial drafting it remains to be seen if it will +// actually be used. +// +// KnownProxy +// +// Runtime-source proxy for a target type the caller *guarantees* matches the +// actual runtime type behind an ETaccessorBase (e.g. "I know this is a 2D +// double tensor"). Unlike RuntimeCastingProxy, there is no cross-scalar +// fallback: the downcast either succeeds outright or throws (via +// ETaccessorBase::ref()/scalar(), same as calling them directly). Since it +// is a hard guarantee rather than a soft cast, operator()() returns a +// reference to the source's own storage (an actual Eigen::Tensor&, not a +// TensorMap view) — no copy, no write-back, no reshaping of singleton dims. +// +// The downcast happens once, in the constructor; operator()() just returns +// the cached reference, so it is safe and cheap to call repeatedly as long +// as the source outlives the proxy: +// +// auto my_proxy = known_nC>(my_ETaccessorBase); +// Y = my_proxy() + B; +template +class KnownProxy { + // Primary template covers true scalar targets (double, int, bool). + TargetType& ref_; +public: + explicit KnownProxy(ETaccessorBase& acc) : ref_(acc.template scalar()) {} + KnownProxy(const KnownProxy&) = delete; + KnownProxy& operator=(const KnownProxy&) = delete; + TargetType& operator()() { return ref_; } +}; + +template +class KnownProxy> { + Eigen::Tensor& ref_; +public: + explicit KnownProxy(ETaccessorBase& acc) : ref_(acc.template ref()) {} + KnownProxy(const KnownProxy&) = delete; + KnownProxy& operator=(const KnownProxy&) = delete; + Eigen::Tensor& operator()() { return ref_; } +}; + +// known_nC — public API for KnownProxy, mirroring as_nC's runtime-source +// overloads (ETaccessorBase&, unique_ptr& / &&). +template +KnownProxy known_nC(ETaccessorBase& acc) { + return KnownProxy(acc); +} + +template +KnownProxy known_nC(std::unique_ptr& acc) { + return KnownProxy(*acc); +} + +template +KnownProxy known_nC(std::unique_ptr&& acc) { + return KnownProxy(*acc); +} + // --------------------------------------------------------------------------- // as_nC — the single public API emitted by the nCompiler code generator. // Two overloads: compile-time source (any concrete T) and runtime source diff --git a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h index 7a75a769..8e1933b8 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h @@ -104,7 +104,11 @@ class RuntimeFlatView { RuntimeFlatView() : data_(nullptr) {} RuntimeFlatView(Scalar *data, RuntimeSubviewInfo info) : data_(data), info_(std::move(info)) {} - + RuntimeFlatView(Scalar *data, const std::vector &intDims, const std::vector &ss) + : data_(data), info_(RuntimeSubviewInfo(intDims, ss)) {} + template + RuntimeFlatView(Scalar *data, const std::vector &intDims, const std::vector &ss) + : data_(data), info_(RuntimeSubviewInfo(intDims, vec_2_vecB__(ss))) {} long size() const { return info_.totalSize; } size_t nDim() const { return info_.nDim(); } const RuntimeSubviewInfo &info() const { return info_; } diff --git a/nCompiler/inst/include/nCompiler/ET_ext/index_block.h b/nCompiler/inst/include/nCompiler/ET_ext/index_block.h index add604f4..b6fd8c7e 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/index_block.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/index_block.h @@ -28,5 +28,13 @@ class b__ { } }; +template +std::vector vec_2_vecB__(const std::vector &v) { + std::vector blocks; + for(const auto& inds : v) { + blocks.push_back(b__(inds[0]-1, inds[1]-1)); + } + return blocks; +} #endif // INDEX_BLOCK_H_ diff --git a/nCompiler/inst/include/nCompiler/Rcpp_extensions/.DS_Store b/nCompiler/inst/include/nCompiler/Rcpp_extensions/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0i}aa53U0I3oeOI$0FLMR6=R$2~7oG^j|AlI%fuyDOm>@ z)0fGo>a4b(9pwhUPLbOlH}D0{U+(@qp4XMFKVSx){T6t#!qQI;g}Y06o0S!n0cAiL zxJm~6tr+ZH<(JU4l>ueoS~9@*LkMMzJa!J{>VT0J0N6)Z1U~l?ToZbXJa!H-0x_-> z=t_-mF^nrmJoI^y$IhWEC*zwB<5xDmLou>C<_{&EOyp3lGN24xWPp1=$cW$nXMgVh zB}t7kpbY$<44D3Ld_2Y8{M)*sQ?wA0#^m>`%vJ9HE|5|PX~gJ0KgT} zZdm&)0W6jP*2FOo8JGqY7*x#>LxYZd$-0_21_oU;hY!ssYfdQYPsjbm%SCG-BNd?XCYm!vC26rzGyE02TOG3g~J#?6!EN?5)kqS+6bdC%Dyo!_BaE3WB#|ptoae ftQ~K>DC&x>ab6S0K&K<`bRd5QOcxpzxVHj7>hcx4 diff --git a/nCompiler/tests/testthat/.DS_Store b/nCompiler/tests/testthat/.DS_Store deleted file mode 100644 index 5008ddfcf53c02e82d7eee2e57c38e5672ef89f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~Jr2S!425mzP>H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0H1@V-^m;4Wg<&0T*E43hX&L&p$$qDprKhvt+--jT7}7np#A3 zem<@ulZcFPQ@L2!n>{z**++&mCkOWA81W14cNZlEfg7;MkzE(HCqgga^y>{tEnwC%0;vJ&^%eQ zLs35+`xjp>T0 Date: Tue, 21 Jul 2026 17:25:29 -0700 Subject: [PATCH 03/19] Make overload dispatch go through symbols in general. Make type decl's extensible. --- nCompiler/NAMESPACE | 11 ++- nCompiler/R/NC_InternalsClass.R | 9 +++ nCompiler/R/NC_Utils.R | 53 ++++++------ nCompiler/R/compile_eigenization.R | 7 +- nCompiler/R/compile_generateCpp.R | 39 ++++----- nCompiler/R/compile_labelAbstractTypes.R | 27 ++++--- nCompiler/R/symbolTable.R | 12 ++- nCompiler/R/typeDeclarations.R | 68 +++++++++++----- .../testthat/nCompile_tests/test-userTypes.R | 80 +++++++++++++++++++ 9 files changed, 221 insertions(+), 85 deletions(-) create mode 100644 nCompiler/tests/testthat/nCompile_tests/test-userTypes.R diff --git a/nCompiler/NAMESPACE b/nCompiler/NAMESPACE index c8173eca..bb426cb3 100644 --- a/nCompiler/NAMESPACE +++ b/nCompiler/NAMESPACE @@ -19,7 +19,6 @@ export(NFinternals) export(OptimControlList) export(OptimResultList) export(SVDDecomp) -export(type2cpp) export(asDense) export(asSparse) export(build_compiled_nClass) @@ -34,15 +33,14 @@ export(createBlockRefInfoIntoC) export(createRef) export(createRefInfoIntoC) export(cube) -export(deregisterOpDef) -export(documentNClass) -export(documentNFunction) export(dcar_normal) export(dcar_proper) export(dcat) export(dconstraint) export(ddexp) export(ddirch) +export(deregisterOpDef) +export(deregisterTypeDeclaration) export(dexp_nimble) export(dinvwish_chol) export(dflat) @@ -55,6 +53,8 @@ export(dmnorm_chol) export(dmnorm_inv_ld) export(dmulti) export(dmvt_chol) +export(documentNClass) +export(documentNFunction) export(dt_nonstandard) export(dwish_chol) export(erasePackage) @@ -143,6 +143,7 @@ export(rconstraint) export(rdexp) export(rdirch) export(registerOpDef) +export(registerTypeDeclaration) export(rexp_nimble) export(rflat) export(rhalfflat) @@ -165,6 +166,8 @@ export(square) export(test_predefined) export(to_full_interface) export(to_generic_interface) +export(type2cpp) +export(type2symbol) export(value) export(writeCode) export(writeCpp_nCompiler) diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index 7c2aebf2..ed4c2045 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -178,10 +178,19 @@ NC_InternalsClass <- R6::R6Class( # 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) + # + # copy inherited overloadDefs and then add or replace with any overloadDefs from this class. + # This should automatically create the hierarchy correctly. + overloadDefs <- parent_nClass_Info$inheritInfo$overloadDefs + new_overloadDefs <- self$compileInfo$overloadDefs + for(mN in names(new_overloadDefs)) { + overloadDefs[[mN]] <- new_overloadDefs[[mN]] + } } else { inheritInfo$allMethodNames <- self$allMethodNames_self inheritInfo$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name inheritInfo$allFieldNames <- self$allFieldNames_self + inheritInfo$overloadDefs <- self$compileInfo$overloadDefs %||% list() symbolTable$setParentST(NULL) } inheritInfo$process_inherit_done <- TRUE diff --git a/nCompiler/R/NC_Utils.R b/nCompiler/R/NC_Utils.R index aa7ab726..2f8a4c13 100644 --- a/nCompiler/R/NC_Utils.R +++ b/nCompiler/R/NC_Utils.R @@ -96,32 +96,37 @@ NCinternals <- function(x) { x } -NC_find_overload <- function(NCgenerator, name, stage, inherits=TRUE) { - if(!isNCgenerator(NCgenerator)) - stop("Input must be a nClass generator.") - current_NCgen <- NCgenerator - done <- FALSE - overload <- NULL - # If there is an overload, it will be at - # overloadDefs[[name]][[stage]]$handler - # e.g. overloadDefs[["[["]][["labelAbstractTypes"]]$handler - while(!done) { - overloadDefs <- NCinternals(current_NCgen)$compileInfo$overloadDefs - if(!is.null(overloadDefs)) { - overload <- overloadDefs[[name]][[stage]] - done <- !is.null(overload) - } - if(!done) { - if(inherits) { - current_NCgen <- current_NCgen$get_inherit() #parent_env$.inherit_obj # same as current_NCgen$get_inherit() if there is inheritance, but get_inherit returns the base class at the top - done <- !isNCgenerator(current_NCgen) - } else - done <- TRUE - } - } - overload +symbol_find_overload <- function(symbol, name, stage, inherits=TRUE) { + overload <- symbol$overloadDefs[[name]][[stage]] + overload # may be NULL } +# NC_find_overload <- function(NCgenerator, name, stage, inherits=TRUE) { +# if(!isNCgenerator(NCgenerator)) +# stop("Input must be a nClass generator.") +# current_NCgen <- NCgenerator +# done <- FALSE +# overload <- NULL +# # If there is an overload, it will be at +# # overloadDefs[[name]][[stage]]$handler +# # e.g. overloadDefs[["[["]][["labelAbstractTypes"]]$handler +# while(!done) { +# overloadDefs <- NCinternals(current_NCgen)$compileInfo$overloadDefs +# if(!is.null(overloadDefs)) { +# overload <- overloadDefs[[name]][[stage]] +# done <- !is.null(overload) +# } +# if(!done) { +# if(inherits) { +# current_NCgen <- current_NCgen$get_inherit() #parent_env$.inherit_obj # same as current_NCgen$get_inherit() if there is inheritance, but get_inherit returns the base class at the top +# done <- !isNCgenerator(current_NCgen) +# } else +# done <- TRUE +# } +# } +# overload +# } + # Utility function to allow searching up an inheritance # ladder to find a method. NC_find_method <- function(NCgenerator, name, inherits=TRUE) { diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index 85853a36..4c20a637 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -79,9 +79,10 @@ compile_eigenize <- function(code, if(isGeneric) { if(length(code$args) > 0) { arg1 <- code$args[[1]] - if(inherits(arg1$type, "symbolNC")) { - handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "eigenImpl", inherits=TRUE) - } + handlingInfo <- symbol_find_overload(arg1$type, code$name, "eigenImpl", inherits=TRUE) + # if(inherits(arg1$type, "symbolNC")) { + # handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "eigenImpl", inherits=TRUE) + # } } } if(is.null(handlingInfo)) diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index 9bdd5b54..2e5381a2 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -101,9 +101,10 @@ compile_generateCpp <- function(code, if(isGeneric) { if(length(code$args) > 0) { arg1 <- code$args[[1]] - if(inherits(arg1$type, "symbolNC")) { - handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "cppOutput", inherits=TRUE) - } + handlingInfo <- symbol_find_overload(arg1$type, code$name, "cppOutput", inherits=TRUE) + # if(inherits(arg1$type, "symbolNC")) { + # handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "cppOutput", inherits=TRUE) + # } handler <- handlingInfo[['handler']] } } @@ -115,22 +116,22 @@ compile_generateCpp <- function(code, # handlingInfo <- opInfo[["cppOutput"]] # if(!is.null(handlingInfo)) { # handler <- handlingInfo$handler - if(!is.null(handler)) { - if (logging) - appendToLog(paste('Calling handler', handler, 'for', code$name)) - if(is.function(handler)) - res <- handler(code, symTab) - else - res <- eval(call(handler, - code, - symTab), - envir = genCppEnv) - if (logging) { - appendToLog(paste('Finished handling', handler, 'for', - code$name, 'with result:')) - appendToLog(res) - } - return(res) + if(!is.null(handler)) { + if (logging) + appendToLog(paste('Calling handler', handler, 'for', code$name)) + if(is.function(handler)) + res <- handler(code, symTab) + else + res <- eval(call(handler, + code, + symTab), + envir = genCppEnv) + if (logging) { + appendToLog(paste('Finished handling', handler, 'for', + code$name, 'with result:')) + appendToLog(res) + } + return(res) } # } # } diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 36d98136..5596e0ab 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -110,12 +110,16 @@ compile_labelAbstractTypes <- function(code, inserts <- labelAbstractTypesEnv$recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo, useArgs = c(TRUE, rep(FALSE, length(code$args)-1))) inserts <- NULL # highlighting that currently these are thrown out -- possibly a problem. - if(inherits(arg1$type, "symbolNC")) { - handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "labelAbstractTypes", inherits=TRUE) - if(!is.null(handlingInfo)) { - handler <- handlingInfo[['handler']] - } + handlingInfo <- symbol_find_overload(arg1$type, code$name, "labelAbstractTypes", inherits=TRUE) + if(!is.null(handlingInfo)) { + handler <- handlingInfo[['handler']] } + # if(inherits(arg1$type, "symbolNC")) { + # handlingInfo <- NC_find_overload(arg1$type$NCgenerator, code$name, "labelAbstractTypes", inherits=TRUE) + # if(!is.null(handlingInfo)) { + # handler <- handlingInfo[['handler']] + # } + # } } } if(is.null(handlingInfo)) { @@ -333,11 +337,14 @@ inLabelAbstractTypesEnv( code, 'left-hand-side of `$new( )` is not an nClass generator (i.e. returned by a call to nClass).' ), call. = FALSE) + NCgen <- code$args[[1]]$type$NCgenerator + NC_info <- register_known_nClass(NCgen, project_env = auxEnv$project_env) returnSym <- symbolNC$new(name = '', type = code$args[[1]]$type$name, isArg = FALSE, - NCgenerator = code$args[[1]]$type$NCgenerator) - newSym <- symbolNF$new(name = NCinternals(code$args[[1]]$type$NCgenerator)$cpp_classname, + overloadDefs = NC_info$inheritInfo$overloadDefs, + NCgenerator = NCgen) + newSym <- symbolNF$new(name = NCinternals(NCgen)$cpp_classname, returnSym = returnSym) code$name <- 'construct_new_nClass' code$type <- newSym @@ -547,7 +554,7 @@ inLabelAbstractTypesEnv( newExpr <- wrapExprClassOperator( code = arg, funName = 'nNumeric', - type = typeDeclarationList$nNumeric() + type = typeDeclarationEnv$nNumeric() ) # set vector length insertArg(expr = newExpr, ID = 2, value = literalIntegerExpr(1)) @@ -1204,7 +1211,7 @@ inLabelAbstractTypesEnv( newExpr <- wrapExprClassOperator( code = arg, funName = 'nNumeric', - type = typeDeclarationList$nNumeric() + type = typeDeclarationEnv$nNumeric() ) # set vector length insertArg(expr = newExpr, ID = 2, value = literalIntegerExpr(1)) @@ -1234,7 +1241,7 @@ inLabelAbstractTypesEnv( newExpr <- wrapExprClassOperator( code = arg, funName = 'nNumeric', - type = typeDeclarationList$nNumeric() + type = typeDeclarationEnv$nNumeric() ) # set vector length insertArg(expr = newExpr, ID = 2, value = literalIntegerExpr(1)) diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index 8566a240..7d32da93 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -7,18 +7,21 @@ symbolBase <- R6::R6Class( isRef = FALSE, isArg = FALSE, interface = TRUE, + overloadDefs = NULL, implementation = NULL, initialize = function(name = NULL, type = character(), isArg = FALSE, isRef = FALSE, interface = TRUE, + overloadDefs = NULL, implementation = NULL) { self$name <- name self$type <- type self$isArg <- isArg self$isRef <- isRef self$interface <- interface + self$overloadDefs <- overloadDefs self$implementation <- implementation }, shortPrint = function() { @@ -279,10 +282,13 @@ symbolTBD <- R6::R6Class( candidate <- self$check_unknown_types(returnID = FALSE, project_env = project_env) if(isNCgenerator(candidate)) { + # if check_unknown_types is updated to return the NC_info, then we can avoid this call to register_known_nClass + NC_info <- register_known_nClass(candidate, project_env = project_env) newSym <- symbolNC$new(name = self$name, - type = NCinternals(candidate)$cpp_classname, # will this work for the type field?? - isArg = self$isArg, - NCgenerator = candidate) + type = NCinternals(candidate)$cpp_classname, # will this work for the type field?? + isArg = self$isArg, + overloadDefs = NC_info$inheritInfo$overloadDefs, + NCgenerator = candidate) return(newSym) } else { stop("In resolveSym method for symbolTBD (", self$name, ", ", self$type, "), could not resolve an nClass generator.") diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index fdefc194..7209914b 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -1,14 +1,13 @@ - ## How creating and passing around types works -## The raw expression information of types is recorded -## in rlang quosures. The idiom for programming with +## The raw expression information of types is recorded +## in rlang quosures. The idiom for programming with ## a type as an input is: ## function(type) { ## ttype <- nCaptureType(type) ## next_res <- foo({{ttype}}) ## } ## This also means that the above function can be -## called with with arguments like "type = numericVector()", +## called with with arguments like "type = numericVector()", ##. type = 'numericVector', or type = {{ type_var }}, ## where type_var was either the result of nCaptureType ## a call like nType(numericVector()) or nType("numericVector") @@ -36,7 +35,7 @@ nTypeSpec <- function(type = NULL) { funName <- deparse(funExpr) args <- typeToUse[-1] |> as.list() } - list(funName = funName, args = args, inputAsCharacter = inputAsCharacter, funExpr = funExpr) |> + list(funName = funName, args = args, inputAsCharacter = inputAsCharacter, funExpr = funExpr) |> structure(class = "nTypeSpec") } @@ -140,7 +139,7 @@ nTypeList <- function(..., .list = NULL, .where = parent.frame()) { ## The next sections of code handle types to symbols ## -## each entry in the typeDeclarationList +## each entry in the typeDeclarationEnv ## gives a function to convert the arguments of a ## type declaration into a symbol object. @@ -175,7 +174,7 @@ nSparseType <- function(scalarType, nDim, isRef = FALSE, ...) { ...) } -typeDeclarationList <- list( +typeDeclarationEnv <- list2env(list( ref = function(internalType) { tIntT <- nCaptureType(internalType) ans <- type2symbol({{tIntT}}, @@ -439,10 +438,10 @@ typeDeclarationList <- list( call. = FALSE) nTypeBasic(scalarType, nDim) }, - ## O(obj) allows a syntax for explicitly saying there is an object + ## O(obj) allows a syntax for explicitly saying there is an object ## to look at for the type. O = function(x) { - typeDeclarationList$typeDeclarationFromObject(x) + typeDeclarationEnv$typeDeclarationFromObject(x) }, CppVar = function(...) { # symbolBaseArgs will be passed to symbolBase$initialize symbolCppVar$new(...) @@ -451,7 +450,7 @@ typeDeclarationList <- list( symbolCppVar$new(baseType = value, ...) }, T = function(symbol) { ## This is semi-defunct but could be resurrected. - # The use of T(mytype) indicates that mytype evaluates to an + # The use of T(mytype) indicates that mytype evaluates to an # existing type object in the evalEnv. # So this is a splice point between base R expression handling # and rlang. @@ -466,7 +465,31 @@ typeDeclarationList <- list( # symbol$clone(deep=TRUE) } ## universal handler for creating symbolBasic objects -) +)) + +userTypeDeclarationEnv <- new.env(parent = typeDeclarationEnv) + +#' @export +#' @importFrom R6 is.R6Class +registerTypeDeclaration <- function(typeName, handler) { + if(R6::is.R6Class(handler)) { + handle_R6gen <- handler + handler <- function(...) { + handler_R6gen$new(...) + } + } + assign(typeName, handler, envir = userTypeDeclarationEnv) +} + +#' @export +deregisterTypeDeclaration <- function(typeName) { + rm(list = typeName, envir = userTypeDeclarationEnv) |> suppressWarnings() +} + +getTypeDeclarationFun <- function(funName) { + userTypeDeclarationEnv[[funName]] %||% + typeDeclarationEnv[[funName]] +} #' @export type2cpp <- function(...) { @@ -476,11 +499,12 @@ type2cpp <- function(...) { quo_strip_quote <- \(qq) { # qq <- q if(identical(rlang::quo_get_expr(qq), rlang::missing_arg())) return(qq) - e <- rlang::quo_get_expr(qq) + e <- rlang::quo_get_expr(qq) e <- if(is.call(e) && deparse1(e[[1]])=="quote") e[[2]] else e rlang::quo_set_expr(qq, e) } +#' @export type2symbol <- function(type, name = character(), origName = "", @@ -496,7 +520,7 @@ type2symbol <- function(type, texplicitType <- nCaptureType(explicitType) ttype <- quo_strip_quote(ttype) texplicitType <- quo_strip_quote(texplicitType) - + if(!is.null(explicitType)) { # typeToUse <- explicitType ttypeToUse <- texplicitType @@ -507,8 +531,8 @@ type2symbol <- function(type, # The idea here was to check if a symbol itself is provided, # but now using rlang quosures, we don't want to assume we - # can evaluate the type argument. - # + # can evaluate the type argument. + # ## First check if what was provided is actually a symbol, and if so return a copy. ## This could be restricted to inherits(typeToUse, "symbolBase") ## but "R6" allows an even wider range of flexibility. @@ -537,7 +561,7 @@ type2symbol <- function(type, ## ## Case 2: It is a valid declaration funName <- typeSpec$funName # deparse(typeToUse[[1]]) - handler <- typeDeclarationList[[funName]] + handler <- getTypeDeclarationFun(funName) if(!is.null(handler)) { symbol <- do.call(handler, typeSpec$args, envir = where) #as.list(typeToUse[-1])) symbol$name <- name @@ -574,7 +598,7 @@ type2symbol <- function(type, # we evaluate the type and see if it (evaluated) is consistent with the explicitType. # It is not clear if this is really a good idea in all cases. # - # Because input could be a quosure already, we need for null based on + # Because input could be a quosure already, we need for null based on # the expression of the quosure, which could be missing_arg or NULL. if(identical(rlang::quo_get_expr(texplicitType), rlang::missing_arg()) || is.null(rlang::quo_get_expr(texplicitType))) @@ -593,7 +617,7 @@ type2symbol <- function(type, else eval(rlang::quo_get_expr(ttype), envir=where) # eval(type, envir = evalEnv) # ttype is a quosure of a default value, since the type spec is in explicitType - checkSymbol <- typeDeclarationList[["typeDeclarationFromObject"]](checkObject) + checkSymbol <- typeDeclarationEnv[["typeDeclarationFromObject"]](checkObject) need_warning <- !identical(symbol$type, checkSymbol$type) ## If dimensions don't match, trigger an error... need_error <- !identical(as.integer(symbol$nDim), @@ -640,7 +664,7 @@ type2symbol <- function(type, else eval(rlang::quo_get_expr(ttype), envir=where) # eval(type, envir = evalEnv) symbol <- - typeDeclarationList[["typeDeclarationFromObject"]](demoObject) + typeDeclarationEnv[["typeDeclarationFromObject"]](demoObject) symbol$name <- name symbol$isArg <- isArg if(isTRUE(isRef) | isTRUE(isBlockRef)) { @@ -888,9 +912,9 @@ 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 <- + nClass_info <- if(!is.null(project_env)) project_env$known_nClasses[[ID]] - else NULL + else NULL if(!is.null(nClass_info)) { NCgen <- nClass_info$NCgenerator } @@ -903,7 +927,7 @@ check_built_types <- function(Rexpr = NULL, candidate = NULL, ##cpp_classname <- NCinternals(NCgen)$cpp_classname ##list(NCgen) |> setNames(cpp_classname) NCgen - } else + } else NULL } diff --git a/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R b/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R new file mode 100644 index 00000000..9ec5b87e --- /dev/null +++ b/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R @@ -0,0 +1,80 @@ +# Test new symbols provided by a user. +# These can include overloadDefs. + +test_that("user type works", { + mySymbol_Bracket_LAT <- function(code, symTab, auxEnv, handlingInfo) { + cat("MSG1\n") + nCompiler:::labelAbstractTypesEnv$recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) + code$type <- nCompiler:::type2symbol("numericScalar") + } + mySymbol_Bracket_EIG <- function(code, symTab, auxEnv, workEnv, handlingInfo) { + cat("MSG2\n") + nCompiler:::eigenizeEnv$eigenCast(code, 2, "integer") + NULL + } + + # This example demonstrates how to create a simple double*. + + mySymbolClass <- R6::R6Class( + classname = "mysymbolclass", + inherit = nCompiler:::symbolBase, + public = list( + initialize = function(...) { + super$initialize(type = 'mySymbolClass', ...) + self$overloadDefs <- list( + "[" = list( + labelAbstractTypes = list( + handler = mySymbol_Bracket_LAT + ), + eigenImpl = list( + handler = mySymbol_Bracket_EIG + ), + cppOutput = list( + handler = nCompiler:::genCppEnv$IndexingBracket + ) + ) + ) + }, + shortPrint = function() "mySymbolClass", + uniqueID = function() "mySymbolClass", + print = function() writeLines(paste0(self$name, ": mySymbolClass")), + genCppVar = function() { + nCompiler:::cppVarFullClass$new(baseType = "double", + name = self$name, + ptr = TRUE, + ref = FALSE) + } + ) + ) + + sym_handler <- function(...) { + mySymbolClass$new() + } + nCompiler:::registerTypeDeclaration("mySym", sym_handler) + on.exit(nCompiler:::deregisterTypeDeclaration("mySym")) + + obj <- nCompiler:::type2symbol("mySym") + expect_true(inherits(obj, "mysymbolclass")) + expect_true(R6::is.R6(obj)) + obj <- nCompiler:::type2symbol("mySym()") + expect_true(inherits(obj, "mysymbolclass")) + expect_true(R6::is.R6(obj)) + + foo <- nFunction( + function(x = 'numericVector') { + nCpp("xptr = &x[0];", type = list(xptr = "mySym")) + x2 <- xptr[2] + 2 + return(x2) + returnType(double()) + } + ) + + output <- capture_output(cfoo <- nCompile(foo)) + expect_true(grepl("MSG1", output)) + expect_true(grepl("MSG2", output)) + expect_equal(cfoo(3:4), 6) + + nCompiler:::deregisterTypeDeclaration("mySym") + obj <- nCompiler:::type2symbol("mySym") + expect_true(inherits(obj, "symbolTBD")) +}) From 3179206f16787197804f130ea600404a87a0acf1 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 21 Jul 2026 19:53:39 -0700 Subject: [PATCH 04/19] fix symbolNC. fix use of scoping for evaluating types given in cppLiteral --- nCompiler/R/compile_labelAbstractTypes.R | 2 +- nCompiler/R/symbolTable.R | 16 ++++++--- .../testthat/nCompile_tests/test-userTypes.R | 33 +++++++++++++++++++ 3 files changed, 46 insertions(+), 5 deletions(-) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 5596e0ab..cdba0cdb 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -1425,7 +1425,7 @@ nCompiler:::inLabelAbstractTypesEnv( if(!is.null(code$aux$compileArgs)) { types <- code$aux$compileArgs$types if(!is.null(types)) { - if(!is.list(types)) types <- eval(types) + if(!is.list(types)) types <- eval(types, envir = auxEnv$closure) newSymTab <- typeList2symbolTable(types, where=auxEnv$closure) resolveTBDsymbols(newSymTab, auxEnv$where, project_env = auxEnv$project_env) symbols <- newSymTab$getSymbols() diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index 7d32da93..e51f23e0 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -356,13 +356,21 @@ symbolNC <- R6::R6Class( type, NCgenerator, isArg, + overloadDefs = NULL, implementation = NULL) { - self$name <- name - self$type <- type + super$initialize(name = name, + type = type, + isArg = isArg, + overloadDefs = overloadDefs, + implementation = implementation) +# self$name <- name +# self$type <- type self$NCgenerator <- NCgenerator - self$isArg <- isArg +# self$overloadDefs <- overloadDefs +# self$isArg <- isArg +# self$overloadDefs <- overloadDefs ## self$isRef <- TRUE - self$implementation <- implementation +# self$implementation <- implementation }, print = function() { writeLines(paste0(self$name, ': symbolNC of type ', self$type)) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R b/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R index 9ec5b87e..02599deb 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-userTypes.R @@ -77,4 +77,37 @@ test_that("user type works", { nCompiler:::deregisterTypeDeclaration("mySym") obj <- nCompiler:::type2symbol("mySym") expect_true(inherits(obj, "symbolTBD")) + + cat("A\n") + + # provide the type as a symbol + foo2 <- nFunction( + function(x = 'numericVector') { + nCpp("xptr = &x[0];", type = list(xptr = mySymbolClass$new())) + x2 <- xptr[2] + 2 + return(x2) + returnType(double()) + } + ) + output <- capture_output(cfoo2 <- nCompile(foo2)) + expect_true(grepl("MSG1", output)) + expect_true(grepl("MSG2", output)) + expect_equal(cfoo2(3:4), 6) + + cat("B\n") + + # provide the type as a symbol in two steps + mySymType <- mySymbolClass$new() + foo3 <- nFunction( + function(x = 'numericVector') { + nCpp("xptr = &x[0];", type = list(xptr = "T(mySymType)")) + x2 <- xptr[2] + 2 + return(x2) + returnType(double()) + } + ) + output <- capture_output(cfoo3 <- nCompile(foo3)) + expect_true(grepl("MSG1", output)) + expect_true(grepl("MSG2", output)) + expect_equal(cfoo3(3:4), 6) }) From 3154fb79405048f55aa256ddab64eabb46b6a801 Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 22 Jul 2026 07:36:56 -0700 Subject: [PATCH 05/19] fix updating of overloadDefs during process_inherit --- nCompiler/R/NC_InternalsClass.R | 1 + nCompiler/R/compile_labelAbstractTypes.R | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index ed4c2045..138ba765 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -186,6 +186,7 @@ NC_InternalsClass <- R6::R6Class( for(mN in names(new_overloadDefs)) { overloadDefs[[mN]] <- new_overloadDefs[[mN]] } + inheritInfo$overloadDefs <- overloadDefs } else { inheritInfo$allMethodNames <- self$allMethodNames_self inheritInfo$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index cdba0cdb..642dcc1c 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -1411,10 +1411,10 @@ inLabelAbstractTypesEnv( # setArg(code, 'drop', drop_arg, add = TRUE) # } - # TODO: double check the assumption that output will always be a - # symbolBasic type as it is understood today. this is handling for the - # subsetting operator, [], but will it always be subsetted to a symbolBasic - # type? + # TODO: double check the assumption that output will always be a + # symbolBasic type as it is understood today. this is handling for the + # subsetting operator, [], but will it always be subsetted to a symbolBasic + # type? code$type <- symbolBasic$new(nDim = nDim, type = obj$type$type) invisible(NULL) } From 984fb3bc159abe8cfbc843452ecdc680e024f20d Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 22 Jul 2026 11:44:22 -0700 Subject: [PATCH 06/19] fix project_env = NULL proxy case in register_known_nClass --- nCompiler/R/nCompile.R | 10 ++++++++++ nCompiler/tests/testthat/specificOp_tests/test-nList.R | 7 +++++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 6ad88c97..9695cbef 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -486,6 +486,16 @@ update_known_nClasses <- function(new_units, new_unitTypes, project_env) { } register_known_nClass <- function(NCgenerator, project_env, classID = NULL) { + # project_env may be NULL when resolving a type outside of an nCompile() call, + # e.g. an nClassBuilder like nList() being called at nClass-definition time. + # In that case we use a scratch project_env so resolution can proceed; it is + # not cached or reused, so it costs one registration/inheritance walk and is + # thrown away (no different from the pre-existing uncached behavior in + # check_built_types() when project_env is NULL). + if(is.null(project_env)) { + project_env <- new.env() + project_env$known_nClasses <- new.env() + } # 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)) { diff --git a/nCompiler/tests/testthat/specificOp_tests/test-nList.R b/nCompiler/tests/testthat/specificOp_tests/test-nList.R index 1c669b80..de4783e9 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-nList.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-nList.R @@ -618,9 +618,12 @@ test_that("limits of T() notation vs {{}} in nested cases", { # then we see that by full use of rlang, with {{}} # to pass expressions with environments, # there is no problem - problem <- quote({ myt3 <- nType(double()) - v7 <- nCompiler:::type2cpp_typename(nList({{myt3}}))}) + problem <- quote({ + myt3 <- nType(double()) + v7 <- nCompiler:::type2cpp_typename(nList({{myt3}})) + }) myenv <- new.env() + eval(problem, envir = myenv) expect_no_error(eval(problem, envir = myenv)) expect_identical(myenv$v7, "std::shared_ptr") }) From 7b7a536e0296c3bc22c06a2892fa04dc460ebab8 Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 22 Jul 2026 17:49:45 -0700 Subject: [PATCH 07/19] add make_scalarNodePtr as a utility for nimble2 --- .../nCompiler/ET_ext/RuntimeFlatView.h | 13 +++++++ .../generic_class_interface_Rcpp_steps.h | 37 +++++++++++++++++++ 2 files changed, 50 insertions(+) diff --git a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h index 8e1933b8..9f7204ee 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h @@ -127,6 +127,19 @@ class RuntimeFlatView { return data_[offset]; } + // Random access by a full multi-index, one 0-based entry per kept + // dimension (indsT any container supporting operator[], e.g. + // std::vector or Eigen::Tensor). Unlike at(flatIndex), this + // is a direct dot-product against info_.strides -- no unflattening. + // No bounds checking; inds must have at least info_.sizes.size() entries. + template + Scalar &at(const IndsT &inds) const { + long offset = info_.baseOffset; + for (size_t k = 0; k < info_.sizes.size(); ++k) + offset += static_cast(inds[k]) * 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 { 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 dbe4b9df..8a4b6750 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 @@ -354,5 +354,42 @@ return Sans; #endif }; +// Pointer to a single element of a named field of obj, addressed by a +// multi-index (one entry per raw dimension of the field, e.g. +// Eigen::Tensor), 0-based unless subtract_ones is set (R callers +// pass 1-based indices; subtract_ones folds the -1 into the same pass that +// already walks inds for bounds-checking, rather than copying/mutating inds +// or teaching RuntimeFlatView about 1-based indexing). +// obj->access(var) is only used to locate the field's data pointer and +// shape; the returned pointer is into the field's own storage and stays +// valid for as long as obj does (the accessor itself is a temporary, not +// the owner of that storage). +template +Scalar* make_scalarNodePtr(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { + auto acc = obj->access(var); + if (!acc) + Rcpp::stop("make_scalarNodePtr: field \"" + var + "\" not found."); + auto view = acc->flatten(); + const RuntimeSubviewInfo &info = view.info(); + const std::vector &sizes = info.sizes; + if (static_cast(inds.size()) != sizes.size()) + Rcpp::stop("make_scalarNodePtr: inds has " + std::to_string(inds.size()) + + " entries but field \"" + var + "\" has " + std::to_string(sizes.size()) + + " dimensions."); + const long origin = subtract_ones ? 1 : 0; + long offset = info.baseOffset; + for (size_t k = 0; k < sizes.size(); ++k) { + const long idx = static_cast(inds[k]) - origin; + if (idx < 0 || idx >= sizes[k]) + Rcpp::stop("make_scalarNodePtr: index " + std::to_string(inds[k]) + + " out of range for dimension " + std::to_string(k) + + " of field \"" + var + "\" (size " + std::to_string(sizes[k]) + ")."); + offset += idx * info.strides[k]; + } + return view.data() + offset; +} #endif // GENERIC_CLASS_INTERFACE_RCPP_STEPS_H_ From c4385e7669f02778001972906eb191032ce1b96b Mon Sep 17 00:00:00 2001 From: perrydv Date: Thu, 23 Jul 2026 09:45:02 -0700 Subject: [PATCH 08/19] Add support for an empty StridedTensorMap that can be rebased to new object, dims and strides --- nCompiler/R/all_utils.R | 5 +- .../nCompiler/ET_ext/StridedTensorMap.h | 51 +++++++- .../generic_class_interface_Rcpp_steps.h | 117 ++++++++++++++++++ .../testthat/cpp/StridedTensorMap_tests.cpp | 53 +++++++- .../cpp_tests/test-StridedTensorMap.R | 16 ++- 5 files changed, 238 insertions(+), 4 deletions(-) diff --git a/nCompiler/R/all_utils.R b/nCompiler/R/all_utils.R index d212e01b..664ed9b1 100644 --- a/nCompiler/R/all_utils.R +++ b/nCompiler/R/all_utils.R @@ -181,7 +181,10 @@ nDim <- function(obj) { is.blank <- function(arg) { if(is.null(arg)) return(FALSE) - return(identical(arg, quote(x[])[[3]])) + # better approach borrowed from rlang::is_missing + return(identical(arg, quote(expr =))) + # old approach + #return(identical(arg, quote(x[])[[3]])) } diff --git a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h index cee0601a..c786e328 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h @@ -186,7 +186,40 @@ namespace Eigen { m_startIndices, m_stopIndices); } - + + // Default constructor: leaves the map empty (m_data == nullptr). Only + // valid use before rebind() is destruction or another rebind()/assignment + // from a fully-constructed StridedTensorMap; element access is guarded by + // eigen_assert below (debug-only, so this costs nothing in release builds). + // Added for StridedTensorMap so a persistent class member can be declared + // once (e.g. before the underlying object/field is known) and bound later + // via rebind(), without needing a wrapper like std::optional. + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap() : m_data(nullptr) {} + + EIGEN_DEVICE_FUNC + EIGEN_STRONG_INLINE bool isEmpty() const { return m_data == nullptr; } // Added for StridedTensorMap + + // Re-seats this map in place to a new data pointer/shape/selection, reusing + // the same setup as the (data, input_sizes, ss) constructor above. Unlike + // operator=, which is an elementwise value-copy through the *existing* + // m_data (matching Eigen's Map/Tensor assignment convention), rebind() + // changes what this map points to -- the only way to (re)point an + // already-constructed (or default-constructed/empty) StridedTensorMap + // somewhere new. Added for StridedTensorMap. + template + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE void rebind(Scalar *data, + const input_sizes_type &input_sizes, + const ss_type &ss) + { + m_data = data; + createSubTensorInfoGeneral(ss, + input_sizes, + m_dimensions, // sizes + m_strides, + m_startIndices, + m_stopIndices); + } + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE Index rank() const { return m_dimensions.rank(); } EIGEN_DEVICE_FUNC @@ -212,6 +245,7 @@ namespace Eigen { EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE const Scalar& operator()(const array& indices) const { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap // StridedTensorMap: TO-DO // eigen_assert(checkIndexRange(indices)); if (PlainObjectType::Options&RowMajor) { @@ -226,6 +260,7 @@ namespace Eigen { EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE const Scalar& operator()() const { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap EIGEN_STATIC_ASSERT(NumIndices == 0, YOU_MADE_A_PROGRAMMING_MISTAKE) return m_data[0]; } @@ -233,6 +268,7 @@ namespace Eigen { EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE const Scalar& operator()(Index index) const { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap eigen_internal_assert(index >= 0 && index < size()); return m_data[m_startIndices[0] + m_strides[0] * index]; // Modified for StridedTensorMap. } @@ -242,6 +278,7 @@ namespace Eigen { template EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE const Scalar& operator()(Index firstIndex, Index secondIndex, IndexTypes... otherIndices) const { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap std::cout<<"in variadic const case"<& indices) { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap // StridedTensorMap: TO-DO // eigen_assert(checkIndexRange(indices)); if (PlainObjectType::Options&RowMajor) { @@ -333,6 +375,7 @@ namespace Eigen { EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE Scalar& operator()() { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap EIGEN_STATIC_ASSERT(NumIndices == 0, YOU_MADE_A_PROGRAMMING_MISTAKE) return m_data[0]; } @@ -340,6 +383,7 @@ namespace Eigen { EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE Scalar& operator()(Index index) { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap eigen_internal_assert(index >= 0 && index < size()); return m_data[m_startIndices[0] + m_strides[0] * index]; // Modified for StridedTensorMap. } @@ -349,6 +393,7 @@ namespace Eigen { template EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE Scalar& operator()(Index firstIndex, Index secondIndex, IndexTypes... otherIndices) { + eigen_assert(m_data != nullptr && "StridedTensorMap: element access on an unbound (empty) map -- call rebind() first."); // Added for StridedTensorMap std::cout<<"in variadic non-const case"< &obj, return view.data() + offset; } +// Shared by make_nodeSTM and rebind_nodeSTM: resolves obj's named field and +// inds selection into the (data pointer, native dims, per-dimension b__ +// blocks) a StridedTensorMap needs, either to construct one (make_nodeSTM) +// or to rebind an existing one in place (rebind_nodeSTM). intDims is a real +// copy (not a reference into the accessor), since acc -- and its own +// intDims() storage -- goes out of scope when this function returns; data +// remains valid regardless, because it points into the field's own storage +// in obj, not into the accessor. +// +// inds is a column-major (nDim x 2) matrix-like container (any type +// supporting operator()(row, col), e.g. Eigen::Tensor), one row per +// raw dimension of the field, giving [start, stop] for that dimension: +// - both columns missing (R's NA or negative) -> whole dimension (kept) +// - only the stop column missing -> single index at start +// (drops this dimension) +// - both given (may be equal) -> range [start, stop] +// (kept; extent is 1 +// when start == stop, +// the dimension is not +// dropped) +// subtract_ones converts from R's 1-based indices (subtracted only from +// non-missing values, after the missing/negative check). +// +// The number of kept (non-dropped) dimensions must equal output_nDim: this +// is checked explicitly before construction, because createSubTensorInfoGeneral +// fills a fixed-size Eigen::array by counting kept +// dimensions as it walks ss, and silently leaves slots uninitialized (rather +// than erroring) if that count doesn't match output_nDim. +template +struct nodeSTM_spec { + Scalar *data; + std::vector intDims; + std::vector ss; +}; + +template +nodeSTM_spec +resolve_nodeSTM_spec(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones) { + auto acc = obj->access(var); + if (!acc) + Rcpp::stop("make_nodeSTM: field \"" + var + "\" not found."); + nodeSTM_spec spec; + spec.data = acc->template S().data(); + spec.intDims = acc->intDims(); // copy: acc (and its intDims() storage) won't outlive this function + const size_t nDim = spec.intDims.size(); + const long origin = subtract_ones ? 1 : 0; + + spec.ss.reserve(nDim); + int nKept = 0; + for (size_t k = 0; k < nDim; ++k) { + const long rawStart = static_cast(inds(k, 0)); + const long rawStop = static_cast(inds(k, 1)); + const bool startMissing = (rawStart == NA_INTEGER || rawStart < 0); + const bool stopMissing = (rawStop == NA_INTEGER || rawStop < 0); + if (startMissing && stopMissing) { + spec.ss.emplace_back(); // whole dimension + ++nKept; + } else if (startMissing) { + Rcpp::stop("make_nodeSTM: start is missing but stop is given, in dimension " + + std::to_string(k) + " of field \"" + var + "\"."); + } else if (stopMissing) { + const long idx = rawStart - origin; + if (idx < 0 || idx >= spec.intDims[k]) + Rcpp::stop("make_nodeSTM: single index " + std::to_string(rawStart) + + " out of range in dimension " + std::to_string(k) + + " of field \"" + var + "\" (size " + std::to_string(spec.intDims[k]) + ")."); + spec.ss.emplace_back(idx); // single index: drops this dimension + } else { + const long start = rawStart - origin; + const long stop = rawStop - origin; + if (start < 0 || stop >= spec.intDims[k] || start > stop) + Rcpp::stop("make_nodeSTM: range [" + std::to_string(rawStart) + ", " + + std::to_string(rawStop) + "] out of range in dimension " + + std::to_string(k) + " of field \"" + var + "\" (size " + + std::to_string(spec.intDims[k]) + ")."); + spec.ss.emplace_back(start, stop); // range, kept even if start == stop + ++nKept; + } + } + if (nKept != output_nDim) + Rcpp::stop("make_nodeSTM: selection keeps " + std::to_string(nKept) + + " dimension(s) but output_nDim is " + std::to_string(output_nDim) + + " for field \"" + var + "\"."); + return spec; +} + +// StridedTensorMap view over a (possibly strided, possibly rank-reducing) +// subview of a named field of obj, with the output rank output_nDim fixed +// at compile time. Sibling to make_scalarNodePtr for the multi-element case. +// See resolve_nodeSTM_spec above for the meaning of inds and subtract_ones. +template +Eigen::StridedTensorMap> +make_nodeSTM(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { + auto spec = resolve_nodeSTM_spec(obj, var, inds, subtract_ones); + return Eigen::StridedTensorMap>(spec.data, spec.intDims, spec.ss); +} + +// Rebinds an existing (persistent) StridedTensorMap member in place, e.g. one +// built once via a default-constructed, empty StridedTensorMap and bound here +// before millions of repeated accesses. See resolve_nodeSTM_spec above for +// the meaning of inds and subtract_ones. +template +void rebind_nodeSTM(Eigen::StridedTensorMap> &target, + const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { + auto spec = resolve_nodeSTM_spec(obj, var, inds, subtract_ones); + target.rebind(spec.data, spec.intDims, spec.ss); +} + #endif // GENERIC_CLASS_INTERFACE_RCPP_STEPS_H_ diff --git a/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp b/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp index 92f38619..ae69543a 100644 --- a/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp +++ b/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp @@ -27,7 +27,7 @@ Eigen::Tensor STM2 ( Eigen::Tensor x ) { typedef Eigen::Tensor TensorType; typedef Eigen::StridedTensorMap< TensorType> StridedTensorMapType; // x[, 2:3, ], input is 6 x 5 x 4 - StridedTensorMapType xMap(x, Eigen::array({b__(0, 5), b__(1, 2), b__(0,3)})); + StridedTensorMapType xMap(x, Eigen::array({b__(0, 5), b__(1, 2), b__(0,3)})); ans = xMap; // arithmetic return(ans); } @@ -99,3 +99,54 @@ Eigen::Tensor STM9 ( Eigen::Tensor x ) { ans = Eigen::MakeStridedTensorMap<2>::make(x, Eigen::MakeIndexBlocks(b__(4), b__(), b__(1, 2))); return(ans); } + +// [[Rcpp::export]] +double STM10 ( Eigen::Tensor x ) { + // Tests the default constructor and rebind(): a default-constructed + // StridedTensorMap starts empty (isEmpty()), and rebind() gives it the + // same data/shape/selection that make_nodeSTM/rebind_nodeSTM pass to it + // (a raw Scalar* plus generic input_sizes/ss containers), as opposed to + // STM1's InputType&-based constructor. Same slice/index as STM1. + Eigen::StridedTensorMap > xMap; + if (!xMap.isEmpty()) + Rcpp::stop("STM10: expected isEmpty() to be true before rebind()"); + std::vector dims = {(int)x.dimension(0), (int)x.dimension(1), (int)x.dimension(2)}; + std::vector ss = {b__(0, 5), b__(1, 2), b__(0, 3)}; + xMap.rebind(x.data(), dims, ss); + if (xMap.isEmpty()) + Rcpp::stop("STM10: expected isEmpty() to be false after rebind()"); + return xMap(1, 1, 2); // x[, 2:3, ][2, 2, 3] in R +} + +// [[Rcpp::export]] +Rcpp::List STM11 ( Eigen::Tensor x, Eigen::Tensor y ) { + // Tests that rebind() can be called again on an already-bound + // StridedTensorMap to re-seat it to a different tensor's storage -- the + // "declare once, rebind at setup" persistent-member pattern rebind_nodeSTM + // is meant to support for repeated access in a hot loop. + Eigen::StridedTensorMap > map; + std::vector ss = {b__(0, 5), b__(1, 1), b__(0, 3)}; + + std::vector dimsX = {(int)x.dimension(0), (int)x.dimension(1), (int)x.dimension(2)}; + map.rebind(x.data(), dimsX, ss); + Eigen::Tensor ansX = map; + + std::vector dimsY = {(int)y.dimension(0), (int)y.dimension(1), (int)y.dimension(2)}; + map.rebind(y.data(), dimsY, ss); + Eigen::Tensor ansY = map; + + return Rcpp::List::create(Rcpp::Named("ansX") = ansX, Rcpp::Named("ansY") = ansY); +} + +// [[Rcpp::export]] +Eigen::Tensor STM12 ( Eigen::Tensor x ) { + // Tests rebind() with a singleton (rank-reducing) selection -- same + // selection as STM6, but built via rebind()'s raw-pointer/std::vector + // path instead of STM6's Eigen::array+InputType constructor path. + Eigen::StridedTensorMap > map; + std::vector dims = {(int)x.dimension(0), (int)x.dimension(1), (int)x.dimension(2)}; + std::vector ss = {b__(1, 4), b__(2), b__(1, 2)}; // x[2:5, 3, 2:3] + map.rebind(x.data(), dims, ss); + Eigen::Tensor ans = map; + return ans; +} diff --git a/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R index a354fbb5..10131d3b 100644 --- a/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R +++ b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R @@ -3,7 +3,7 @@ test_that("basic uses of StridedTensorMap work",{ cppfile <- system.file( file.path('tests', 'testthat', 'cpp', 'StridedTensorMap_tests.cpp'), package = 'nCompiler') - test <- `:::`("nCompiler", "QuietSourceCpp")(cppfile) + test <- nCompiler:::QuietSourceCpp(cppfile) x <- array(1:(6*5*4), dim = c(6, 5, 4)) expect_equal(STM1(x), x[, 2:3, ][2, 2, 3]) expect_equal(STM2(x), x[, 2:3, ]) @@ -14,4 +14,18 @@ test_that("basic uses of StridedTensorMap work",{ expect_equal(STM7(x), x[ 5, 1:3, 2:3 ]) expect_equal(STM8(x), x[5, 1:3, 2]) expect_equal(STM9(x), x[5, , 2:3]) + + ## Tests of being able to create an empty STM and then use rebind() + x <- array(1:(6*5*4), dim = c(6, 5, 4)) + y <- array(101:(100 + 6*5*4), dim = c(6, 5, 4)) + # Default-constructed (empty) map, then rebind() to the raw-pointer path + # used by make_nodeSTM/rebind_nodeSTM; same slice/index as STM1. + expect_equal(STM10(x), x[, 2:3, ][2, 2, 3]) + # rebind() called a second time re-seats the same map object to a + # different tensor's storage, rather than copying values into the old one. + res <- STM11(x, y) + expect_equal(res$ansX, x[, 2:2,,drop=FALSE ]) + expect_equal(res$ansY, y[, 2:2,,drop=FALSE ]) + # rebind() with a singleton (rank-reducing) selection, same result as STM6. + expect_equal(STM12(x), x[2:5, 3, 2:3]) }) From d30d7d8424b18d4dc795717be2c995f57ccf8377 Mon Sep 17 00:00:00 2001 From: perrydv Date: Thu, 23 Jul 2026 14:05:45 -0700 Subject: [PATCH 09/19] update names liek make_scalarNodePtr to more general make_scalarFieldPtr --- .../generic_class_interface_Rcpp_steps.h | 104 +++++++++++------- .../testthat/cpp/StridedTensorMap_tests.cpp | 4 +- .../cpp_tests/test-StridedTensorMap.R | 2 +- 3 files changed, 70 insertions(+), 40 deletions(-) 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 2a9ee604..f74ff628 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 @@ -365,18 +365,18 @@ return Sans; // valid for as long as obj does (the accessor itself is a temporary, not // the owner of that storage). template -Scalar* make_scalarNodePtr(const std::shared_ptr &obj, - const std::string &var, - const IndsT &inds, - bool subtract_ones = false) { +Scalar* make_scalarFieldPtr(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { auto acc = obj->access(var); if (!acc) - Rcpp::stop("make_scalarNodePtr: field \"" + var + "\" not found."); + Rcpp::stop("make_scalarFieldPtr: field \"" + var + "\" not found."); auto view = acc->flatten(); const RuntimeSubviewInfo &info = view.info(); const std::vector &sizes = info.sizes; if (static_cast(inds.size()) != sizes.size()) - Rcpp::stop("make_scalarNodePtr: inds has " + std::to_string(inds.size()) + + Rcpp::stop("make_scalarFieldPtr: inds has " + std::to_string(inds.size()) + " entries but field \"" + var + "\" has " + std::to_string(sizes.size()) + " dimensions."); const long origin = subtract_ones ? 1 : 0; @@ -384,7 +384,7 @@ Scalar* make_scalarNodePtr(const std::shared_ptr &obj, for (size_t k = 0; k < sizes.size(); ++k) { const long idx = static_cast(inds[k]) - origin; if (idx < 0 || idx >= sizes[k]) - Rcpp::stop("make_scalarNodePtr: index " + std::to_string(inds[k]) + + Rcpp::stop("make_scalarFieldPtr: index " + std::to_string(inds[k]) + " out of range for dimension " + std::to_string(k) + " of field \"" + var + "\" (size " + std::to_string(sizes[k]) + ")."); offset += idx * info.strides[k]; @@ -392,10 +392,10 @@ Scalar* make_scalarNodePtr(const std::shared_ptr &obj, return view.data() + offset; } -// Shared by make_nodeSTM and rebind_nodeSTM: resolves obj's named field and +// Shared by make_fieldSTM and rebind_fieldSTM: resolves obj's named field and // inds selection into the (data pointer, native dims, per-dimension b__ -// blocks) a StridedTensorMap needs, either to construct one (make_nodeSTM) -// or to rebind an existing one in place (rebind_nodeSTM). intDims is a real +// blocks) a StridedTensorMap needs, either to construct one (make_fieldSTM) +// or to rebind an existing one in place (rebind_fieldSTM). intDims is a real // copy (not a reference into the accessor), since acc -- and its own // intDims() storage -- goes out of scope when this function returns; data // remains valid regardless, because it points into the field's own storage @@ -421,27 +421,55 @@ Scalar* make_scalarNodePtr(const std::shared_ptr &obj, // dimensions as it walks ss, and silently leaves slots uninitialized (rather // than erroring) if that count doesn't match output_nDim. template -struct nodeSTM_spec { +struct fieldSTM_spec { Scalar *data; std::vector intDims; std::vector ss; }; template -nodeSTM_spec -resolve_nodeSTM_spec(const std::shared_ptr &obj, - const std::string &var, - const IndsT &inds, - bool subtract_ones) { +fieldSTM_spec +resolve_fieldSTM_spec(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones) { auto acc = obj->access(var); if (!acc) - Rcpp::stop("make_nodeSTM: field \"" + var + "\" not found."); - nodeSTM_spec spec; + Rcpp::stop("make_fieldSTM: field \"" + var + "\" not found."); + fieldSTM_spec spec; spec.data = acc->template S().data(); spec.intDims = acc->intDims(); // copy: acc (and its intDims() storage) won't outlive this function const size_t nDim = spec.intDims.size(); const long origin = subtract_ones ? 1 : 0; + // inds is (rows x 2); there's no generic "row count" across arbitrary + // matrix-like containers, so derive it from .size() (already used the same + // way for make_scalarFieldPtr's 1-D inds), checked for an even total first. + if (inds.size() % 2 != 0) + Rcpp::stop("make_fieldSTM: inds must have 2 columns (start, stop) per row; got " + + std::to_string(inds.size()) + " total entries for field \"" + var + "\"."); + const size_t indsRows = static_cast(inds.size()) / 2; + + if (indsRows == 0) { + // No selection given (0 rows): map the whole field. This is the only + // safe way to detect "no inds" when going through this overload -- + // reading inds(k, 0)/inds(k, 1) for a field dimension inds doesn't + // actually have a row for is an out-of-bounds read, not a graceful + // fallback, so this check has to happen before the loop below, not + // inside it. + if (nDim != static_cast(output_nDim)) + Rcpp::stop("make_fieldSTM: field \"" + var + "\" has " + std::to_string(nDim) + + " dimension(s) but output_nDim is " + std::to_string(output_nDim) + + ", and inds was empty (no subview selection given)."); + spec.ss.assign(nDim, b__()); // whole field: every dimension kept, native extent + return spec; + } + + if (indsRows != nDim) + Rcpp::stop("make_fieldSTM: inds has " + std::to_string(indsRows) + + " row(s) but field \"" + var + "\" has " + std::to_string(nDim) + + " dimension(s)."); + spec.ss.reserve(nDim); int nKept = 0; for (size_t k = 0; k < nDim; ++k) { @@ -453,12 +481,12 @@ resolve_nodeSTM_spec(const std::shared_ptr &obj, spec.ss.emplace_back(); // whole dimension ++nKept; } else if (startMissing) { - Rcpp::stop("make_nodeSTM: start is missing but stop is given, in dimension " + + Rcpp::stop("make_fieldSTM: start is missing but stop is given, in dimension " + std::to_string(k) + " of field \"" + var + "\"."); } else if (stopMissing) { const long idx = rawStart - origin; if (idx < 0 || idx >= spec.intDims[k]) - Rcpp::stop("make_nodeSTM: single index " + std::to_string(rawStart) + + Rcpp::stop("make_fieldSTM: single index " + std::to_string(rawStart) + " out of range in dimension " + std::to_string(k) + " of field \"" + var + "\" (size " + std::to_string(spec.intDims[k]) + ")."); spec.ss.emplace_back(idx); // single index: drops this dimension @@ -466,7 +494,7 @@ resolve_nodeSTM_spec(const std::shared_ptr &obj, const long start = rawStart - origin; const long stop = rawStop - origin; if (start < 0 || stop >= spec.intDims[k] || start > stop) - Rcpp::stop("make_nodeSTM: range [" + std::to_string(rawStart) + ", " + + Rcpp::stop("make_fieldSTM: range [" + std::to_string(rawStart) + ", " + std::to_string(rawStop) + "] out of range in dimension " + std::to_string(k) + " of field \"" + var + "\" (size " + std::to_string(spec.intDims[k]) + ")."); @@ -475,7 +503,7 @@ resolve_nodeSTM_spec(const std::shared_ptr &obj, } } if (nKept != output_nDim) - Rcpp::stop("make_nodeSTM: selection keeps " + std::to_string(nKept) + + Rcpp::stop("make_fieldSTM: selection keeps " + std::to_string(nKept) + " dimension(s) but output_nDim is " + std::to_string(output_nDim) + " for field \"" + var + "\"."); return spec; @@ -483,29 +511,31 @@ resolve_nodeSTM_spec(const std::shared_ptr &obj, // StridedTensorMap view over a (possibly strided, possibly rank-reducing) // subview of a named field of obj, with the output rank output_nDim fixed -// at compile time. Sibling to make_scalarNodePtr for the multi-element case. -// See resolve_nodeSTM_spec above for the meaning of inds and subtract_ones. +// at compile time. Sibling to make_scalarFieldPtr for the multi-element case. +// See resolve_fieldSTM_spec above for the meaning of inds and subtract_ones +// (including the 0-row inds case, which maps the whole field). template Eigen::StridedTensorMap> -make_nodeSTM(const std::shared_ptr &obj, - const std::string &var, - const IndsT &inds, - bool subtract_ones = false) { - auto spec = resolve_nodeSTM_spec(obj, var, inds, subtract_ones); +make_fieldSTM(const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { + auto spec = resolve_fieldSTM_spec(obj, var, inds, subtract_ones); return Eigen::StridedTensorMap>(spec.data, spec.intDims, spec.ss); } // Rebinds an existing (persistent) StridedTensorMap member in place, e.g. one // built once via a default-constructed, empty StridedTensorMap and bound here -// before millions of repeated accesses. See resolve_nodeSTM_spec above for -// the meaning of inds and subtract_ones. +// before millions of repeated accesses. See resolve_fieldSTM_spec above for +// the meaning of inds and subtract_ones (including the 0-row inds case, +// which rebinds to the whole field). template -void rebind_nodeSTM(Eigen::StridedTensorMap> &target, - const std::shared_ptr &obj, - const std::string &var, - const IndsT &inds, - bool subtract_ones = false) { - auto spec = resolve_nodeSTM_spec(obj, var, inds, subtract_ones); +void rebind_fieldSTM(Eigen::StridedTensorMap> &target, + const std::shared_ptr &obj, + const std::string &var, + const IndsT &inds, + bool subtract_ones = false) { + auto spec = resolve_fieldSTM_spec(obj, var, inds, subtract_ones); target.rebind(spec.data, spec.intDims, spec.ss); } diff --git a/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp b/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp index ae69543a..d29e8099 100644 --- a/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp +++ b/nCompiler/tests/testthat/cpp/StridedTensorMap_tests.cpp @@ -104,7 +104,7 @@ Eigen::Tensor STM9 ( Eigen::Tensor x ) { double STM10 ( Eigen::Tensor x ) { // Tests the default constructor and rebind(): a default-constructed // StridedTensorMap starts empty (isEmpty()), and rebind() gives it the - // same data/shape/selection that make_nodeSTM/rebind_nodeSTM pass to it + // same data/shape/selection that make_fieldSTM/rebind_fieldSTM pass to it // (a raw Scalar* plus generic input_sizes/ss containers), as opposed to // STM1's InputType&-based constructor. Same slice/index as STM1. Eigen::StridedTensorMap > xMap; @@ -122,7 +122,7 @@ double STM10 ( Eigen::Tensor x ) { Rcpp::List STM11 ( Eigen::Tensor x, Eigen::Tensor y ) { // Tests that rebind() can be called again on an already-bound // StridedTensorMap to re-seat it to a different tensor's storage -- the - // "declare once, rebind at setup" persistent-member pattern rebind_nodeSTM + // "declare once, rebind at setup" persistent-member pattern rebind_fieldSTM // is meant to support for repeated access in a hot loop. Eigen::StridedTensorMap > map; std::vector ss = {b__(0, 5), b__(1, 1), b__(0, 3)}; diff --git a/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R index 10131d3b..7c8f43d4 100644 --- a/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R +++ b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R @@ -19,7 +19,7 @@ test_that("basic uses of StridedTensorMap work",{ x <- array(1:(6*5*4), dim = c(6, 5, 4)) y <- array(101:(100 + 6*5*4), dim = c(6, 5, 4)) # Default-constructed (empty) map, then rebind() to the raw-pointer path - # used by make_nodeSTM/rebind_nodeSTM; same slice/index as STM1. + # used by make_fieldSTM/rebind_fieldSTM; same slice/index as STM1. expect_equal(STM10(x), x[, 2:3, ][2, 2, 3]) # rebind() called a second time re-seats the same map object to a # different tensor's storage, rather than copying values into the old one. From f4c4b4042f1e88660d096975c302dfcb9d6eaabd Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 27 Jul 2026 17:11:50 -0700 Subject: [PATCH 10/19] support for nCpp to work within one line if a types$return element is provided --- nCompiler/R/NF_InternalsClass.R | 2 +- nCompiler/R/compile_labelAbstractTypes.R | 3 ++- nCompiler/R/nCppVec.R | 1 - .../include/nCompiler/predef/nList_/nList_.h | 11 +++++++++++ .../testthat/nCompile_tests/test-cppLiteral.R | 17 ++++++++++++++++- 5 files changed, 30 insertions(+), 4 deletions(-) diff --git a/nCompiler/R/NF_InternalsClass.R b/nCompiler/R/NF_InternalsClass.R index 64a9ac09..731080ba 100644 --- a/nCompiler/R/NF_InternalsClass.R +++ b/nCompiler/R/NF_InternalsClass.R @@ -119,7 +119,7 @@ NF_InternalsClass <- R6::R6Class( ## e.g. 'print' to 'nPrint'; see 'nKeyWords' list in ## changeKeywords.R self$code <- body(fun_to_use) - if(code[[1]] != '{') + if(self$code[[1]] != '{') self$code <- substitute({CODE}, list(CODE=self$code)) ## check all code except.nCompiler package nFunctions ## if(check && "package.nCompiler" %in% search()) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 642dcc1c..786153a8 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -1429,7 +1429,8 @@ nCompiler:::inLabelAbstractTypesEnv( 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) + for (sym in symbols) if(sym$name != "return") symTab$addSymbol(sym) + code$type <- symbols[["return"]] # may be NULL if the code is an entire line } } invisible(NULL) diff --git a/nCompiler/R/nCppVec.R b/nCompiler/R/nCppVec.R index 76789c65..8ffd8cbb 100644 --- a/nCompiler/R/nCppVec.R +++ b/nCompiler/R/nCppVec.R @@ -461,7 +461,6 @@ length.nList <- function(x) { x } -# Draft for a new version of nCppVec. #' @export nList <- function(type, .ID = FALSE, env = parent.frame()) { ttype <- nCaptureType(type) diff --git a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h index e8f82cf1..8f36a66b 100644 --- a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h +++ b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h @@ -1,3 +1,12 @@ +#ifndef NCOMPILER_NLIST__H_ +#define NCOMPILER_NLIST__H_ + +inline std::shared_ptr interface_ptr_2_nList_ptr(std::shared_ptr interface_ptr) { + std::shared_ptr ans = std::dynamic_pointer_cast(interface_ptr); + if(!ans) Rcpp::stop("interface_ptr_2_nList_ptr: interface_ptr is not a nListBase_nClass."); + return ans; +} + template class nList_ : public nListBase_nClass { public: @@ -552,3 +561,5 @@ class nList_ : public nListBase_nClass { auto& operator[](size_t i) { return contents_[i]; } const auto& operator[](size_t i) const { return contents_[i]; } }; + +#endif // NCOMPILER_NLIST__H_ \ No newline at end of file diff --git a/nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R b/nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R index 78acc94f..d72e8677 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R @@ -127,7 +127,7 @@ test_that("nCpp works with evaluation in correct environment", { expect_identical(capture.output(obj$nf())[1], "hw 10") }) -test_that("nCpp works within a line", { +test_that("nCpp works as a type declaration", { make_nf <- function() { nf <- nFunction( fun = function(ivec = nCpp('Eigen::Tensor')) { @@ -140,3 +140,18 @@ test_that("nCpp works within a line", { nfC <- nCompile(nf) expect_identical(nfC(1:3), 1:3) }) + +test_that("nCpp works within a line", { + make_nf <- function() { + nf <- nFunction( + fun = function(ivec = integerVector()) { + x <- nCpp("(ivec + int(1))", types = list(return = 'integerVector')) + 2L + return(x) + returnType('integerVector') + } + ) + } + nf <- make_nf() + nfC <- nCompile(nf) + expect_equal(nfC(1:3), (1:3)+3) +}) From a4ebf3d2a3e770d594c299116bea21e1633b0482 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 4 Aug 2026 10:20:43 -0700 Subject: [PATCH 11/19] Support RcppObject type. Update nGet for known_nClasses. Support nList inline new. --- nCompiler/R/NF_ProcessCompilerStages.R | 6 +-- nCompiler/R/NF_Utils.R | 8 +++- nCompiler/R/symbolTable.R | 3 +- nCompiler/R/typeDeclarations.R | 16 ++++--- .../testthat/specificOp_tests/test-nList.R | 23 ++++++++++ .../testthat/types_tests/test-RcppTypes.R | 45 +++++++++++++++++++ 6 files changed, 88 insertions(+), 13 deletions(-) diff --git a/nCompiler/R/NF_ProcessCompilerStages.R b/nCompiler/R/NF_ProcessCompilerStages.R index 7c3ddeaf..664adc58 100644 --- a/nCompiler/R/NF_ProcessCompilerStages.R +++ b/nCompiler/R/NF_ProcessCompilerStages.R @@ -110,9 +110,9 @@ compilerStage_initializeAuxEnv <- function(NFcompiler, class_env = new.env(), project_env = new.env(), debug = FALSE) { - if(!exists("built_types", envir = project_env)) { - project_env$built_types <- list() - } + #if(!exists("built_types", envir = project_env)) { + # project_env$built_types <- list() + #} nameSubList <- NFcompiler$nameSubList NFcompiler$auxEnv[['uses_nCppVec']] <- FALSE NFcompiler$auxEnv[['needed_nFunctions']] <- list() diff --git a/nCompiler/R/NF_Utils.R b/nCompiler/R/NF_Utils.R index ac3d0ca5..9f6cd3d6 100644 --- a/nCompiler/R/NF_Utils.R +++ b/nCompiler/R/NF_Utils.R @@ -44,8 +44,12 @@ isConstructor <- function(NF) { ## If the name is not found, NULL is returned. nGet <- function(name, where, project_env = NULL) { if(!is.null(project_env)) { - obj <- project_env$built_types[[name]] - if(!is.null(obj)) return(obj) + obj <- project_env$known_nClasses[[name]] + if(!is.null(obj)) { + obj <- obj$NCgenerator + if(!is.null(obj)) + return(obj) + } } if(inherits(where, "R6ClassGenerator")) { if(exists(name, envir = where, inherits = FALSE)) diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index e51f23e0..539b3dbd 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -545,7 +545,7 @@ symbolRcppType<- R6::R6Class( self$type }, uniqueID = function() { - stop("uniqueID() is not yet implemented for symbolRcppType.") + paste0("RcppType_", self$type) }, print = function() { writeLines( @@ -558,7 +558,6 @@ symbolRcppType<- R6::R6Class( ) ) - symbolRcppNumericVector <- R6::R6Class( classname = "symbolRcppNumericVector", inherit = symbolBase, diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 7209914b..151ead8c 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -317,6 +317,9 @@ typeDeclarationEnv <- list2env(list( symbolCppVar$new(baseType = "SEXP", ...) }, ## Rcpp types + RcppObject = function(...) { + symbolRcppType$new(RcppType = "Rcpp::RObject", ...) + }, RcppEnvironment = function(...) { symbolRcppType$new(RcppType = "Rcpp::Environment", ...) }, @@ -897,12 +900,13 @@ check_built_types <- function(Rexpr = NULL, candidate = NULL, } ttype <- nType(expr = Rexpr, env = where) typeSpec <- nTypeSpec(ttype) - 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(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 + } } } diff --git a/nCompiler/tests/testthat/specificOp_tests/test-nList.R b/nCompiler/tests/testthat/specificOp_tests/test-nList.R index de4783e9..729f7bc6 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-nList.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-nList.R @@ -1261,3 +1261,26 @@ test_that("nList ETaccess at C++ level works", { expect_equal(obj$check3(), 3) expect_error(obj$check4()) }) + +test_that("nList new operation works inline", { + foo <- nFunction( + function() { + x <- nList(integerVector())$new() + return(x) + returnType(nList(integerVector())) + } + ) + + cfoo <- nCompile(foo) + res <- cfoo() + expect_true(inherits(res, "nList")) + length(res) <- 3 + expect_equal(length(res), 3) + expect_true(res$isCompiled()) + + res <- foo() + expect_true(inherits(res, "nList")) + length(res) <- 3 + expect_equal(length(res), 3) + expect_false(res$isCompiled()) +}) diff --git a/nCompiler/tests/testthat/types_tests/test-RcppTypes.R b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R index f29ae9f5..fe7f5019 100644 --- a/nCompiler/tests/testthat/types_tests/test-RcppTypes.R +++ b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R @@ -732,3 +732,48 @@ test_that("RcppEnvironment works in nClasses", { expect_equal(myEnv$x, 11:13) rm(my_nc); gc() }) + +test_that("RcppList works in nClasses", { + nc <- nClass( + classname = "test_RcppList", + Cpublic = list( + x = "RcppList", + set_x = nFunction( + fun = function(myList = "RcppList", new_x = "RcppNumericVector") { + x <- myList + nCpp('x["x"] = new_x;') + return(x) + }, + returnType = "RcppList()" + ) + ) + ) + ncC <- nCompile(nc) + my_nc <- ncC$new() + myList <- list(A = 1:3, B = 2:4) + my_nc$set_x(myList, 11:13) + expect_equal(my_nc$x, c(myList, list(x = 11:13))) + rm(my_nc); gc() +}) + +test_that("RcppObject works in nClasses", { + nc <- nClass( + classname = "test_RcppObject", + Cpublic = list( + x = "RcppObject", + set_x = nFunction( + fun = function(myObj = "RcppObject") { + x <- myObj + return(x) + }, + returnType = "RcppObject()" + ) + ) + ) + ncC <- nCompile(nc) + my_nc <- ncC$new() + myList <- list(A = 1:3, B = 2:4) + my_nc$set_x(myList) + expect_equal(my_nc$x, myList) + rm(my_nc); gc() +}) From ece532067691ac70156f4d806e817fe42c6723ef Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 5 Aug 2026 14:10:31 -0700 Subject: [PATCH 12/19] Support `nClass(myclass(), interface = "generic")` type declaration and consolidate process_inherit steps --- nCompiler/R/NC_InternalsClass.R | 146 +++++++++++++++--- nCompiler/R/NC_LoadedObjectEnv.R | 10 +- nCompiler/R/NC_Utils.R | 9 +- nCompiler/R/cppDefs_core.R | 117 +++++--------- nCompiler/R/symbolTable.R | 34 ++-- nCompiler/R/typeDeclarations.R | 13 +- .../nCompiler/nC_inter/loadedObjectsHook.h | 44 ------ .../generic_class_interface_Rcpp_steps.h | 28 ++++ .../post_Rcpp/loadedObjectHookC_impl.h | 6 + .../post_Rcpp/shared_ptr_as_wrap.h | 27 +++- .../shared_ptr_as_wrap_forward_declarations.h | 31 ++++ 11 files changed, 301 insertions(+), 164 deletions(-) diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index 138ba765..a24cbe45 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -5,16 +5,15 @@ NC_InternalsClass <- R6::R6Class( public = list( symbolTable = NULL, cppSymbolNames = NULL, - methodNames = character(), + methodNames = character(), # this class's own methods, not including inherited ones #allMethodNames = character(), # including inherited methods - allMethodNames_self = character(), # not including inherited methods - fieldNames = character(), + fieldNames = character(), # this class's own fields, not including inherited ones #allFieldNames = character(), # including inherited methods - allFieldNames_self = character(), # not including inherited methods classname = character(), cpp_classname = character(), #all_methodName_to_cpp_code_name = list(), orig_methodName_to_cpp_code_name = list(), + orig_methodInfo = list(), compileInfo = list(), inherit_base_provided = FALSE, # compileInfo will include interface ("full", "generic", or "none"), @@ -29,8 +28,7 @@ NC_InternalsClass <- R6::R6Class( env = NULL, inheritQ = NULL, # quoted inherit expression, to defer access to the inherited nClass generator itself. # process_inherit_done = FALSE, - virtualMethodNames_self = character(), # will be used when checking inherited method validity, only for locally implemented methods - # virtualMethodNames = character(), + virtualMethodNames = character(), # this class's own virtual methods, not including inherited ones; will be used when checking inherited method validity #check_inherit_done = FALSE, classID = NULL, #Cpub_class_code = NULL, @@ -71,7 +69,6 @@ NC_InternalsClass <- R6::R6Class( } } has_Cpublic_init <- "initialize" %in% names(Cpublic) - #self$virtualMethodNames <- names(Cpublic)[isVirtual] self$symbolTable <- typeList2symbolTable(Cpublic[!isMethod], where = env) self$cppSymbolNames <- Rname2CppName(symbolTable$getSymbolNames()) self$methodNames <- names(Cpublic)[isMethod] @@ -81,24 +78,44 @@ NC_InternalsClass <- R6::R6Class( call. = FALSE) } } - self$allMethodNames_self <- methodNames - self$virtualMethodNames_self <- names(Cpublic)[isVirtual] + self$virtualMethodNames <- names(Cpublic)[isVirtual] #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$orig_methodName_to_cpp_code_name <- structure(vector("list", length=length(methodNames)), names = methodNames) + # orig_methodInfo carries the raw, per-own-method ingredients + # addGenericInterface_impl (cppDefs_core.R) needs to emit a method(...) line -- + # owning C++ class, argument names/passing-mode flags, and the destructor/ + # constructor/callFromR flags -- as plain data, not assembled C++ text and not + # yet folded with interfaceInclude/interfaceExclude (that decision needs + # self$compileInfo, but is deferred to process_inherit, which computes it in + # one place shared with fields). Built here, not in process_inherit, only + # because it needs the actual method objects (Cpublic), which process_inherit + # doesn't receive -- only initialize does. The actual C++ identifier for a method + # (needed for override/virtual-dispatch consistency with the base class) comes + # from all_methodName_to_cpp_code_name, not from anything stored here. + self$orig_methodInfo <- structure(vector("list", length=length(methodNames)), + names = methodNames) for(mN in methodNames) { - self$orig_methodName_to_cpp_code_name[[mN]] <- NFinternals(Cpublic[[mN]])$cpp_code_name + NFint <- NFinternals(Cpublic[[mN]]) + NFcompInfo <- NFint$compileInfo + self$orig_methodName_to_cpp_code_name[[mN]] <- NFint$cpp_code_name + self$orig_methodInfo[[mN]] <- list(argNames = NFint$argSymTab$getSymbolNames(), # we do not want cpp names here. + refArgs = NFint$refArgs, + blockRefArgs = NFint$blockRefArgs, + ownerClassName = self$cpp_classname, + destructor = isTRUE(NFcompInfo$destructor), + constructor = isTRUE(NFcompInfo$constructor), + callFromR = isTRUE(NFcompInfo$callFromR)) } # 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$allMethodNames <- self$methodNames. # 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 + # self$allFieldNames <- self$fieldNames. # 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)) @@ -153,6 +170,80 @@ NC_InternalsClass <- R6::R6Class( # and require recursion up the inheritance tree, using flags. # TO-DO: Error trap in methods of same name but different argument signatures. if(isTRUE(inheritInfo$process_inherit_done)) return() + # allFieldInfo carries everything addGenericInterface_impl (cppDefs_core.R) + # needs to emit a field(...) line for each field, flattened across the whole + # inheritance chain: which C++ class it belongs to, its cpp-mangled name, its + # final generic-interface inclusion decision, and its (symbol-owned, already + # C++-ready) interfaceAux text. Building it here -- rather than in + # addGenericInterface_impl, which would otherwise have to walk ancestors via + # raw/unresolved NCinternals -- means callers get one complete, already-merged, + # already-deduplicated (self's own field wins on a name collision, mirroring + # allMethodNames/all_methodName_to_cpp_code_name below) map, and + # addGenericInterface_impl never needs to know how a field's inclusion was + # decided or what kind of aux content a symbol contributes. + # + # The inclusion decision folds in both the field's own (already TBD-resolved, + # via the symbolTable passed in here) interface flag and this class's + # interfaceInclude/interfaceExclude override -- previously computed in + # addGenericInterface_impl per ancestor level, now computed here per class + # since self$compileInfo is exactly the level whose override should govern + # its own fields, same as before. + # self$compileInfo's interfaceInclude/interfaceExclude governs both fields and + # methods identically, so both inclusion decisions below fold in the same + # useIM/use_include/interfaceInclude/interfaceExclude. + interfaceInclude <- self$compileInfo$interfaceInclude + interfaceExclude <- self$compileInfo$interfaceExclude + useIM <- !is.null(interfaceInclude) || !is.null(interfaceExclude) + if(useIM && !is.null(interfaceInclude) && !is.null(interfaceExclude)) { + stop("interfaceExclude and interfaceInclude cannot both be non-null. Something is wrong.") + } + use_include <- useIM && !is.null(interfaceInclude) + # Needs to be built here because it relies on resolved symbols. cppName is + # looked up from cppSymbolNames (already computed in initialize) rather than + # recomputing Rname2CppName(nm) here -- keyed by name (via symbolTable's own + # names), not by position, since fieldNames can be a strict subset of + # symbolTable's names (the has_Cpublic_init/"initialize" case in initialize + # adjusts fieldNames but not symbolTable/cppSymbolNames). + cppNameLookup <- setNames(self$cppSymbolNames, symbolTable$getSymbolNames()) + self_fieldInfo_all <- structure( + lapply(self$fieldNames, \(nm) { + sym <- symbolTable$getSymbol(nm) + included <- if(useIM) { + if(use_include) nm %in% interfaceInclude + else isTRUE(sym$interface) && !(nm %in% interfaceExclude) + } else { + isTRUE(sym$interface) + } + list(cppName = cppNameLookup[[nm]], + ownerClassName = self$cpp_classname, + interface = included, + interfaceAux = sym$interfaceAux) + }), + names = self$fieldNames) + # Folds the interfaceInclude/interfaceExclude decision into the raw per-method + # data built in initialize (destructor/constructor always excluded; otherwise + # interfaceInclude/interfaceExclude if set, else the method's own callFromR + # flag) -- the plain-data ingredients (argNames/refArgs/blockRefArgs) pass + # through unchanged; addGenericInterface_impl (cppDefs_core.R) is responsible + # for assembling them into actual args({...}) C++ text, since that's the C++ + # code generation stage. + self_methodInfo_all <- structure( + lapply(self$methodNames, \(mN) { + raw <- self$orig_methodInfo[[mN]] + included <- !raw$destructor && !raw$constructor && + (if(useIM) { + if(use_include) (mN %in% interfaceInclude) + else !(mN %in% interfaceExclude) + } else { + raw$callFromR + }) + list(argNames = raw$argNames, + refArgs = raw$refArgs, + blockRefArgs = raw$blockRefArgs, + ownerClassName = raw$ownerClassName, + interface = included) + }), + names = self$methodNames) 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)) @@ -168,16 +259,27 @@ NC_InternalsClass <- R6::R6Class( # } #self$inheritNCinternals$process_inherit() #self$symbolTable$setParentST(self$inheritNCinternals$symbolTable) - newMethodNames <- setdiff(self$allMethodNames_self, + newMethodNames <- setdiff(self$methodNames, 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) + # allMethodInfo/allFieldInfo are the opposite precedence from + # all_methodName_to_cpp_code_name above: self's own record wins on a name + # collision (ownerClassName/argNames/refArgs/blockRefArgs/cppName/interfaceAux + # come from wherever the name is most-derived), matching the old per-level walk + # in addGenericInterface_impl, which started at the derived class and skipped a + # name only once already output -- i.e. the derived declaration's own info was + # captured first. Only all_methodName_to_cpp_code_name is intentionally + # base-wins, since virtual dispatch requires the override to share the base's + # C++ identifier; that's unrelated to which class's info populates these maps. + inheritInfo$allMethodInfo <- c(self_methodInfo_all, + parent_nClass_Info$inheritInfo$allMethodInfo[ + setdiff(names(parent_nClass_Info$inheritInfo$allMethodInfo), self$methodNames)]) + inheritInfo$allFieldNames <- c(self$fieldNames, parent_nClass_Info$inheritInfo$allFieldNames) + inheritInfo$allFieldInfo <- c(self_fieldInfo_all, + parent_nClass_Info$inheritInfo$allFieldInfo[ + setdiff(names(parent_nClass_Info$inheritInfo$allFieldInfo), self$fieldNames)]) # # copy inherited overloadDefs and then add or replace with any overloadDefs from this class. # This should automatically create the hierarchy correctly. @@ -188,9 +290,11 @@ NC_InternalsClass <- R6::R6Class( } inheritInfo$overloadDefs <- overloadDefs } else { - inheritInfo$allMethodNames <- self$allMethodNames_self + inheritInfo$allMethodNames <- self$methodNames inheritInfo$all_methodName_to_cpp_code_name <- self$orig_methodName_to_cpp_code_name - inheritInfo$allFieldNames <- self$allFieldNames_self + inheritInfo$allMethodInfo <- self_methodInfo_all + inheritInfo$allFieldNames <- self$fieldNames + inheritInfo$allFieldInfo <- self_fieldInfo_all inheritInfo$overloadDefs <- self$compileInfo$overloadDefs %||% list() symbolTable$setParentST(NULL) } diff --git a/nCompiler/R/NC_LoadedObjectEnv.R b/nCompiler/R/NC_LoadedObjectEnv.R index 91eb51cb..0406ce9c 100644 --- a/nCompiler/R/NC_LoadedObjectEnv.R +++ b/nCompiler/R/NC_LoadedObjectEnv.R @@ -45,14 +45,18 @@ to_generic_interface <- function(obj) { } #' @export -new.loadedObjectEnv_full <- function(extptr = NULL, parentEnv = NULL) { +new.loadedObjectEnv_full <- function(extptr = NULL, parentEnv = NULL, is_full = NULL) { # This will be true if called from an nFunction (or nClass method) returning an object + # When is_full is NULL, we follow the default for the class (return_mode below) + # When is_full is provided, we over-ride the default. ans <- new.loadedObjectEnv(extptr, parentEnv) if(!is.null(parentEnv)) { # This doesn't really do anything - if(exists('.R6interface', parentEnv) && - parentEnv$return_mode == "full") { + if(exists('.R6interface', parentEnv)) { + is_full <- is_full %||% (parentEnv$return_mode == "full") + if(is_full) { fullAns <- parentEnv$.R6interface$new(CppObj = ans) return(fullAns) + } } } ans diff --git a/nCompiler/R/NC_Utils.R b/nCompiler/R/NC_Utils.R index 2f8a4c13..deb1ebc9 100644 --- a/nCompiler/R/NC_Utils.R +++ b/nCompiler/R/NC_Utils.R @@ -174,7 +174,7 @@ NC_check_inheritance <- function(NCgenerator, inheritInfo, project_env) { if(is.null(NCint$inheritQ)) { inheritInfo$check_inherit_done <- TRUE - inheritInfo$virtualMethodNames <- NCint$virtualMethodNames_self + inheritInfo$virtualMethodNames <- NCint$virtualMethodNames return(inheritInfo$virtualMethodNames) } if(inheritInfo$check_inherit_done) return(inheritInfo$virtualMethodNames) @@ -191,12 +191,11 @@ NC_check_inheritance <- function(NCgenerator, inheritInfo, project_env) { new_virtualMethodNames <- character() if(!allow_method_overloading) { - local_virtualMethodNames <- NCint$virtualMethodNames_self # default: check for disallowed method overloading 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% NCint$methodNames)) next 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) @@ -230,9 +229,9 @@ NC_check_inheritance <- function(NCgenerator, inheritInfo, project_env) { # # If any of my own field names already existed from my inherited classes, # that's not allowed - badFields <- NCint$allFieldNames_self %in% parent_nClass_Info$inheritInfo$allFieldNames + badFields <- NCint$fieldNames %in% parent_nClass_Info$inheritInfo$allFieldNames if(any(badFields)) - stop(paste0("Problem with field(s): ", paste(NCint$allFieldNames_self[badFields], collapse = ", "), + stop(paste0("Problem with field(s): ", paste(NCint$fieldNames[badFields], collapse = ", "), ". Fields with the same name are not allowed in base and inherited classes.", " (If you want to allow local fields of the same name in C++ by turning off this requirement,", " set nOptions(allow_inherited_field_duplicates=TRUE)"), diff --git a/nCompiler/R/cppDefs_core.R b/nCompiler/R/cppDefs_core.R index b172382c..1d62d11f 100644 --- a/nCompiler/R/cppDefs_core.R +++ b/nCompiler/R/cppDefs_core.R @@ -332,88 +332,50 @@ addGenericInterface_impl <- function(self) { outputMethodClassNames <- character() outputMethodNames <- character() outputCppMethodNames <- character() - iOut <- 1 fieldClassNames <- character() fieldNames <- character() + fieldAux <- character() cpp_fieldNames <- character() - done <- FALSE - current_NCgen <- self$Compiler$NCgenerator - my_NCgen <- current_NCgen - while(!done) { - NCint <- NCinternals(current_NCgen) - NCcompInfo <- NCint$compileInfo - interfaceInclude <- NCcompInfo$interfaceInclude - interfaceExclude <- NCcompInfo$interfaceExclude - useIM <- !is.null(interfaceInclude) || !is.null(interfaceExclude) - if(useIM) { - if(!is.null(interfaceExclude) && !is.null(interfaceInclude)) { - stop("interfaceExclude and interfaceInclude cannot both be non-null. Something is wrong.") - } - use_include <- !is.null(interfaceInclude) - } - methodNames <- NCint$methodNames - for(mName in methodNames) { - if(mName %in% outputMethodNames) next - if(useIM) { - if(use_include && !(mName %in% interfaceInclude)) next - if(!use_include && (mName %in% interfaceExclude)) next - } - NFint <- NFinternals(NC_get_Cpub_class(current_NCgen)$public_methods[[mName]]) - NFcompInfo <- NFint$compileInfo - if(!useIM && !isTRUE(NFcompInfo$callFromR)) next - if(isTRUE(NFcompInfo$destructor)) next - if(isTRUE(NFcompInfo$constructor)) next - argNames <- NFint$argSymTab$getSymbolNames() # we do not want cpp names here. - refArgs <- NFint$refArgs - blockRefArgs <- NFint$blockRefArgs - if(length(argNames)) { - passingTypes <- - ifelse(refArgs[argNames] |> lapply(isTRUE) |> unlist(), "ref", - ifelse(blockRefArgs[argNames] |> lapply(isTRUE) |> unlist(), - "refBlock", "copy")) - step1 <- paste0('\"',argNames,'\"') - step2 <- paste(step1, passingTypes, sep=',') - step3 <- paste0('{arg(', step2, ')}', collapse = ',') - } else { - step3 <- '{}' - } - step4 <- paste0('args({', step3, '})') - cppArgInfos[iOut] <- step4 - outputMethodNames[iOut] <- mName - # This line should give the same result as the next line. - # outputCppMethodNames[iOut] <- NFint$cpp_code_name - 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 + # Neither loop below walks the inheritance tree or touches raw NCinternals: both + # allMethodInfo and allFieldInfo (built once, in NC_InternalsClass$initialize / + # process_inherit) are already complete, flattened, deduplicated (self's own + # declaration wins on a name collision) maps across the whole hierarchy, in + # derived-to-base order, with the final generic-interface inclusion decision + # (folding in each item's own interface flag/callFromR/destructor/constructor + # status and its declaring class's interfaceInclude/interfaceExclude) already + # resolved. + for(mName in names(self$Compiler$inheritInfo$allMethodInfo)) { + info <- self$Compiler$inheritInfo$allMethodInfo[[mName]] + if(!isTRUE(info$interface)) next + outputMethodNames <- c(outputMethodNames, mName) + outputCppMethodNames <- c(outputCppMethodNames, self$Compiler$inheritInfo$all_methodName_to_cpp_code_name[[mName]]) + outputMethodClassNames <- c(outputMethodClassNames, info$ownerClassName) + # Assembling the args({...}) C++ text from the plain-data ingredients + # (argNames/refArgs/blockRefArgs) happens here, not in NC_InternalsClass, since + # this is the C++ code generation stage. + argNames <- info$argNames + if(length(argNames)) { + passingTypes <- + ifelse(info$refArgs[argNames] |> lapply(isTRUE) |> unlist(), "ref", + ifelse(info$blockRefArgs[argNames] |> lapply(isTRUE) |> unlist(), + "refBlock", "copy")) + step1 <- paste0('\"',argNames,'\"') + step2 <- paste(step1, passingTypes, sep=',') + step3 <- paste0('{arg(', step2, ')}', collapse = ',') + } else { + step3 <- '{}' } - # I am belaboring what could be done with unique or setdiff to be more - # sure that order is preserved aligning fieldNames and cpp_fieldNames - new_fieldNames <- NCint$symbolTable$getSymbolNames() - if(!useIM || !use_include) - do_interface <- NCint$symbolTable$getSymbols() |> - lapply(\(x) isTRUE(x$interface)) |> unlist() - if(useIM) { - if(use_include) { - do_interface <- (new_fieldNames %in% interfaceInclude) - } else { - do_interface <- do_interface & !(new_fieldNames %in% interfaceExclude) - } - } - new_fieldNames <- new_fieldNames[do_interface] - new_fieldNames <- new_fieldNames[!(new_fieldNames %in% fieldNames)] - fieldNames <- c(fieldNames, new_fieldNames) - new_cpp_fieldNames <- NCint$cppSymbolNames - new_cpp_fieldNames <- new_cpp_fieldNames[do_interface] - new_cpp_fieldNames <- new_cpp_fieldNames[!(new_cpp_fieldNames %in% cpp_fieldNames)] - cpp_fieldNames <- c(cpp_fieldNames, new_cpp_fieldNames) - fieldClassNames <- c(fieldClassNames, - rep(NCint$cpp_classname, length(new_cpp_fieldNames))) - # - current_NCgen <- current_NCgen$get_inherit() #$parent_env$.inherit_obj # same as current_NCgen$get_inherit() if there is inheritance, but get_inherit returns the base class at the top - done <- !isNCgenerator(current_NCgen) + cppArgInfos <- c(cppArgInfos, paste0('args({', step3, '})')) + } + for(nm in names(self$Compiler$inheritInfo$allFieldInfo)) { + info <- self$Compiler$inheritInfo$allFieldInfo[[nm]] + if(!isTRUE(info$interface)) next + fieldNames <- c(fieldNames, nm) + cpp_fieldNames <- c(cpp_fieldNames, info$cppName) + fieldClassNames <- c(fieldClassNames, info$ownerClassName) + fieldAux <- c(fieldAux, if(!is.null(info$interfaceAux)) paste0(", ", info$interfaceAux) else "") } - if(iOut > 1) { + if(length(outputMethodNames) > 0) { methodsContent <- paste0("method(\"", outputMethodNames, "\", &", @@ -434,6 +396,7 @@ addGenericInterface_impl <- function(self) { fieldClassNames, "::", cpp_fieldNames, + fieldAux, ")", collapse = ",\n") fieldsContent <- paste0("NCOMPILER_FIELDS(\n", fieldsContent, "\n)") } else diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index 539b3dbd..5535f41e 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -288,7 +288,8 @@ symbolTBD <- R6::R6Class( type = NCinternals(candidate)$cpp_classname, # will this work for the type field?? isArg = self$isArg, overloadDefs = NC_info$inheritInfo$overloadDefs, - NCgenerator = candidate) + NCgenerator = candidate, + interface = self$interface) return(newSym) } else { stop("In resolveSym method for symbolTBD (", self$name, ", ", self$type, "), could not resolve an nClass generator.") @@ -352,10 +353,12 @@ symbolNC <- R6::R6Class( portable = TRUE, public = list( NCgenerator = NULL, + interfaceAux = NULL, initialize = function(name, type, NCgenerator, isArg, + interface, overloadDefs = NULL, implementation = NULL) { super$initialize(name = name, @@ -363,14 +366,26 @@ symbolNC <- R6::R6Class( isArg = isArg, overloadDefs = overloadDefs, implementation = implementation) -# self$name <- name -# self$type <- type self$NCgenerator <- NCgenerator -# self$overloadDefs <- overloadDefs -# self$isArg <- isArg -# self$overloadDefs <- overloadDefs -## self$isRef <- TRUE -# self$implementation <- implementation + # interface may be TRUE or FALSE or + # "full", "generic", or "none" + if(!missing(interface)) { + if(is.logical(interface)) { + self$interface <- interface + } + if(is.character(interface)) { + self$interface <- interface != "none" + # The symbol owns its own C++ representation (cf. genCppVar()), so + # the nCwrapMode(...) text is built here, not by addGenericInterface_impl. + # That keeps addGenericInterface_impl (and NC_InternalsClass$process_inherit, + # which just flattens this across inheritance) generic: it only ever + # does a null-check and string concat, with no knowledge of what kind + # of aux content a symbol type produces. + if(self$interface) + self$interfaceAux <- paste0("nCwrapMode(", + if(interface == "full") "true" else "false", ")") + } + } }, print = function() { writeLines(paste0(self$name, ': symbolNC of type ', self$type)) @@ -400,7 +415,8 @@ symbolSelf <- R6::R6Class( super$initialize(name = name, type = type, NCgenerator = NCgenerator, - isArg = isArg) + isArg = isArg, + interface = FALSE) }, # Note that the genCppOutput handlers for 'Method' and 'Member' # intercept this. If they see a name "self" with type that inherits from "symbolSelf", diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 151ead8c..f67efd0f 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -452,6 +452,17 @@ typeDeclarationEnv <- list2env(list( nCpp = function(value, ...) { symbolCppVar$new(baseType = value, ...) }, + nClass = function(value, ...) { + # e.g nClass(myClass(), interface = "generic") + # this allows member-level control over interface option + ttype <- nCaptureType(value) + typeSpec <- nTypeSpec(ttype) + symbolTBD$new(type = typeSpec$funName, + typeSpec = typeSpec, + quo = ttype, + where = parent.frame(), + ...) + }, T = function(symbol) { ## This is semi-defunct but could be resurrected. # The use of T(mytype) indicates that mytype evaluates to an # existing type object in the evalEnv. @@ -525,10 +536,8 @@ type2symbol <- function(type, texplicitType <- quo_strip_quote(texplicitType) if(!is.null(explicitType)) { -# typeToUse <- explicitType ttypeToUse <- texplicitType } else { -# typeToUse <- type ttypeToUse <- ttype } diff --git a/nCompiler/inst/include/nCompiler/nC_inter/loadedObjectsHook.h b/nCompiler/inst/include/nCompiler/nC_inter/loadedObjectsHook.h index 2fc6bf4b..4e7123ff 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/loadedObjectsHook.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/loadedObjectsHook.h @@ -8,7 +8,6 @@ class loadedObjectHookBaseC { public: - // virtual SEXP base_setup_R_return_object(SEXP Xptr)=0; virtual void hw()=0; virtual ~loadedObjectHookBaseC() {}; #ifdef NCOMPILER_USES_CEREAL @@ -17,49 +16,9 @@ class loadedObjectHookBaseC { #endif }; -// class CnC_env_holderC; - -// class CnC_env_holderC { -// public: -// static Rcpp::Environment CnClass_env; - -// }; - template class loadedObjectHookC; -// template -// class loadedObjectHookC : public loadedObjectHookBaseC { -// public: -// void hw() {}; -// ~loadedObjectHookC() {}; -// static Rcpp::Environment CnClass_env; -// static void set_CnClass_env(Rcpp::Environment env) {CnClass_env = env;} -// static SEXP setup_R_return_object_full(SEXP Xptr) { -// Rcpp::Environment nc("package: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::Function newLOE(nc["new.loadedObjectEnv"]); -// return newLOE(Xptr, CnClass_env); -// }; -// /* SEXP base_setup_R_return_object(SEXP Xptr) { */ -// /* Rcpp::Environment nc("package:nCompiler"); */ -// /* Rcpp::Function newLOE = nc["new.loadedObjectEnv"]; */ -// /* return newLOE(Xptr, CnClass_env); */ -// /* }; */ -// #ifdef NCOMPILER_USES_CEREAL -// template -// void _SERIALIZE_(Archive &archive) { -// archive(cereal::base_class(this)); -// } -// #endif -// }; - -// template -// Rcpp::Environment loadedObjectHookC::CnClass_env; #define CREATE_NEW_NCOMP_OBJECT(NCLASS_) \ loadedObjectHookC::setup_R_return_object(new_nCompiler_object()) @@ -68,9 +27,6 @@ loadedObjectHookC::setup_R_return_object(new_nCompiler_object( std::shared_ptr SHARED_(this); \ return loadedObjectHookC::setup_R_return_object(return_nCompiler_object(SHARED_)) -// #define RETURN_THIS_NCOMP_OBJECT(NCLASS_, OBJ) \ -// return return_nCompiler_object(OBJ_) - #define SET_CNCLASS_ENV(NCLASS_, ENV_) \ loadedObjectHookC::set_CnClass_env(ENV_) 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 f74ff628..e2ad4f44 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 @@ -96,6 +96,22 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { } }; + template + class accessor_class_aux : public accessor_class { + public: + typedef P T2::*ptrtype; // T2 will only be T or a base class of T. + AUX aux; + typedef std::pair wrap_type; + accessor_class_aux(ptrtype ptr_, AUX aux_) : + accessor_class(ptr_), aux(aux_) {}; + SEXP get(const genericInterfaceBaseC *intBasePtr) const { +#ifdef SHOW_FIELDS + std::cout<<"in derived get"<(intBasePtr)->*(this->ptr), aux)); + } + }; + // static maps from character names static int name_count; // typedef std::map name2index_type; @@ -122,6 +138,18 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { ); } + template + static name_access_pair field(std::string name, P T2::*ptr, AUX aux) { +#ifdef SHOW_FIELDS + std::cout<<"adding "<(new accessor_class_aux(ptr, aux)) + ); + } + // hello world to see if static maps were populated. void hw() { std::cout<<"HW "< struct wrap_shared_ptr_to_R< T, typename std::enable_if, T >::value>::type > { static SEXP go(std::shared_ptr< T > obj) { - SEXP Sans = PROTECT(loadedObjectHookC::setup_R_return_object_full( PROTECT(return_nCompiler_object< T >(obj) ) ) ); + SEXP Sans = PROTECT(loadedObjectHookC::setup_R_return_object_full( + PROTECT(return_nCompiler_object< T >(obj) ) ) ); + UNPROTECT(2); + return Sans; + } + static SEXP go(std::pair, nCwrapMode> pair_obj) { + SEXP Sans = PROTECT(loadedObjectHookC::setup_R_return_object_dyn( + PROTECT(return_nCompiler_object< T >(pair_obj.first) ), + pair_obj.second ) ); UNPROTECT(2); return Sans; } }; namespace Rcpp { - template - SEXP wrap( std::shared_ptr< T > obj ) { + template + SEXP wrap( std::shared_ptr< T > obj ) { SEXP Sans; if(!obj) { return(R_NilValue); @@ -103,6 +113,17 @@ namespace Rcpp { UNPROTECT(1); return Sans; } + + template + SEXP wrap( std::pair, nCwrapMode> pair_obj ) { + SEXP Sans; + if(!pair_obj.first) { + return(R_NilValue); + } + Sans = PROTECT(wrap_shared_ptr_to_R::go( pair_obj ) ); + UNPROTECT(1); + return Sans; + } } diff --git a/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/shared_ptr_as_wrap_forward_declarations.h b/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/shared_ptr_as_wrap_forward_declarations.h index f5fcaf31..c0832678 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/shared_ptr_as_wrap_forward_declarations.h +++ b/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/shared_ptr_as_wrap_forward_declarations.h @@ -2,6 +2,25 @@ #define SHARED_PTR_AS_WRAP_FORWARD_DECLARATIONS_H_ #include +#include + +// Defined here (not just forward-declared) because loadedObjectHookC_impl.h +// (included via the _post_Rcpp path before shared_ptr_as_wrap.h) needs the +// complete type: it accesses the nested nCwrapMode::mode enum and calls +// .get() in a class-template member body, which requires more than an +// incomplete type even though nothing has been instantiated yet. This class +// has no Rcpp dependency, so it's safe to define this early. +class nCwrapMode { + public: + enum class mode {full, generic}; + static constexpr mode full = mode::full; + static constexpr mode generic = mode::generic; + nCwrapMode(mode m) : m_(m) {} + nCwrapMode(bool m) : m_(m ? mode::full : mode::generic) {} + mode get() const { return m_; } + private: + mode m_; +}; namespace Rcpp { namespace traits { @@ -13,6 +32,18 @@ namespace traits { namespace Rcpp { template SEXP wrap( std::shared_ptr< T > obj ); + + // Forward-declared here (definition in shared_ptr_as_wrap.h) for the same + // reason as the shared_ptr overload above: accessor_class_aux::get(), in + // generic_class_interface_Rcpp_steps.h, calls this as a *qualified* name + // (Rcpp::wrap), which disables ADL. Two-phase lookup then fixes the + // overload set to whatever's visible at accessor_class_aux::get()'s + // definition point, included well before shared_ptr_as_wrap.h -- without + // this forward declaration, that call can never find this overload no + // matter what it's instantiated with, since no rescue lookup happens at + // instantiation time for qualified calls. + template + SEXP wrap( std::pair, nCwrapMode> pair_obj ); } #endif // SHARED_PTR_AS_WRAP_FORWARD_DECLARATIONS_H_ From 59c81b9c067d53f73fee743b8b38e37079e9fc45 Mon Sep 17 00:00:00 2001 From: perrydv Date: Thu, 6 Aug 2026 09:31:49 -0700 Subject: [PATCH 13/19] Member-specific control over generic vs full interface. New interface_names() feature to get method and member names. --- nCompiler/NAMESPACE | 1 + nCompiler/R/NC_FullCompiledInterface.R | 8 +++++- nCompiler/R/NC_LoadedObjectEnv.R | 18 ++++++++----- nCompiler/R/NC_SimpleInterface.R | 13 ++++++++++ nCompiler/R/cppDefs_R_interface_calls.R | 8 ++++++ nCompiler/R/nCppVec.R | 1 + .../nC_inter/generic_class_interface.h | 24 ++++++++++++++++++ .../generic_class_interface_Rcpp_steps.h | 25 ++++++++++++++++++- 8 files changed, 90 insertions(+), 8 deletions(-) diff --git a/nCompiler/NAMESPACE b/nCompiler/NAMESPACE index bb426cb3..e5b8cb37 100644 --- a/nCompiler/NAMESPACE +++ b/nCompiler/NAMESPACE @@ -64,6 +64,7 @@ export(get_nCompile_types) export(get_nOption) export(icloglog) export(ilogit) +export(interface_names) export(iprobit) export(is.loadedObjectEnv) export(isCNC) diff --git a/nCompiler/R/NC_FullCompiledInterface.R b/nCompiler/R/NC_FullCompiledInterface.R index 3d8d33bb..18063e4f 100644 --- a/nCompiler/R/NC_FullCompiledInterface.R +++ b/nCompiler/R/NC_FullCompiledInterface.R @@ -237,9 +237,15 @@ make_compiled_Cpub_class_code <- function(NCgenerator, if(is.null(newCobjFun)) stop("Cannot create a nClass full interface object without a newCobjFun or a CppObj argument.") CppObj <- newCobjFun() + } else { + if(isCNC(CppObj)) { + CppObj <- CppObj$private$Cpublic_obj$private$CppObj + } } + if(!nCompiler:::is.loadedObjectEnv(CppObj)) + stop("in initializeCpp: CppObj should be a loadedObjectEnv") private$CppObj <- CppObj - private$DLLenv <- `:::`("nCompiler", "get_DLLenv")(CppObj) # workaround static code scanning for nCompiler:::get_DLLenv(CppObj) + private$DLLenv <- nCompiler:::get_DLLenv(CppObj) }, list( NEWCOBJFUN = if(package) as.name(newCobjFun) diff --git a/nCompiler/R/NC_LoadedObjectEnv.R b/nCompiler/R/NC_LoadedObjectEnv.R index 0406ce9c..08ce3df6 100644 --- a/nCompiler/R/NC_LoadedObjectEnv.R +++ b/nCompiler/R/NC_LoadedObjectEnv.R @@ -27,8 +27,10 @@ new.loadedObjectEnv <- function(extptr = NULL, parentEnv = NULL) { #' @export to_full_interface <- function(LOE) { # parentEnv <- parent.env(LOE) - if(!is.loadedObjectEnv(LOE)) - stop("LOE should be a loadedObjectEnv") + if(!is.loadedObjectEnv(LOE)) { + if(isCNC(obj)) return(LOE) + else stop("LOE should be a loadedObjectEnv") + } CnCenv <- get_CnCenv(LOE) if(exists('.R6interface', CnCenv)) { fullAns <- CnCenv$.R6interface$new(CppObj = LOE) @@ -39,8 +41,10 @@ to_full_interface <- function(LOE) { #'@export to_generic_interface <- function(obj) { - if(!isCNC(obj)) - stop("obj should be a compiled nClass object") + if(!isCNC(obj)) { + if(is.loadedObjectEnv(obj)) return(obj) + else stop("obj should be a compiled nClass object") + } obj$private$Cpublic_obj$private$CppObj } @@ -161,7 +165,8 @@ setup_nClass_environments_from_package <- function(nClass_exportNames, reqdFuns <- c(reqdFuns, "call_method", "get_value", - "set_value") + "set_value", + "get_names") for(i in seq_along(interfaceTypes)) { if(createFromR[i]) reqdFuns <- c(reqdFuns, nClass_exportNames[i]) @@ -252,7 +257,8 @@ setup_DLLenv <- function(compiledFuns, "new_serialization_mgr", "get_value", "set_value", - "call_method" + "call_method", + "get_names" ) compiledFuns <- move_funs_from_list_to_env(namesForDLLenv, diff --git a/nCompiler/R/NC_SimpleInterface.R b/nCompiler/R/NC_SimpleInterface.R index d1a94a2d..4d51738e 100644 --- a/nCompiler/R/NC_SimpleInterface.R +++ b/nCompiler/R/NC_SimpleInterface.R @@ -44,6 +44,19 @@ value <- function(obj, name) { DLLenv$get_value(extptr, name) } +#' @export +interface_names <- function(obj, what = c("members", "methods")) { + what <- match.arg(what) + if(inherits(obj, "nClass")) + if(obj$isCompiled()) + obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj + else + stop("interface_names() can only be used on compiled nClass objects.") + DLLenv <- get_DLLenv(obj) + extptr <- getExtptr(obj) + DLLenv$get_names(extptr, methods = (what == "methods")) +} + #' @export `value<-` <- function(obj, name = NULL, value) { if(inherits(obj, "nClass")) { diff --git a/nCompiler/R/cppDefs_R_interface_calls.R b/nCompiler/R/cppDefs_R_interface_calls.R index 015123ab..294e803d 100644 --- a/nCompiler/R/cppDefs_R_interface_calls.R +++ b/nCompiler/R/cppDefs_R_interface_calls.R @@ -46,6 +46,14 @@ global_R_interface_cppDef <- " get_genericInterfaceBaseC(Xptr);\n", " // std::cout << name << std::endl;\n", " return(obj->call_method( name, Sargs ));\n", + "}\n\n", + + "// This is completely generic, good for all derived classes\n", + "// [[Rcpp::export]]\n", + "SEXP get_names(SEXP Xptr, bool methods) {\n", + " genericInterfaceBaseC *obj =\n", + " get_genericInterfaceBaseC(Xptr);\n", + " return(obj->get_names( methods ));\n", "}\n"), name = "R_interfaces" ) diff --git a/nCompiler/R/nCppVec.R b/nCompiler/R/nCppVec.R index 8ffd8cbb..6b07bf90 100644 --- a/nCompiler/R/nCppVec.R +++ b/nCompiler/R/nCppVec.R @@ -138,6 +138,7 @@ nList_nClass <- function(type, env = parent.frame()) { classname <- "nList" inner_cpp_typename <- type2cpp_typename({{ttype}}, where = env) + # cpp_classname matches the unique ID returned by nList(type, .ID=TRUE). cpp_classname <- Rname2CppName(paste0("nList_", type2uniqueID({{ttype}}, where = env))) # We need the C++ type for the nClass_inherit$base class, # but we can defer determining that until code generation 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 695deb8e..853c19b4 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h @@ -94,6 +94,15 @@ class genericInterfaceBaseC { return R_NilValue; } + // Return the available names (data members if methods==false, methods if + // methods==true) for R-level introspection (e.g. interface_names() in R). + // Derived classes should provide valid implementations. + virtual SEXP get_names(bool methods) const { + std::cout<<"Error: you should be in a derived genericInterfaceC class for get_names"< void _SERIALIZE_(Archive &archive) {} @@ -194,6 +203,9 @@ class interface_resolver : public Bases..., virtual public genericInterfaceBaseC SEXP make_deserialized_return_SEXP() override { return FirstFound::make_deserialized_return_SEXP(); } + SEXP get_names(bool methods) const override { + return FirstFound::get_names(methods); + } }; // Single-arg specialization: root nClass (no nClass parent). @@ -238,6 +250,9 @@ class interface_resolver : SEXP make_deserialized_return_SEXP() override { return FirstFound::make_deserialized_return_SEXP(); } + SEXP get_names(bool methods) const override { + return FirstFound::get_names(methods); + } }; // Empty specialization: nClass with no generic interface (no enable_shared_from_this). @@ -251,6 +266,12 @@ class interface_resolver<> : virtual public genericInterfaceBaseC const name2access_type& get_name2access() const override { return FirstFound::get_name2access(); } + 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); } @@ -266,6 +287,9 @@ class interface_resolver<> : virtual public genericInterfaceBaseC SEXP make_deserialized_return_SEXP() override { return FirstFound::make_deserialized_return_SEXP(); } + SEXP get_names(bool methods) const override { + return FirstFound::get_names(methods); + } }; // A forward declaration. (This is being disabled and a new approach is being used.) 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 e2ad4f44..c7495672 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 @@ -282,7 +282,30 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { // UNPROTECT(2); SEXP Sans = PROTECT(method->second.method_ptr->call(this, Sargs)); UNPROTECT(1); -return Sans; + return Sans; + } + + // Return the names of either the methods (methods==true) or the data + // members/fields (methods==false), for R-level introspection (e.g. + // interface_names() in R). Built fresh on each call rather than cached, + // since this is not a hot-path operation and caching a static SEXP would + // risk dangling across package unload/reload. + SEXP get_names(bool methods) const { + if(methods) { + Rcpp::CharacterVector ans(name2method.size()); + size_t i = 0; + for(typename name2method_type::const_iterator it = name2method.begin(); + it != name2method.end(); ++it, ++i) + ans[i] = it->first; + return ans; + } else { + Rcpp::CharacterVector ans(name2access.size()); + size_t i = 0; + for(name2access_type::const_iterator it = name2access.begin(); + it != name2access.end(); ++it, ++i) + ans[i] = it->first; + return ans; + } } template From a4e5ad7ac15d040f4ff8a759104a65a899ddf37d Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 11 Aug 2026 10:59:53 -0700 Subject: [PATCH 14/19] Tests for member control over interface type. Make various ls() uses have `all.names=TRUE` --- nCompiler/R/compileNimble.R | 2 +- nCompiler/R/compile_aaa_operatorLists.R | 2 +- nCompiler/R/compile_generateCpp.R | 8 +- nCompiler/R/nCompile.R | 6 +- .../nClass_tests/test-nClass_interface.R | 107 +++++++++++++++++- .../testthat/nCompile_tests/test-nCompile.R | 35 ++++++ .../testthat/nCompile_tests/test-userOps.R | 6 +- nCompiler/tests/testthat/testing_utils.R | 8 +- 8 files changed, 155 insertions(+), 19 deletions(-) diff --git a/nCompiler/R/compileNimble.R b/nCompiler/R/compileNimble.R index 0c24db2e..5570f214 100644 --- a/nCompiler/R/compileNimble.R +++ b/nCompiler/R/compileNimble.R @@ -356,7 +356,7 @@ compileNimble <- function(..., project, dirName = NULL, projectName = '', names(nComp_units) <- names(units) registerOpDef(nimble_nCompiler_opDefs) - on.exit({deregisterOpDef(ls(nimble_nCompiler_opDefs))}) + on.exit({deregisterOpDef(ls(nimble_nCompiler_opDefs, all.names = TRUE))}) ans <- do.call(nCompile, nComp_units) if(sum(nfUnits) > 0) { whichUnits <- which(nfUnits) diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index 088ea49e..ec9e67bb 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -77,7 +77,7 @@ registerOpDef <- function(opDefs, modify=TRUE, replaceEnv=TRUE) { #' @export deregisterOpDef <- function(names) { - if(!isTRUE(is.character(names))) names <- ls(names) # in case an env or list is passed in as names. + if(!isTRUE(is.character(names))) names <- ls(names, all.names = TRUE) # in case an env or list is passed in as names. suppressWarnings(rm(list=names, envir=operatorDefUserEnv)) } diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index 2e5381a2..69041265 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -404,9 +404,9 @@ inGenCppEnv( } ) -cppOutputMemberData <- function(code, symTab) { - paste0( nimGenerateCpp(code$args[[1]], symTab), '.', code$args[[2]]$name) -} +# cppOutputMemberData <- function(code, symTab) { +# paste0( nimGenerateCpp(code$args[[1]], symTab), '.', Rname2CppName(code$args[[2]]$name)) +# } inGenCppEnv( ## Member(A, x) -> A.x @@ -415,7 +415,7 @@ inGenCppEnv( objOutput <- if(isSelf) 'this' else compile_generateCpp(code$args[[1]], symTab) paste0( '(', objOutput, - ')', connector, code$args[[2]]$name) + ')', connector, Rname2CppName(code$args[[2]]$name)) } ) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 9695cbef..7654a651 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -602,7 +602,7 @@ nCompile <- function(..., while(!done_finding_units) { update_known_nClasses(new_units, new_unitTypes, project_env) - existing_known_nClass_names <- ls(project_env$known_nClasses) + existing_known_nClass_names <- ls(project_env$known_nClasses, all.names = TRUE) cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos, project_env) new_cppDefs <- cppDefs_info$cppDefs @@ -623,7 +623,7 @@ 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_known_nClass_names <- ls(project_env$known_nClasses) + updated_known_nClass_names <- ls(project_env$known_nClasses, all.names = TRUE) 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) @@ -1350,7 +1350,7 @@ WP_writeMemberData <- function(memberData, datDir) { # Write out data if (length(memberData) > 0) { datEnv <- as.environment(memberData) - ls_datEnv <- ls(datEnv) + ls_datEnv <- ls(datEnv, all.names = TRUE) for (i in seq_along(ls_datEnv)) { save(list = ls_datEnv[i], envir = datEnv, file = file.path(datDir, paste0(ls_datEnv[i], ".RData"))) diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R index f40d425f..98c37588 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R @@ -1,5 +1,100 @@ # (These work when run directly, but not when run through test_package().) +test_that("member-specific control over full vs generic return works", { + nc1 <- nClass( + Cpublic = list( + Cfoo = nFunction( + fun = function(x) { + return(x+1) + }, + argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar') + ), + compileInfo = list(interface = "generic") + ) + + nc1a <- nClass( + Cpublic = list( + Cfoo = nFunction( + fun = function(x) { + return(x+2) + }, + argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar') + ), + compileInfo = list(interface = "full") + ) + + nc1b <- nClass( + Cpublic = list( + Cfoo = nFunction( + fun = function(x) { + return(x+3) + }, + argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar') + ) + # pick up interface setting nCompile call. + ) + + nc2 <- nClass( + Cpublic = list( + x1 = "nc1()", + x2 = "nClass(nc1())", + x3 = "nClass(nc1(), interface = 'full')", + x4 = "nClass(nc1(), interface = 'generic')", + x5 = "nClass(nc1a(), interface = 'full')", + x6 = "nClass(nc1a(), interface = 'generic')", + x7 = "nClass(nc1b(), interface = 'full')", + x8 = "nClass(nc1b(), interface = 'generic')" + ) + ) + + comp <- nCompile(nc2, nc1, nc1a, nc1b) + obj2 <- comp$nc2$new() + expect_equal(interface_names(obj2), paste0("x", 1:8)) + expect_equal(interface_names(obj2, "methods"), character()) + obj1 <- comp$nc1() + expect_equal(interface_names(obj1), character()) + expect_equal(interface_names(obj1, "methods"), "Cfoo") + obj1a <- comp$nc1a$new() + obj1b <- comp$nc1b$new() + + obj2$x1 <- obj1 + obj2$x2 <- obj1 + obj2$x3 <- obj1 + obj2$x4 <- obj1 + obj2$x5 <- obj1a + obj2$x6 <- obj1a + obj2$x7 <- obj1b + obj2$x8 <- obj1b + + expect_true(is.loadedObjectEnv(obj2$x1)) + expect_false(isNC(obj2$x1)) + expect_true(is.loadedObjectEnv(obj2$x2)) + expect_false(isNC(obj2$x2)) + expect_false(is.loadedObjectEnv(obj2$x3)) + expect_true(isNC(obj2$x3)) + expect_true(is.loadedObjectEnv(obj2$x4)) + expect_false(isNC(obj2$x4)) + expect_false(is.loadedObjectEnv(obj2$x5)) + expect_true(isNC(obj2$x5)) + expect_true(is.loadedObjectEnv(obj2$x6)) + expect_false(isNC(obj2$x6)) + expect_false(is.loadedObjectEnv(obj2$x7)) + expect_true(isNC(obj2$x7)) + expect_true(is.loadedObjectEnv(obj2$x8)) + expect_false(isNC(obj2$x8)) + + expect_equal(interface_names(obj2$x7), character()) + expect_equal(interface_names(obj2$x7, "methods"), "Cfoo") + expect_equal(interface_names(obj2$x8), character()) + expect_equal(interface_names(obj2$x8, "methods"), "Cfoo") + + rm(obj2, obj1, obj1a, obj1b); gc() +}) + + test_that( "Basic and full interfaces work", { @@ -19,9 +114,11 @@ test_that( returnType = 'numericScalar') ) ) -# ans <- nCompile_nClass(nc1, interface = "generic") + ans <- nCompile(nc1, interfaces = "generic") obj <- ans() + expect_equal(interface_names(obj), sort(c("Ca", "Cv"))) + expect_equal(interface_names(obj, "methods"), "Cfoo") value(obj, 'Cv') <- 2.3 check <- value(obj, 'Cv') expect_equal(check, 2.3, info = "scalar value() and `value<-()`") @@ -66,10 +163,14 @@ test_that( returnType = 'numericScalar') ) ) -# ans <- nCompile_nClass(nc1, interface = "full") + ans <- nCompile(nc1, interfaces = "full") expect_true(isCompiledNCgenerator(ans)) obj <- ans$new() + + expect_equal(interface_names(obj), sort(c("Ca", "Cv"))) + expect_equal(interface_names(obj, "methods"), "Cfoo") + expect_true(inherits(obj, "nClass")) obj$Cv <- 2.3 check <- obj$Cv @@ -83,7 +184,7 @@ test_that( expect_equal(check, 4.4, info = "method from a full interface") }) -test_that("getting a generic interface pointer within C++ works", { +test_that("getting an interface base class pointer within C++ works", { nc1 <- nList("integerVector()") nc2 <- nClass( classname = "nc2", diff --git a/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R index f9b9d51e..7de3c482 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R @@ -952,6 +952,41 @@ test_that("argument name mangling and argument ordering work together", { expect_equal(comp2$bar2(1.2,TRUE), dnorm(1.2,0,1,TRUE)) }) +test_that("Rname2CppName mangling works for variables including members", { + nc1 <- nClass( + Cpublic = list( + .x = "numericVector", + .foo = nFunction( + function(.y = "numericVector") { + .s <- .x[1] + 1 # Induce a scalar assignment to see flex(dot_s) work + .z <- .x + .y + .z <- .z + 1 + return(.z) + returnType("numericVector") + } + ) + ) + ) + nc2 <- nClass( + Cpublic = list( + nc1a = "nc1", + go = nFunction( + function(.x = "numericVector", .y = "numericVector") { + nc1a <- nc1$new() + nc1a$.x <- .x + ans <- nc1a$.foo(.y) + return(ans) + returnType("numericVector") + } + ) + ) + ) + expect_no_error(comp <- nCompile(nc1, nc2, returnList = TRUE)) + obj <- comp$nc2$new() + expect_equal(obj$go(1:3, 4:6), 1:3 + 4:6 + 1) +}) + + test_that("showing types works", { test <- nFunction( name = "test", diff --git a/nCompiler/tests/testthat/nCompile_tests/test-userOps.R b/nCompiler/tests/testthat/nCompile_tests/test-userOps.R index 209cfbce..2cfeaf05 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-userOps.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-userOps.R @@ -29,7 +29,7 @@ test_that("registering a global user-defined operator definition (opDef) works", fillZeros=TRUE, recycle=TRUE, nDim, type="double") {}, simpleTransformations=list(handler = nimArrayHandler)))) - expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), "nimArray") + expect_equal(ls(nCompiler:::operatorDefUserEnv), "nimArray") registerOpDef( list(nimArray2 = @@ -39,7 +39,7 @@ test_that("registering a global user-defined operator definition (opDef) works", type="double") {}, simpleTransformations=list(handler = 'replace', replacement = 'nArray')))) - expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), c("nimArray", "nimArray2")) + expect_equal(ls(nCompiler:::operatorDefUserEnv), c("nimArray", "nimArray2")) nc <- nClass( Cpublic = list( @@ -66,7 +66,7 @@ test_that("registering a global user-defined operator definition (opDef) works", # deregisterOpDef("nimArray") deregisterOpDef("nimArray2") - expect_equal(length(ls(`:::`("nCompiler", "operatorDefUserEnv"))), 0) + expect_equal(length(ls(nCompiler:::operatorDefUserEnv)), 0) }) cat("User opDef could be dangerous prior to genCpp because it won't update cachedOpDef\n") diff --git a/nCompiler/tests/testthat/testing_utils.R b/nCompiler/tests/testthat/testing_utils.R index cc61b50a..af6d25cf 100644 --- a/nCompiler/tests/testthat/testing_utils.R +++ b/nCompiler/tests/testthat/testing_utils.R @@ -289,16 +289,16 @@ modifyBatchOnMatch <- get_matching_ops <- function(field, subfield = NULL, test = isTRUE) { ## Returns vector of operator names where the value in a given field (or its ## subfield) returns TRUE when the test function is applied to it. - ops <- ls(`:::`("nCompiler", "operatorDefEnv")) - values <- sapply(ops, `:::`("nCompiler", "getOperatorDef"), field, subfield) + ops <- ls(nCompiler:::operatorDefEnv, all.names = TRUE) + values <- sapply(ops, nCompiler:::getOperatorDef, field, subfield) if (is.null(values)) return(character(0)) names(values)[sapply(values, test)] } get_ops_values <- function(field, subfield = NULL) { ## Return a named (by operator) list of the values found in field/subfield. - ops <- ls(`:::`("nCompiler", "operatorDefEnv")) - values <- sapply(ops, `:::`("nCompiler", "getOperatorDef"), field, subfield, + ops <- ls(nCompiler:::operatorDefEnv, all.names = TRUE) + values <- sapply(ops, nCompiler:::getOperatorDef, field, subfield, simplify = FALSE) non_null <- sapply(values, function(x) !is.null(x)) return(values[non_null]) From c4f4e0cdfca30ac7cff3bf8a1da92f597efa8e95 Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 14 Aug 2026 14:31:34 -0700 Subject: [PATCH 15/19] Extent RuntimeFlatView and RuntimeFlatViewGroup to copy between two such objects. Tweak ETaccessor for Tensors. --- .../post_Rcpp/ETaccessor_post_Rcpp.h | 7 +- .../nCompiler/ET_ext/RuntimeFlatView.h | 98 +++++++++++++++++++ 2 files changed, 104 insertions(+), 1 deletion(-) 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 4099cb7e..b7f93fe5 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 @@ -313,10 +313,15 @@ class ETaccessor, copy> : public ETaccessorTyped &intDims() override { + intDims_.resize(NumIndices); Dimensions dim = obj.dimensions(); std::copy(dim.begin(), dim.end(), intDims_.begin()); return intDims_; diff --git a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h index 9f7204ee..28e5d622 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/RuntimeFlatView.h @@ -94,6 +94,41 @@ void walkStrided1(const std::vector &sizes, } } +// Two-sided version of walkStrided1: visits every multi-index combination +// over `sizes` exactly once, maintaining two native offsets (one per side) +// in lockstep via pure addition/subtraction. Used for view-to-view copies +// where both sides have the same logical shape (`sizes`) but independent +// strides/base/data -- e.g. two different objects' subviews of the same +// declared shape. Requires both sides to agree on `sizes`; callers are +// responsible for checking that before calling (see RuntimeFlatView::copyTo). +template +void walkStrided2(const std::vector &sizes, + const std::vector &stridesA, long baseA, + const std::vector &stridesB, long baseB, + Fn fn) { + const size_t n = sizes.size(); + if (n == 0) { + fn(baseA, baseB); + return; + } + std::vector idx(n, 0); + long offA = baseA; + long offB = baseB; + for (;;) { + fn(offA, offB); + size_t k = 0; + for (; k < n; ++k) { + offA += stridesA[k]; + offB += stridesB[k]; + if (++idx[k] < sizes[k]) break; + offA -= stridesA[k] * sizes[k]; + offB -= stridesB[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 @@ -114,6 +149,12 @@ class RuntimeFlatView { const RuntimeSubviewInfo &info() const { return info_; } Scalar *data() const { return data_; } + // Rebinds this view to new backing storage, keeping info_ (sizes, strides, + // baseOffset) exactly as built. Caller's responsibility that the new + // pointer's layout matches what info_ was built against (e.g. it's the + // same field of a different, same-shaped object). + void setData(Scalar *data) { data_ = 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. @@ -183,6 +224,22 @@ class RuntimeFlatView { [&](long off) { data_[off] = srcData[off]; }); } + // Element-wise copy to another view, independently strided (unlike + // copyToSameShape, dst need not share info_ at all -- only sizes must + // match, e.g. dst is the "same" field of a different object with its own + // layout). No intermediate buffer: both offsets are carried incrementally + // by walkStrided2. Throws if dst's kept-dimension shape disagrees. + void copyTo(RuntimeFlatView &dst) const { + if (dst.info_.sizes != info_.sizes) + throw std::runtime_error("RuntimeFlatView::copyTo: shape mismatch"); + walkStrided2(info_.sizes, info_.strides, info_.baseOffset, + dst.info_.strides, dst.info_.baseOffset, + [&](long offSrc, long offDst) { dst.data_[offDst] = data_[offSrc]; }); + } + + // this = src, inverse of copyTo. + void copyFrom(const RuntimeFlatView &src) { src.copyTo(*this); } + private: Scalar *data_; RuntimeSubviewInfo info_; @@ -212,6 +269,23 @@ class RuntimeFlatViewGroup { const RuntimeFlatView &view(size_t i) const { return views_[i]; } long offset(size_t i) const { return offsets_[i]; } + // Rebinds a single view's data pointer in place (see RuntimeFlatView::setData). + void setData(size_t i, Scalar *data) { views_[i].setData(data); } + + // Rebinds every view's data pointer, one call per view, in the same order + // they were add()-ed -- mirrors add() itself, so the caller just walks its + // own objects in that order without packing the new pointers into a + // vector first. prepare_for_setData() resets the internal cursor; each + // setNextData() rebinds the next view and advances it. + void prepare_for_setData() { setDataCursor_ = 0; } + + void setNextData(Scalar *data) { + if (setDataCursor_ >= views_.size()) + throw std::runtime_error("RuntimeFlatViewGroup::setNextData: more calls than views " + "(did you forget prepare_for_setData()?)"); + views_[setDataCursor_++].setData(data); + } + Eigen::Tensor copyIntoVector() const { Eigen::Tensor out(totalSize()); copyIntoVector(out.data()); @@ -255,10 +329,34 @@ class RuntimeFlatViewGroup { SetValuesProxy setValues_() { return SetValuesProxy(*this); } + // Element-wise copy to/from another group, view by view, with no + // intermediate buffer -- each pair delegates to RuntimeFlatView::copyTo, + // which checks that the pair's sizes agree. Requires both groups to have + // the same number of views, added in corresponding order; a per-view + // shape mismatch is caught here and rethrown with its index attached, so + // the error names which view/field disagrees instead of leaving that to + // the caller to work out from an unqualified "shape mismatch". + void copyTo(RuntimeFlatViewGroup &dst) const { + if (dst.views_.size() != views_.size()) + throw std::runtime_error("RuntimeFlatViewGroup::copyTo: numViews() mismatch"); + for (size_t i = 0; i < views_.size(); ++i) { + try { + views_[i].copyTo(dst.views_[i]); + } catch (const std::runtime_error &e) { + throw std::runtime_error("RuntimeFlatViewGroup::copyTo: view " + + std::to_string(i) + ": " + e.what()); + } + } + } + + // this = src, inverse of copyTo. + void copyFrom(const RuntimeFlatViewGroup &src) { src.copyTo(*this); } + private: std::vector> views_; std::vector offsets_; long totalSize_ = 0; + size_t setDataCursor_ = 0; }; #endif // NCOMPILER_RUNTIME_FLAT_VIEW_H_ From cc91d9b88dfac63fe4acf4fa007eea909e00a411 Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 26 Aug 2026 15:55:40 -0700 Subject: [PATCH 16/19] support compileInfo$abstract = TRUE in an nClass method. Catch lack of virtual=TRUE and createFromR=FALSE with warn & fix --- nCompiler/R/NC.R | 1 + nCompiler/R/NC_InternalsClass.R | 8 + nCompiler/R/NF.R | 2 +- nCompiler/R/NF_InternalsClass.R | 6 + nCompiler/R/cppDefs_core.R | 98 +----------- .../nClass_tests/test-nClass_inherit.R | 141 ++++++++++++++++-- 6 files changed, 150 insertions(+), 106 deletions(-) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index a8f791e7..591482da 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -110,6 +110,7 @@ nClass <- function(classname, # accessor specifier, typically "public", e.g. "public some_class". # Similarly, template arguments (include CRTP) should be in the text explicitly. # needed_units: list of needed nClasses and nFunctions to include, by name or object + # createFromR: Default TRUE, whether to enable creation of objects from R. # # packageNames: can be a vector or list of two names, possibly named by "uncompiled" and "compiled", # and taken in that order if unnamed. diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index a24cbe45..0f74a1de 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -55,10 +55,12 @@ NC_InternalsClass <- R6::R6Class( if(numEntries) { isMethod <- rep(FALSE, numEntries) isVirtual <- rep(FALSE, numEntries) + isAbstract <- rep(FALSE, numEntries) for(i in seq_along(Cpublic)) { if(isNF(Cpublic[[i]])) { isMethod[i] <- TRUE isVirtual[i] <- isTRUE(NFinternals(Cpublic[[i]])$compileInfo$virtual) + isAbstract[i] <- isTRUE(NFinternals(Cpublic[[i]])$compileInfo$abstract) # NFinternals(Cpublic[[i]])$isMethod <- TRUE next; } @@ -68,6 +70,12 @@ NC_InternalsClass <- R6::R6Class( call. = FALSE) } } + if(any(isAbstract)) { + if(!isFALSE(compileInfo$createFromR)) { + warning("Setting compileInfo$createFromR = FALSE since at least one method is abstract.") + self$compileInfo$createFromR <- FALSE + } + } has_Cpublic_init <- "initialize" %in% names(Cpublic) self$symbolTable <- typeList2symbolTable(Cpublic[!isMethod], where = env) self$cppSymbolNames <- Rname2CppName(symbolTable$getSymbolNames()) diff --git a/nCompiler/R/NF.R b/nCompiler/R/NF.R index 98732ff2..cd511b51 100644 --- a/nCompiler/R/NF.R +++ b/nCompiler/R/NF.R @@ -106,7 +106,7 @@ nFunction <- function(fun, compileInfo <- updateDefaults( list(C_fun = NULL, callFromR = TRUE, - virtual=FALSE, abstract=FALSE, const=FALSE, + virtual = FALSE, abstract = FALSE, const = FALSE, depends = list()), compileInfo ) diff --git a/nCompiler/R/NF_InternalsClass.R b/nCompiler/R/NF_InternalsClass.R index 731080ba..72a6c9a1 100644 --- a/nCompiler/R/NF_InternalsClass.R +++ b/nCompiler/R/NF_InternalsClass.R @@ -193,6 +193,12 @@ NF_InternalsClass <- R6::R6Class( self$ADcontent$cpp_code_name <- paste0(cpp_code_name,"_AD__") } } + # Check on virtual and abstract + if(isTRUE(self$compileInfo$abstract)) { + if(!isTRUE(self$compileInfo$virtual)) + warning("Setting compileInfo$virtual = TRUE since compileInfo$abstract = TRUE") + self$compileInfo$virtual <- TRUE + } }, updateCode = function(newCode) { self$code <- newCode diff --git a/nCompiler/R/cppDefs_core.R b/nCompiler/R/cppDefs_core.R index 1d62d11f..10920a75 100644 --- a/nCompiler/R/cppDefs_core.R +++ b/nCompiler/R/cppDefs_core.R @@ -793,11 +793,11 @@ cppFunctionClass <- R6::R6Class( scopes = character(), ...) { - if((!declaration) && is.null(self$code$code) && is.null(compileInfo$body)) + if((!declaration) && isTRUE(self$abstract)) return(character(0)) - ## There is no code. This can occur for - ## a nFunctionVirtual that is an - ## abstract base class. + + # if((!declaration) && is.null(self$code$code) && is.null(compileInfo$body)) + # return(character(0)) argsListToUse <- if(inherits(self$args, 'symbolTableClass')) self$args$getSymbols() @@ -849,84 +849,7 @@ cppFunctionClass <- R6::R6Class( } ) ) - ## ## old - ## argsListToUse <- if(inherits(self$args, 'symbolTableClass')) - ## self$args$getSymbols() - ## else { - ## list() - ## } - ## if(declaration) { - ## outputCode <- paste0( - ## if(self$virtual) - ## 'virtual ' - ## else - ## character(0), - - ## generateFunctionHeader(self$returnType, - ## self$name, - ## argsListToUse, - ## scopes, - ## self$template, - ## self$static, ...), - - ## if(self$const) - ## ' const ' - ## else - ## character(0), - - ## if(self$abstract) - ## '= 0' - ## else - ## character(0), - - ## ';' - ## ) ## end paste - ## if(isTRUE(self$externC)) - ## outputCode <- paste0('extern "C" ', outputCode) - ## return(outputCode) - ## } else { - ## if(is.null(self$code$code)) - ## ## There is no code. This can occur for - ## ## a nFunctionVirtual that is an - ## ## abstract base class. - ## return(character(0)) - ## } - ## c(self$commentsAbove, - ## paste0( - ## generateFunctionHeader(self$returnType, - ## self$name, - ## argsListToUse, - ## scopes, - ## self$template, - ## static = FALSE, - ## ...), ' ', - ## if(self$const) - ## ' const ' - ## else - ## character(), - ## ' ', - ## if(!is.null(self$initializerList)) - ## generateInitializerList(self$initializerList) ## We can add a symbolTable to use later if necessary - ## else - ## character(0), - ## '{' - ## ), ## end paste, - ## 'RESET_EIGEN_ERRORS'[ - ## isTRUE(nOptions('compilerOptions')$throwEigenErrors) - ## ], - ## 'BEGIN_NC_ERRORTRAP'[ - ## isTRUE(nOptions('compilerOptions')$cppStacktrace) - ## ], - ## self$code$generate(...), - ## 'END_NC_ERRORTRAP'[ - ## isTRUE(nOptions('compilerOptions')$cppStacktrace) - ## ], - ## list('}') - ## )## end c() - ## } - ## ) -#) generateInitializerList <- function(initializerList) { ## initializerList should be a list of exprClass objects @@ -944,12 +867,6 @@ generateFunctionHeader <- function(self, scopes, args ) { - #returnType, - # name, -# args, - # scopes = character(), - # template = character(), - # static = FALSE) { compileInfo <- self$compileInfo @@ -965,8 +882,6 @@ generateFunctionHeader <- function(self, virtual_text <- compileInfo$virtual else if(isTRUE(self$virtual)) virtual_text <- 'virtual ' - # virtual_text <- compileInfo$virtual - # if(is.null(virtual_text)) virtual_text <- if(isTRUE(self$virtual)) 'virtual ' else character() isAbstract <- compileInfo$abstract if(is.null(isAbstract)) isAbstract <- self$abstract @@ -1011,7 +926,7 @@ generateFunctionHeader <- function(self, qualifier_text <- compileInfo$qualifiers if(is.null(qualifier_text)) { qualifier_text <- if(self$const) 'const ' else character() - if(self$abstract) qualifier_text <- c(qualifier_text, "= 0") + # if(self$abstract) qualifier_text <- c(qualifier_text, "= 0") } header <- list( @@ -1023,7 +938,8 @@ generateFunctionHeader <- function(self, returnType_text, scopes_name_text, args_text, - qualifier_text + qualifier_text, + abstract_text ) ) header diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R index 5c8cbe1e..e472e2c6 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R @@ -453,7 +453,7 @@ test_that("inheritance with interfaces at multiple levels", { return(base_x); returnType('numericScalar') }, name = "get_x"), - # get_x_virt will be virtual + # get_x_virt will be virtual get_x_virt = nFunction( function() { return(base_x); returnType('numericScalar') @@ -644,21 +644,21 @@ test_that("inheritance with interfaces at multiple levels", { # base accessing an actual base expect_equal(c( obj$useBase(1) - ,obj$useBase(2) - ,obj$useBase(3) - ,obj$useBase(4)), rep(11, 4)) + ,obj$useBase(2) + ,obj$useBase(3) + ,obj$useBase(4)), rep(11, 4)) # der accessing an actual der expect_equal(c( obj$useDer(1) - ,obj$useDer(2) - ,obj$useDer(3) - ,obj$useDer(4)), c(3, 1, 3, 1)) + ,obj$useDer(2) + ,obj$useDer(3) + ,obj$useDer(4)), c(3, 1, 3, 1)) expect_equal(c( obj$useDer(5) - ,obj$useDer(6) - ,obj$useDer(7)), c(1, 2, 2)) + ,obj$useDer(6) + ,obj$useDer(7)), c(1, 2, 2)) expect_equal(c( obj$useDer(8) @@ -670,9 +670,9 @@ test_that("inheritance with interfaces at multiple levels", { obj$myBase <- Cder expect_equal(c( obj$useBase(1) - ,obj$useBase(2) - ,obj$useBase(3) - ,obj$useBase(4)), c(3,1,1,1)) + ,obj$useBase(2) + ,obj$useBase(3) + ,obj$useBase(4)), c(3,1,1,1)) # base pointing to a mid @@ -713,7 +713,7 @@ test_that("manual access to derived interfaced members works", { function(obj = ncDer()) { cppLiteral("auto ETacc = obj->access(\"x\");") cppLiteral("ans = ETacc->map<1, double>();", types=list(ans="numericVector")) - # Cppliteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) + # Cppliteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) return(ans) returnType(numericVector()) } @@ -722,7 +722,7 @@ test_that("manual access to derived interfaced members works", { function(obj = ncBase()) { cppLiteral("auto ETacc = obj->access(\"x\");") cppLiteral("ans = ETacc->map<1, double>();", types=list(ans="numericVector")) -# cppLiteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) + # cppLiteral("ans = Rcpp::as >(obj->get_value(\"x\"));", types=list(ans = "numericVector")) return(ans) returnType(numericVector()) } @@ -735,3 +735,116 @@ test_that("manual access to derived interfaced members works", { comp$foo2(obj) rm(obj); gc() }) + +test_that("abstract functions in a base class work", { + ncBase <- nClass( + classname = "ncBase", + Cpublic = list( + foo = nFunction( + name = "foo", + function(x = double(1)) { + returnType(double(1)) + }, + compileInfo = list(virtual = TRUE, abstract = TRUE) + ), + bar = nFunction( + name = "bar", + function(x = double(1)) { + returnType(double(1)) + return(x + 1) + } + ) + ), + compileInfo = list( + createFromR = FALSE + ) + ) + ncDer <- nClass( + classname = "ncDer", + inherit = ncBase, + Cpublic = list( + foo = nFunction( + function(x = double(1)) { + return(x + 2) + returnType(double(1)) + } + ) + ) + ) + comp <- expect_no_error( + nCompile(ncBase, ncDer, control = list(return_cppDefs = TRUE)) + ) + out <- capture_output( comp[[1]]$generate(declaration = TRUE) |> writeCode() ) + expect_true(grepl(" = 0;", out)) + expect_true(grepl("foo", out)) + out <- capture_output( comp[[1]]$generate() |> writeCode()) + expect_false(grepl("foo", out)) + expect_no_error(comp <- nCompile(ncBase, ncDer)) + obj <- comp$ncDer$new() + expect_equal(obj$foo(1:3), 3:5) + rm(obj); gc() + + expect_warning( + ncBase <- nClass( + classname = "ncBase", + Cpublic = list( + foo = nFunction( + name = "foo", + function(x = double(1)) { + returnType(double(1)) + }, + compileInfo = list(virtual = TRUE, abstract = TRUE) + ), + bar = nFunction( + name = "bar", + function(x = double(1)) { + returnType(double(1)) + return(x + 1) + } + ) + ) + ), + "Setting compileInfo\\$createFromR = FALSE") + comp <- expect_no_error( + nCompile(ncBase, ncDer, control = list(return_cppDefs = TRUE)) + ) + out <- capture_output( comp[[1]]$generate(declaration = TRUE) |> writeCode() ) + expect_true(grepl(" = 0;", out)) + expect_true(grepl("foo", out)) + out <- capture_output( comp[[1]]$generate() |> writeCode()) + expect_false(grepl("foo", out)) + + + expect_warning( + ncBase <- nClass( + classname = "ncBase", + Cpublic = list( + foo = nFunction( + name = "foo", + function(x = double(1)) { + returnType(double(1)) + }, + compileInfo = list(abstract = TRUE) + ), + bar = nFunction( + name = "bar", + function(x = double(1)) { + returnType(double(1)) + return(x + 1) + } + ) + ), + compileInfo = list( + createFromR = FALSE + ) + ), + "Setting compileInfo\\$virtual = TRUE") + comp <- expect_no_error( + nCompile(ncBase, ncDer, control = list(return_cppDefs = TRUE)) + ) + out <- capture_output( comp[[1]]$generate(declaration = TRUE) |> writeCode() ) + expect_true(grepl(" = 0;", out)) + expect_true(grepl("foo", out)) + out <- capture_output( comp[[1]]$generate() |> writeCode()) + expect_false(grepl("foo", out)) +}) From 5accdb01b3b7b4cea1838a6b8aaa10add69addab Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 28 Aug 2026 14:46:19 -0700 Subject: [PATCH 17/19] Add an option to control warnings from nClass --- nCompiler/R/NC.R | 2 +- nCompiler/R/NC_InternalsClass.R | 3 ++- nCompiler/R/options.R | 1 + 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index 591482da..ca21cd2a 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -185,7 +185,7 @@ nClass <- function(classname, init_body_text <- deparse(body(Rpublic[['initialize']])) has_super_init <- any(grepl("super\\$initialize", init_body_text)) has_init_cpublic <- any(grepl("initialize_Cpublic", init_body_text)) - if(!has_super_init && !has_init_cpublic) + if(!has_super_init && !has_init_cpublic && isTRUE(get_nOption("NCwarn"))) warning( "The Rpublic 'initialize' function does not call 'super$initialize()' or ", "'initialize_Cpublic()'. Without one of these, the Cpublic component will not ", diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index 0f74a1de..a6362c71 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -72,7 +72,8 @@ NC_InternalsClass <- R6::R6Class( } if(any(isAbstract)) { if(!isFALSE(compileInfo$createFromR)) { - warning("Setting compileInfo$createFromR = FALSE since at least one method is abstract.") + if(isTRUE(get_nOption("NCwarn"))) + warning("Setting compileInfo$createFromR = FALSE since at least one method is abstract.") self$compileInfo$createFromR <- FALSE } } diff --git a/nCompiler/R/options.R b/nCompiler/R/options.R index 6c9c8885..6084fa18 100644 --- a/nCompiler/R/options.R +++ b/nCompiler/R/options.R @@ -10,6 +10,7 @@ updateDefaults <- function(defaults, control) { list( enableSaving = TRUE, check_nFunction = TRUE, ## check syntax of nFunction fun + NCwarn = TRUE, ## issue warnings from issues when creating an nClass showCompilerOutput = FALSE, use_nCompLocal = FALSE, debugSizeProcessing = FALSE, From a533bc1b928f327058bc5b77fd8f98d1a8c9b18c Mon Sep 17 00:00:00 2001 From: perrydv Date: Fri, 28 Aug 2026 14:51:05 -0700 Subject: [PATCH 18/19] remove nimbleModel and compileNimble from testing and prototypes (moved to nimble2) --- .github/workflows/test-all.yaml | 9 - nCompiler/DESCRIPTION | 1 - nCompiler/R/compileNimble.R | 373 ------------------ .../nimble_tests/test-compileNimble.R | 75 ---- 4 files changed, 458 deletions(-) delete mode 100644 nCompiler/R/compileNimble.R delete mode 100644 nCompiler/tests/testthat/nimble_tests/test-compileNimble.R diff --git a/.github/workflows/test-all.yaml b/.github/workflows/test-all.yaml index 326b801d..074e17ce 100644 --- a/.github/workflows/test-all.yaml +++ b/.github/workflows/test-all.yaml @@ -39,10 +39,6 @@ jobs: - uses: actions/checkout@v4 - name: SessionInfo run: R -q -e 'sessionInfo()' - - name: Install nimbleModel - run: R -q -e 'remotes::install_github("https://github.com/perrydv/nimbleModel", subdir="nimbleModel", auth_token=Sys.getenv("GITHUB_TOKEN_NIMBLEMODEL"))' - env: - GITHUB_TOKEN_NIMBLEMODEL: ${{ secrets.GH_NM_PAT }} - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline @@ -95,10 +91,6 @@ jobs: #- name: System Dependencies # # can be used to install e.g. cmake or other build dependencies # run: apt update -qq && apt install --yes --no-install-recommends cmake git - - name: Install nimbleModel - run: R -q -e 'remotes::install_github("https://github.com/perrydv/nimbleModel", subdir="nimbleModel", auth_token=Sys.getenv("GITHUB_TOKEN_NIMBLEMODEL"))' - env: - GITHUB_TOKEN_NIMBLEMODEL: ${{ secrets.GH_NM_PAT }} - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline @@ -110,7 +102,6 @@ jobs: - name: Run nCompile and other tests run: | library(nCompiler) - # testthat::test_dir("nCompiler/tests/testthat/nimble_tests", reporter = "summary") testthat::test_dir("nCompiler/tests/testthat/nClass_tests", reporter = "summary") testthat::test_dir("nCompiler/tests/testthat/types_tests", reporter = "summary") testthat::test_dir("nCompiler/tests/testthat/serialization_tests", reporter = "summary") diff --git a/nCompiler/DESCRIPTION b/nCompiler/DESCRIPTION index 5fa6d562..f2335663 100644 --- a/nCompiler/DESCRIPTION +++ b/nCompiler/DESCRIPTION @@ -35,7 +35,6 @@ Collate: compile_simpleIntermediates.R compile_simpleTransformations.R compile_finalTransformations.R - compileNimble.R cppDefs_core.R cppDefs_utils.R cppDefs_ADutils.R diff --git a/nCompiler/R/compileNimble.R b/nCompiler/R/compileNimble.R deleted file mode 100644 index 5570f214..00000000 --- a/nCompiler/R/compileNimble.R +++ /dev/null @@ -1,373 +0,0 @@ -## Drafting backward compatibility for nimble here. -## Eventually this should live in the nimble package itself. - -compileNimble_expandUnits <- function(units, unitTypes) { - ## This will return a list with: - ## - units: a list of units containing any units called by the input units - ## - unitTypes: a corresponding vector of unitTypes - ## - a list of additional names for units in case the same is found by multiple names - ## which would be unusual but technically seems possible - needed_result <- character() - done <- FALSE - new_units <- units - new_extraNames <- rep(list(character()), length(units)) - new_unitTypes <- unitTypes - output_units <- list() - output_unitTypes <- character() - output_extraNames <- list() - while(!done) { - new_needed_result <- character() - for(i in seq_along(new_units)) { - if(unitTypes[i]=="rcf") { - nfMethodRCobj <- environment(new_units[[i]])$nfMethodRCobject - new_needed_result <- c(new_needed_result, - RCfun_find_needed_recurse(nfMethodRCobj$code)) - } - } - output_units <- c(output_units, new_units) - output_unitTypes <- c(output_unitTypes, new_unitTypes) - output_extraNames <- c(output_extraNames, new_extraNames) - new_units <- list() - new_extraNames <- list() - new_unitTypes <- character() - - new_unique_names <- unique(names(new_needed_result)) - new_unique_names <- setdiff(new_unique_names, names(needed_result)) - if(length(new_unique_names)==0) { - done <- TRUE - next - } - unique_new_needed_result <- new_needed_result[new_unique_names] - new_found_objects <- mget(names(unique_new_needed_result), - envir = asNamespace("nimble"), - inherits=TRUE, ifnotfound=list(NULL)) - new_object_already_in_units <- rep(FALSE, length(new_found_objects)) - needed_result <- c(needed_result, unique_new_needed_result) - new_found_objects_unitTypes <- nimble:::getNimbleTypes(new_found_objects) - for(i in seq_along(new_found_objects)) { - this_object <- new_found_objects[[i]] - if(is.null(this_object)) { - message("The nimbleFunction ", names(new_found_objects)[i], - " is not found. We'll try to continue anyway.") - new_object_already_in_units[i] <- TRUE # to allow moving on - } - for(j in seq_along(output_units)) { - if(identical(output_units[[j]], this_object)) { - new_object_already_in_units[i] <- TRUE - new_name <- names(new_found_objects)[i] - if(!(new_name==names(output_units)[j])) - output_extraNames[[j]] <- c(output_extraNames[[j]], - names(new_found_ojects)[i]) - break - } - } - for(j in seq_along(new_units)) { - if(identical(new_units[[j]], this_object)) { - new_object_already_in_units[i] <- TRUE - new_extraNames[[j]] <- c(new_extraNames[[j]], - names(new_found_ojects)[i]) - break - } - } - if(!new_object_already_in_units[i]) { - if(!isTRUE(new_found_objects_unitTypes[i]=="unknown")) { - message("not sure what to do with object found for ", - names(new_found_objects)[i], " which is not an rcf.") - } else { - new_units <- c(new_units, this_object) - new_extraNames <- c(new_extraNames, list(character())) - new_unitTypes <- c(unitTypes, new_found_objects_unitTypes[i]) - } - } - } - if(all(new_object_already_in_units)) { - done <- TRUE - } - } - list(units = output_units, - unitTypes = output_unitTypes, - extraNames = output_extraNames) -} - -nimble_other_valid_call_names <- c("{", "$") - -RCfun_find_needed_recurse <- function(code) { - results <- character() - cl = length(code) - if(is.call(code)) { # f(a, b, c) - # Handle the f - f_code <- code[[1]] # f of f(a, b, c) - if(length(f_code) > 1) { # A case like g(h)(a, b, c), i.e. a chained call - results <- c(results, - RCfun_find_needed_recurse(f_code)) - } else { # not a chained call - # look for f in sizeProcessing or in environment - f_text <- deparse(f_code) - if(identical(f_text, "$")) { - if(identical(deparse(code[[3]]), "new")) - results <- c(results, structure("NFgenerator", names=deparse(code[[2]]))) - } - new_RCfun <- is.null(nimble:::sizeCalls[[f_text]]) && - is.null(nimble:::specificCallHandlers[[f_text]]) - new_RCfun <- new_RCfun && !(f_text %in% nimble_other_valid_call_names) - # check if it is a needed RCfun - if(new_RCfun) { - results <- c(results, structure("RCfun", names=f_text)) - } - } - # handle the arguments - if(length(code) > 1) { - for(i in 2:length(code)) { - if(is.call(code[[i]])) { # avoids recursing on a$b for an object rather than packaging.R - results <- c(results, - RCfun_find_needed_recurse(code[[i]])) - } - } - } - } - results -} - -RCfun_2_nFun <- function(RCfun, env=parent.frame()) { - if(inherits(RCfun, "nfMethodRC")) nfMethodRCobj <- RCfun - else nfMethodRCobj <- environment(RCfun)$nfMethodRCobject - fun <- function() {} - body(fun) <- nfMethodRCobj$code - formals(fun) <- nfMethodRCobj$argInfo - nFun <- nFunction( - name = nfMethodRCobj$uniqueName, # This might be helpful - fun = fun, - returnType = !!(nfMethodRCobj$returnType), - where = env - ) - nFun -} - -BROWSE_COMPILE_NIMBLE <- FALSE - -## nf <- nimbleFunction( -## setup = function() {x <- 1:2}, -## run = function() {return(x[1]); returnType(double())} -## ) - -## nf1 <- nf() - -## test2 <- nCompile_nimbleFunctionClass(nf1) - -## nC1 <- nClass(Cpublic = list(x1 = 'integerVector')) -## test <- nC1$new() - -buildCopyFromNimbleFunction <- function(nComp_types_list) { - buildOneCopyLine <- function(type) { - paste0('SEXP_to_type(', type$name, ', SdataEnv["',type$name,'"]);') - } - copyLines <- nComp_types_list |> lapply(buildOneCopyLine) |> unlist() -# copyLines <- 'Rprintf("copying\\n");' - copyfun <- eval(substitute( - nFunction( - function(NFobj = 'SEXP') { - nCpp(c("Rcpp::Environment SdataEnv = get_NF_dataenv(NFobj);", - COPYLINES)) - }), - list(COPYLINES=copyLines) - )) -} - -NF_2_nClass <- function(nf) { - #browser() - dirName = tempdir() - projectName <- '' - project <- nimble:::nimbleProjectClass(dirName, name = projectName) - generatorName <- nimble:::nfGetDefVar(nf, 'name') - nfProc <- nimble:::nfProcessing(nf, generatorName, fromModel = FALSE, project = project, isNode = FALSE) - nfProc$setupTypesForUsingFunction() - setupSymTab <- nfProc$setupSymTab - nComp_types_list <- nimbleSymTab_to_nComp_types(setupSymTab) - origMethods <- nfProc$origMethods - nComp_methods_list <- origMethods |> lapply(RCfun_2_nFun) - copyFromNimbleFunction <- - list(copyFromNF = buildCopyFromNimbleFunction(nComp_types_list)) - nCans <- nClass( - classname = nfProc$name, - Cpublic = c(nComp_types_list, nComp_methods_list, copyFromNimbleFunction) - ) - nCans -} - -nCompile_nimbleFunctionClass <- function(nf) { - #browser() - nCans <- NF_2_nClass(nf) - CnCans <- nCompile(nCans) - obj <- CnCans$new() - obj$copyFromNF(nf) - obj -} - -nimbleSymTab_to_nComp_types <- function(symTab) { - symbolNames <- symTab$getSymbolNames() - result <- list() - for(sn in symbolNames) { - obj <- symTab$getSymbolObject(sn) - symClass <- class(obj) - if(symClass[length(symClass)] == "symbolBasic") { # numeric, integer, logical - nDim <- obj$nDim - scalarType <- obj$type - result[[sn]] <- nTypeBasic(name = sn, scalarType=scalarType, nDim=nDim) - } - } - result -} - -nimble_nCompiler_opDefs <- list( - nimRound = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='round')), - nimNumeric = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nNumeric')), - nimInteger = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nInteger')), - nimLogical = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nLogical')), - nimMatrix = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nMatrix')), - nimC = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nC')), - nimRep = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nRep')), - nimSeq = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nSeq')), - nimDim = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='dim')), - rexp_nimble = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='rexp_nCompiler')), - dexp_nimble = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='dexp_nCompiler')), - nimStep = list(simpleTransformations=list(handler='replaceAndNormalize', replacement='nStep')) -) - -proxyNimbleProjectClass <- R6::R6Class( - classname = "nimbleProjectClass", - public = list( - dirName = NULL, - name = NULL, - initialize = function(name, dirName) { - if(!missing(name)) self$name <- name - if(!missing(dirName)) self$dirName <- dirName - }, - resetFunctions = function() {}, - clearCompiled = function() {} - ) -) - -compileNimble <- function(..., project, dirName = NULL, projectName = '', - control = list(), - resetFunctions = FALSE, - showCompilerOutput = getNimbleOption('showCompilerOutput')) { - ## 1. Extract compilation items - reset <- FALSE - if(BROWSE_COMPILE_NIMBLE) browser() - ## This pulls out ... arguments, makes names from their expressions if names weren't provided, and combines them with any ... arguments that are lists. - controlDefaults = list(debug = FALSE, debugCpp = FALSE, compileR = TRUE, writeFiles = TRUE, compileCpp = TRUE, loadSO = TRUE, returnAsList = FALSE) - - controlDefaults$nCompiler_expandUnits <- TRUE - - dotsDeparses <- unlist(lapply( substitute(list(...))[-1], deparse )) - origList <- list(...) - if(is.null(names(origList))) names(origList) <- rep('', length(origList)) - boolNoName <- names(origList)=='' - origIsList <- unlist(lapply(origList, is.list)) - dotsDeparses[origIsList] <- '' - names(origList)[boolNoName] <- dotsDeparses[boolNoName] - units <- do.call('c', origList) - - if(any(sapply(units, is, "MCMCconf"))) - stop("You have provided an MCMC configuration object, which cannot be compiled. Instead, use run 'buildMCMC' on the configuration object and compile the resulting MCMC object.") - unitTypes <- nimble:::getNimbleTypes(units) - if(length(grep('unknown', unitTypes)) > 0) stop(paste0('Some items provided for compilation do not have types that can be compiled: ', paste0(names(units), collapse = ' '), '. The types provided were: ', paste0(unitTypes, collapse = ' '), '. Be sure only specialized nimbleFunctions are provided, not nimbleFunction generators.'), call. = FALSE) - if(is.null(names(units))) names(units) <- rep('', length(units)) - if(length(units) == 0) stop('No objects for compilation provided') - - ## 2. Get project or make new project - if(missing(project)) { - if(reset) warning("You requested 'reset = TRUE', but no project was provided. If you are trying to re-compiled something into the same project, give it as the project argument as well as a compilation item. For example, 'compileNimble(myFunction, project = myFunction, reset = TRUE)'.") - if(!is.null(getNimbleOption('nimbleProject'))) project <- getNimbleOption('nimbleProject') - else project <- proxyNimbleProjectClass$new(dirName, name=projectName) #nimble:::nimbleProjectClass(dirName, name = projectName) - - ## Check for uncompiled models. - if(!any(sapply(units, is, 'RmodelBaseClass'))) { - mcmcUnits <- which(sapply(units, class) == "MCMC") - if(any(sapply(mcmcUnits, function(idx) { - class(units[[idx]]$model$CobjectInterface) == "uninitializedField" - }))) - stop("compileNimble: The model associated with an MCMC is not compiled. Please compile the model first.") - } - } else { - project <- getNimbleProject(project, TRUE) - if(!inherits(project, 'nimbleProjectClass')) - stop("Invalid project argument; note that models and nimbleFunctions need to be compiled before they can be used to specify a project. Once compiled you can use an R model or nimbleFunction to specify the project.", call. = FALSE) - } - if(resetFunctions) project$resetFunctions() - - for(i in names(controlDefaults)) { - if(!i %in% names(control)) control[[i]] <- controlDefaults[[i]] - } - - if(!showCompilerOutput) { - messageIfVerbose("Compiling via nCompiler\n [Note] This may take a minute.\n [Note] Use 'showCompilerOutput = TRUE' to see C++ compilation details.") - } - if(showCompilerOutput) { - messageIfVerbose("Compiling via nCompiler\n [Note] This may take a minute.\n [Note] On some systems there may be some compiler warnings that can be safely ignored.") - } - - # - if(isTRUE(control[['nCompiler_expandUnits']])) { - expandedUnits <- compileNimble_expandUnits(units, unitTypes) - units <- expandedUnits$units - unitTypes <- expandedUnits$unitTypes - units_extraNames <- expandedUnits$extraNames - } - foundUnitsEnv <- new.env() - # - ans <- list() - nComp_units <- vector(mode="list", length = length(units)) - rcfUnits <- unitTypes == 'rcf' - if(sum(rcfUnits) > 0) { - whichUnits <- which(rcfUnits) - for(i in whichUnits) { - if(isTRUE(getNimbleOption("enableDerivs"))) { - if(!isFALSE(environment(units[[i]])$nfMethodRCobject$buildDerivs)) - stop(paste0("A nimbleFunction without setup code and with buildDerivs = TRUE can't be included\n", - "directly in a call to compileNimble. It can be called by another nimbleFunction and,\n", - "in that case, will be automatically compiled.")) - } - nComp_units[[i]] <- RCfun_2_nFun(units[[i]], foundUnitsEnv) - foundUnitsEnv[[names(units)[i]]] <- nComp_units[[i]] - if(isTRUE(control[['nCompiler_expandUnits']])) { - for(EN in units_extraNames[[i]]) - foundUnitsEnv[[EN]] <- nComp_units[[i]] - } - environment(units[[i]])$nfMethodRCobject[['nimbleProject']] <- project -# ans[[i]] <- project$compileRCfun(units[[i]], control = control, showCompilerOutput = showCompilerOutput) -# if(names(units)[i] != '') names(ans)[i] <- names(units)[i] - } - } - - nfUnits <- unitTypes == 'nf' - if(sum(nfUnits) > 0) { - whichUnits <- which(nfUnits) - if(length(whichUnits)>1) message("Still need to check for multiple objects of the same nimbleFunction class.") - for(i in whichUnits) { - nComp_units[[i]] <- NF_2_nClass(units[[i]]) - nfVar(units[[i]], "nimbleProject") <- project - } - #nfAns <- project$compileNimbleFunctionMulti(units[whichUnits], control = control, - # reset = reset, showCompilerOutput = showCompilerOutput) - #ans[whichUnits] <- nfAns - #for(i in whichUnits) if(names(units)[i] != '') names(ans)[i] <- names(units)[i] - } - - names(nComp_units) <- names(units) - registerOpDef(nimble_nCompiler_opDefs) - on.exit({deregisterOpDef(ls(nimble_nCompiler_opDefs, all.names = TRUE))}) - ans <- do.call(nCompile, nComp_units) - if(sum(nfUnits) > 0) { - whichUnits <- which(nfUnits) - for(i in whichUnits) { - obj <- if(is.list(ans)) ans[[i]]$new() else ans$new() - obj$copyFromNF(units[[i]]) - if(is.list(ans)) - ans[[i]] <- obj - else - ans <- obj # Add checking that there is one and only one unit. - } - } - ans -} diff --git a/nCompiler/tests/testthat/nimble_tests/test-compileNimble.R b/nCompiler/tests/testthat/nimble_tests/test-compileNimble.R deleted file mode 100644 index 4a64826f..00000000 --- a/nCompiler/tests/testthat/nimble_tests/test-compileNimble.R +++ /dev/null @@ -1,75 +0,0 @@ -## Support for bridging nimble's compileNimble to nCompile -## Only basic tests will be here. -## The real tests will be running nimble's test suite. - -library(nimble) -library(nCompiler) -library(testthat) - -test_that("compileNimble bridge works for simple nimbleFunction (RC function)",{ - RCF1 <- nimbleFunction( - run = function(x = double(1)) { - ans <- sum(x) - return(ans) - returnType(double()) - } - ) - CRCF1 <- nCompiler:::compileNimble(RCF1) - expect_equal(CRCF1(1:3), 6) -}) - -test_that("compileNimble bridge works for one nimbleFunction object", { - nf <- nimbleFunction( - setup = function() {x <- 1:2}, - run = function() {return(x[1]); returnType(double())} - ) - nf1 <- nf() - Cnf1 <- nCompiler:::compileNimble(nf1) - expect_identical(Cnf1$x, 1:2) - - nf <- nimbleFunction( - setup = function() {x <- 2:3}, - run = function(mult = double(0)) { - return(myfun(mult)); returnType(double()) - }, - methods = list( - myfun = function(mult = double(0)) { - return(x[1]*mult); returnType(double()) - } - ) - ) - nf1 <- nf() - Cnf1 <- nCompiler:::compileNimble(nf1) - expect_identical(Cnf1$run(3), 6) -}) - -test_that("compileNimble bridge works for two nimbleFunction objects", { - nf1 <- nimbleFunction( - run = function(x = double(0)) { - return(nf2(x)) - returnType(double(0)) - }) - nf2 <- nimbleFunction( - run = function(x = double(0)) { - return(3*x) - returnType(double(0)) - }) - Cnfs <- nCompiler:::compileNimble(nf1,nf2) - expect_identical(Cnfs[[1]](5), 15) - -}) - -## NEXT STEPS: -## get a custom handler working -## try a test file from nimble using nClass -## add nClass to nCompiler:::compileNimble -## -## document, document, document - - -test <- nClass( - Cpublic = list( - x = nTypeBasic(name = "x", scalarType = "integer", nDim = 1) - ) -) -ctest <- nCompile(test) From 64eec8d536fe1c3f18136ae3ff0c5c4b21c511f5 Mon Sep 17 00:00:00 2001 From: perrydv Date: Sun, 30 Aug 2026 19:42:45 -0700 Subject: [PATCH 19/19] remove compileNimble tests (moved to nimble2) --- .github/workflows/test-all.yaml | 6 ++-- .../nCompile_tests/test-compileNimble.R | 35 ------------------- 2 files changed, 3 insertions(+), 38 deletions(-) delete mode 100644 nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R diff --git a/.github/workflows/test-all.yaml b/.github/workflows/test-all.yaml index 074e17ce..82979671 100644 --- a/.github/workflows/test-all.yaml +++ b/.github/workflows/test-all.yaml @@ -42,7 +42,7 @@ jobs: - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline - run: R -q -e 'remotes::install_cran(c("inline", "nimble"))' + run: R -q -e 'remotes::install_cran(c("inline"))' - name: Build Package run: | R CMD build nCompiler @@ -94,7 +94,7 @@ jobs: - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline - run: R -q -e 'remotes::install_cran(c("inline", "nimble"))' + run: R -q -e 'remotes::install_cran(c("inline"))' - name: Build Package run: | R CMD build nCompiler @@ -148,7 +148,7 @@ jobs: - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline - run: R -q -e 'remotes::install_cran(c("inline", "nimble"))' + run: R -q -e 'remotes::install_cran(c("inline"))' - name: Build Package run: | R CMD build nCompiler diff --git a/nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R b/nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R deleted file mode 100644 index b90c4cd1..00000000 --- a/nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R +++ /dev/null @@ -1,35 +0,0 @@ -## Support for bridging nimble's compileNimble to nCompile -## Only basic tests will be here. -## The real tests will be running nimble's test suite. - -library(nimble) -#library(nCompiler) -library(testthat) - -test_that("compileNimble bridge works for simple nimbleFunction (RC function)",{ - RCF1 <- nimbleFunction( - run = function(x = double(1)) { - ans <- sum(x) - return(ans) - returnType(double()) - } - ) - CRCF1 <- `:::`("nCompiler", "compileNimble")(RCF1) - expect_equal(CRCF1(1:3), 6) -}) - -test_that("compileNimble bridge works for one nimbleFunction object", { - nf <- nimbleFunction( - setup = function() {x <- 1:2}, - run = function() {return(x[1]); returnType(double())} - ) - nf1 <- nf() - Cnf1 <- compileNimble(nf1) - expect_identical(Cnf1$x, 1:2) -}) -## NEXT STEPS: -## get a custom handler working -## try a test file from nimble using nClass -## add nClass to nCompiler:::compileNimble -## -## document, document, document