[education/rkward] /: Move shadows to a sane location, start removing active binding code.
Thomas Friedrichsmeier
null at kde.org
Thu May 26 10:06:45 BST 2022
Git commit 5f04fe6a16f0d96c2b97377d372aaacc70ff98dd by Thomas Friedrichsmeier.
Committed on 23/05/2020 at 21:27.
Pushed by tfry into branch 'master'.
Move shadows to a sane location, start removing active binding code.
M +1 -1 VERSION.cmake
M +1 -11 rkward/rbackend/rkrbackend.cpp
M +22 -8 rkward/rbackend/rkrsupport.cpp
M +1 -0 rkward/rbackend/rkrsupport.h
M +1 -1 rkward/rbackend/rpackages/rkward/DESCRIPTION
M +1 -68 rkward/rbackend/rpackages/rkward/R/internal.R
https://invent.kde.org/education/rkward/commit/5f04fe6a16f0d96c2b97377d372aaacc70ff98dd
diff --git a/VERSION.cmake b/VERSION.cmake
index 8a71a415..b2c0d6cb 100644
--- a/VERSION.cmake
+++ b/VERSION.cmake
@@ -1,3 +1,3 @@
# DO NOT CHANGE THIS FILE MANUALLY!
# It will be overwritten by scripts/set_dist_version.sh
-SET(RKVERSION_NUMBER 0.7.1z+0.7.2+devel2)
+SET(RKVERSION_NUMBER 0.7.1z+0.7.2+devel3)
diff --git a/rkward/rbackend/rkrbackend.cpp b/rkward/rbackend/rkrbackend.cpp
index 11da3242..d9b2420c 100644
--- a/rkward/rbackend/rkrbackend.cpp
+++ b/rkward/rbackend/rkrbackend.cpp
@@ -928,14 +928,6 @@ SEXP doError (SEXP call) {
return R_NilValue;
}
-SEXP doWs (SEXP name) {
- if ((!RKRBackend::this_pointer->current_command) || (RKRBackend::this_pointer->current_command->type & RCommand::ObjectListUpdate) || (!(RKRBackend::this_pointer->current_command->type & RCommand::Sync))) { // ignore Sync commands that are not flagged as ObjectListUpdate
- QString sym = RKRSupport::SEXPToString(name);
- if (!RKRBackend::this_pointer->changed_symbol_names.contains (sym)) RKRBackend::this_pointer->changed_symbol_names.append (sym); // schedule symbol update for later
- }
- return R_NilValue;
-}
-
SEXP doSubstackCall (SEXP call) {
RK_TRACE (RBACKEND);
@@ -1043,7 +1035,6 @@ SEXP doCaptureOutput (SEXP mode, SEXP capture_messages, SEXP capture_output, SEX
SEXP RKStartGraphicsDevice (SEXP width, SEXP height, SEXP pointsize, SEXP family, SEXP bg, SEXP title, SEXP antialias);
SEXP RKD_AdjustSize (SEXP devnum);
-SEXP doWs (SEXP name);
void doPendingPriorityCommands ();
SEXP checkEnv(SEXP a) {
@@ -1123,7 +1114,7 @@ bool RKRBackend::startR () {
// register our functions
R_CallMethodDef callMethods [] = {
// NOTE: Intermediate cast to void* to avoid compiler warning
- { "ws", (DL_FUNC) (void*) &doWs, 1 },
+ { "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 },
{ "rk.do.error", (DL_FUNC) (void*) &doError, 1 },
{ "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 1 },
{ "rk.do.generic.request", (DL_FUNC) (void*) &doPlainGenericRequest, 2 },
@@ -1138,7 +1129,6 @@ bool RKRBackend::startR () {
{ "rk.capture.output", (DL_FUNC) (void*) &doCaptureOutput, 5 },
{ "rk.graphics.device", (DL_FUNC) (void*) &RKStartGraphicsDevice, 7},
{ "rk.graphics.device.resize", (DL_FUNC) (void*) &RKD_AdjustSize, 1},
- { "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 },
{ 0, 0, 0 }
};
R_registerRoutines (R_getEmbeddingDllInfo(), NULL, callMethods, NULL, NULL);
diff --git a/rkward/rbackend/rkrsupport.cpp b/rkward/rbackend/rkrsupport.cpp
index 97a39335..f4c0129f 100644
--- a/rkward/rbackend/rkrsupport.cpp
+++ b/rkward/rbackend/rkrsupport.cpp
@@ -249,15 +249,29 @@ RData *RKRSupport::SEXPToRData (SEXP from_exp) {
return data;
}
+SEXP RKRShadowEnvironment::shadowenvbase = nullptr;
QMap<SEXP, RKRShadowEnvironment*> RKRShadowEnvironment::environments;
RKRShadowEnvironment* RKRShadowEnvironment::environmentFor(SEXP baseenvir) {
+ // TODO: probably R_GlobalEnv should be special-cased, as this is what we'll check most often (or exclusively?)
if (!environments.contains(baseenvir)) {
- // TODO: Of course this is still wrong!
-Rprintf("new shadow environment for %p\n", baseenvir);
- SEXP tr = Rf_allocVector(INTSXP, 1);
- INTEGER (tr)[0] = TRUE;
- Rf_defineVar(Rf_install("shadow_hide_me"), RKRSupport::callSimpleFun2(Rf_install("new.env"), tr, R_EmptyEnv, R_GlobalEnv), R_GlobalEnv);
- SEXP shadowenvir = Rf_findVar(Rf_install("shadow_hide_me"), R_GlobalEnv);
+ RK_DEBUG(RBACKEND, DL_DEBUG, "creating new shadow environment for %p\n", baseenvir);
+ if (!shadowenvbase) {
+ SEXP rkn = Rf_allocVector(STRSXP, 1);
+ SET_STRING_ELT(rkn, 0, Rf_mkChar("package:rkward"));
+ SEXP rkwardenv = RKRSupport::callSimpleFun(Rf_install("as.environment"), rkn, R_GlobalEnv);
+ RK_ASSERT(Rf_isEnvironment(rkwardenv));
+ SEXP rkwardvars = Rf_eval(Rf_findVar(Rf_install(".rk.variables"), rkwardenv), R_BaseEnv); // NOTE: Rf_eval to resolve promise
+ RK_ASSERT(Rf_isEnvironment(rkwardvars));
+ shadowenvbase = Rf_findVar(Rf_install(".rk.shadow.envs"), rkwardvars);
+ RK_ASSERT(Rf_isEnvironment(shadowenvbase));
+ }
+
+ char name[sizeof(void*)*2+3];
+ sprintf(name, "%p", baseenvir);
+ SEXP tr = Rf_allocVector(LGLSXP, 1);
+ LOGICAL(tr)[0] = true;
+ Rf_defineVar(Rf_install(name), RKRSupport::callSimpleFun2(Rf_install("new.env"), tr, R_EmptyEnv, R_GlobalEnv), shadowenvbase);
+ SEXP shadowenvir = Rf_findVar(Rf_install(name), shadowenvbase);
environments.insert(baseenvir, new RKRShadowEnvironment(baseenvir, shadowenvir));
}
return environments[baseenvir];
@@ -303,7 +317,7 @@ QStringList RKRShadowEnvironment::diffAndUpdate() {
UNPROTECT(2);
- Rprintf("changed %s\n", qPrintable(diffs.join(", ")));
- Rprintf("removed %s\n", qPrintable(removed.join(", ")));
+ RK_DEBUG(RBACKEND, DL_DEBUG, "changed %s\n", qPrintable(diffs.join(", ")));
+ RK_DEBUG(RBACKEND, DL_DEBUG, "removed %s\n", qPrintable(removed.join(", ")));
return diffs + removed;
}
diff --git a/rkward/rbackend/rkrsupport.h b/rkward/rbackend/rkrsupport.h
index c73920ef..0dd827af 100644
--- a/rkward/rbackend/rkrsupport.h
+++ b/rkward/rbackend/rkrsupport.h
@@ -53,6 +53,7 @@ private:
SEXP baseenvir;
SEXP shadowenvir;
static QMap<SEXP, RKRShadowEnvironment*> environments;
+ static SEXP shadowenvbase;
};
#endif
diff --git a/rkward/rbackend/rpackages/rkward/DESCRIPTION b/rkward/rbackend/rpackages/rkward/DESCRIPTION
index 674c29c5..c9c37380 100755
--- a/rkward/rbackend/rpackages/rkward/DESCRIPTION
+++ b/rkward/rbackend/rpackages/rkward/DESCRIPTION
@@ -18,7 +18,7 @@ Authors at R: c(person(given="Thomas", family="Friedrichsmeier",
role=c("aut")), person(given="the RKWard team",
email="rkward-devel at kde.org", role=c("cre","ctb")))
Version: 0.7.2
-Date: 2020-04-02
+Date: 2020-05-23
RoxygenNote: 6.1.0
Collate:
'base_overrides.R'
diff --git a/rkward/rbackend/rpackages/rkward/R/internal.R b/rkward/rbackend/rpackages/rkward/R/internal.R
index 1601bc13..3b0e4764 100755
--- a/rkward/rbackend/rpackages/rkward/R/internal.R
+++ b/rkward/rbackend/rpackages/rkward/R/internal.R
@@ -222,74 +222,6 @@
# .Internal (.addCondHands (c ("message", "warning", "error"), list (function (m) { .Call ("rk.do.condition", c ("m", conditionMessage (m))) }, function (w) { .Call ("rk.do.condition", c ("w", conditionMessage (w))) }, function (e) { .Call ("rk.do.condition", c ("e", conditionMessage (e))) }), globalenv (), NULL, TRUE))
#}
-# these functions can be used to track assignments to R objects. The main interfaces are .rk.watch.symbol (k) and .rk.unwatch.symbol (k). This works by copying the symbol to a local environment, removing it, and replacing it by an active binding to the backup location
-".rk.watched.symbols" <- new.env ()
-
-#' @export
-".rk.make.watch.f" <- function (k) {
- # we need to make sure, the functions we use are *not* looked up as symbols in .GlobalEnv.
- # else, for instance, if the user names a symbol "missing", and we try to resolve it in the
- # wrapper function below, evaluation would recurse to look up "missing" in the .GlobalEnv
- # due to the call to "if (!missing(value))".
- missing <- base::missing
- .Call <- base::.Call
-
- # NOTE: - Another _small_ speedup (~10%) _could_ be achieved by pre-compiling the returned function (compiler::cmpfun()).
- # - Limiting the .Call()s (by keeping/clearing a flag of whether change has been signalled, before) does not have any measurable effect, but adds complexity
- function (value) {
- if (missing (value)) {
- x
- } else {
- .Call ("ws", k, PACKAGE="(embedding)");
- x <<- value
- }
- }
-}
-
-#' @export
-".rk.watch.symbol" <- function (k) {
- if (bindingIsActive(k, globalenv())) {
- # If the symbol already is an active binding, give up for now, as there is not currently a user-accessible way to copy an active binding (not just its value)
- message("Note: RKWard cannot watch active binding ", k, " for changes.")
- } else {
- f <- .rk.make.watch.f (k)
- .Call ("rk.copy.no.eval", k, globalenv(), "x", environment (f), PACKAGE="(embedding)");
- rm (list=k, envir=globalenv ())
- .rk.makeActiveBinding.default (k, f, globalenv ())
- }
- .rk.watched.symbols[[k]] <- TRUE
-
- invisible (TRUE)
-}
-
-# not needed by rkward but provided for completeness
-#' @export
-".rk.unwatch.symbol" <- function (k) {
- x <- get(k, envir=globalenv ())
- rm (list=k, envir=globalenv ())
- assign (k, x, envir=globalenv ())
- rm (k, envir=.rk.watched.symbols);
-
- invisible (TRUE)
-}
-
-#' @export
-".rk.watch.globalenv" <- function () {
- newlist <- ls (globalenv (), all.names=TRUE)
- oldlist <- ls (.rk.watched.symbols, all.names=TRUE)
- for (old in oldlist) { # unwatch no longer present items
- if (!(old %in% newlist)) {
- rm (list=old, envir=.rk.watched.symbols);
- }
- }
-
- for (new in newlist) { # watch new items
- if (!(new %in% oldlist)) {
- .rk.watch.symbol (new)
- }
- }
-}
-
#' @export
".rk.get.vector.data" <- function (x) {
ret <- list ();
@@ -388,6 +320,7 @@ assign(".rk.active.device", 1, envir=.rk.variables)
assign(".rk.output.html.file", NULL, envir=.rk.variables)
assign(".rk.rkreply", NULL, envir=.rk.variables)
assign("available.packages.cache", NULL, envir=.rk.variables)
+assign(".rk.shadow.envs", new.env(parent=emptyenv()), envir=.rk.variables)
#' @export
".rk.backups" <- new.env ()
More information about the rkward-tracker
mailing list