Commit 7a436a43 authored by Thomas Friedrichsmeier's avatar Thomas Friedrichsmeier
Browse files

Add test for new object modification mechanism

parent a873b072
Pipeline #180990 passed with stage
in 11 minutes and 30 seconds
......@@ -916,13 +916,12 @@ void doError (const QString &callstring) {
}
}
SEXP doSubstackCall (SEXP call) {
SEXP doSubstackCall (SEXP _call, SEXP _args) {
RK_TRACE (RBACKEND);
R_CheckUserInterrupt ();
QStringList list = RKRSupport::SEXPToStringList (call);
QString call = RKRSupport::SEXPToStringList(_call).value(0);
/* // this is a useful place to sneak in test code for profiling
if (list.value (0) == "testit") {
for (int i = 10000; i >= 1; --i) {
......@@ -931,9 +930,8 @@ SEXP doSubstackCall (SEXP call) {
return R_NilValue;
} */
QStringList args;
if (list.size() > 1) args = list.mid(1);
auto ret = RKRBackend::this_pointer->handleRequestWithSubcommands(list.value(0), args);
// For now, for simplicity, assume args are always strings, although possibly nested in lists
auto ret = RKRBackend::this_pointer->handleRequestWithSubcommands(call, RKRSupport::SEXPToNestedStrings(_args));
if (!ret.warning.isEmpty()) Rf_warning(RKRBackend::fromUtf8(ret.warning)); // print warnings, first, as errors will cause a stop
if (!ret.error.isEmpty()) Rf_error(RKRBackend::fromUtf8(ret.error));
......@@ -1138,7 +1136,7 @@ bool RKRBackend::startR () {
// NOTE: Intermediate cast to void* to avoid compiler warning
{ "rk.check.env", (DL_FUNC) (void*) &checkEnv, 1 },
{ "rk.simple", (DL_FUNC) (void*) &doSimpleBackendCall, 1},
{ "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 1 },
{ "rk.do.command", (DL_FUNC) (void*) &doSubstackCall, 2 },
{ "rk.do.generic.request", (DL_FUNC) (void*) &doPlainGenericRequest, 2 },
{ "rk.get.structure", (DL_FUNC) (void*) &doGetStructure, 4 },
{ "rk.get.structure.global", (DL_FUNC) (void*) &doGetGlobalEnvStructure, 3 },
......
/*
rkrsupport - This file is part of RKWard (https://rkward.kde.org). Created: Mon Oct 25 2010
SPDX-FileCopyrightText: 2010-2020 by Thomas Friedrichsmeier <thomas.friedrichsmeier@kdemail.net>
SPDX-FileCopyrightText: 2010-2022 by Thomas Friedrichsmeier <thomas.friedrichsmeier@kdemail.net>
SPDX-FileContributor: The RKWard Team <rkward-devel@kde.org>
SPDX-License-Identifier: GPL-2.0-or-later
*/
......@@ -163,6 +163,19 @@ SEXP RKRSupport::QVariantToSEXP(const QVariant& var) {
return ret;
}
QVariant RKRSupport::SEXPToNestedStrings(SEXP from_exp) {
RK_TRACE (RBACKEND);
if (Rf_isList(from_exp)) {
QVariantList ret;
for(SEXP cons = from_exp; cons != R_NilValue; cons = CDR(cons)) {
SEXP el = CAR(cons);
ret.append(SEXPToNestedStrings(el));
}
return ret;
}
return QVariant(SEXPToStringList(from_exp));
}
RData::IntStorage RKRSupport::SEXPToIntArray (SEXP from_exp) {
RK_TRACE (RBACKEND);
......@@ -361,7 +374,7 @@ RKRShadowEnvironment::Result RKRShadowEnvironment::diffAndUpdate() {
if (main == R_UnboundValue) {
res.removed.append(RKRSupport::SEXPToString(name));
R_removeVarFromFrame(name, shadowenvir);
if (++count >= count2) break;
if (++count >= count2) i = count2; // end loop
}
UNPROTECT(1);
}
......
/*
rkrsupport - This file is part of the RKWard project. Created: Mon Oct 25 2010
SPDX-FileCopyrightText: 2010-2020 by Thomas Friedrichsmeier <thomas.friedrichsmeier@kdemail.net>
SPDX-FileCopyrightText: 2010-2022 by Thomas Friedrichsmeier <thomas.friedrichsmeier@kdemail.net>
SPDX-FileContributor: The RKWard Team <rkward-devel@kde.org>
SPDX-License-Identifier: GPL-2.0-or-later
*/
......@@ -28,6 +28,7 @@ namespace RKRSupport {
QStringList SEXPToStringList (SEXP from_exp);
SEXP StringListToSEXP (const QStringList &list);
SEXP QVariantToSEXP(const QVariant &val);
QVariant SEXPToNestedStrings(SEXP from_exp);
QString SEXPToString (SEXP from_exp);
RData::IntStorage SEXPToIntArray (SEXP from_exp);
int SEXPToInt (SEXP from_exp, int def_value = INT_MIN);
......
......@@ -18,7 +18,7 @@ Authors@R: c(person(given="Thomas", family="Friedrichsmeier",
role=c("aut")), person(given="the RKWard team",
email="rkward-devel@kde.org", role=c("cre","ctb")))
Version: 0.7.5
Date: 2022-05-22
Date: 2022-05-26
RoxygenNote: 7.1.2
Collate:
'base_overrides.R'
......
......@@ -122,7 +122,7 @@
}
".rk.do.call" <- function (x, args=NULL) {
x <- .Call ("rk.do.command", c (x, args), PACKAGE="(embedding)");
x <- .Call ("rk.do.command", x, args, PACKAGE="(embedding)");
if (is.null(x)) invisible(NULL)
else x
}
......@@ -351,3 +351,11 @@ assign(".rk.shadow.envs", new.env(parent=emptyenv()), envir=.rk.variables)
# call separate assignments functions:
if (exists (".rk.fix.assignments.graphics")) eval (body (.rk.fix.assignments.graphics)) # internal_graphics.R
}
# Checks which objects have been added, removed, or changed since the last time, this function was called on the given environment.
# This is mostly provided for testing purposes (and not currently exported), but speak up, if you think it is useful beyond internal use.
"rk.check.env.changes" <- function(env) {
ret <- .Call("rk.check.env", env, PACKAGE="(embedding)")
names(ret) <- c("added", "removed", "changed")
ret
}
......@@ -29,12 +29,12 @@
#' @export
"rk.sync" <- function (x) {
object <- deparse (substitute (x))
.rk.do.call ("sync", object)
.rk.do.call("sync", list(NULL, NULL, object))
}
# should this really be public?
#' @export
#' @rdname rk.sync
"rk.sync.global" <- function () {
.rk.do.call("syncglobal", ls (envir=globalenv (), all.names=TRUE))
.rk.do.call("sync", rk.check.env.changes(globalenv()))
}
......@@ -21,10 +21,30 @@ suite <- new ("RKTestSuite", id="rkward_application_tests",
.GlobalEnv$active.binding.value <- 123
stopifnot (.GlobalEnv$active.binding == 123)
stopifnot (isTRUE(rkward:::.rk.watched.symbols$active.binding))
# NOTE: the message "active.binding" should be displayed in the message output
}),
new ("RKTest", id="object_modifications", call=function () {
env <- new.env()
for (a in letters) {
for (b in letters) {
for (c in letters) {
assign(paste0(a, b, c), 1, pos=env);
}
}
}
assign(paste0("lll", 0), 1, pos=env);
rkward:::rk.check.env.changes(env)
res <- system.time({
for (i in 1:5) {
env$lll <- env$lll + 1
assign(paste0("lll", i), 1, pos=env);
rm(list=paste0("lll", i-1), pos=env);
rk.print(rkward:::rk.check.env.changes(env))
}
})
# this is really crude, and might give false positives, but the idea is trying to catch potential performance regressions
stopifnot(res[1] < 0.5)
}),
new ("RKTest", id="promise_in_globalenv", call=function () {
.GlobalEnv$promised.value <- 1
delayedAssign ("promise.symbol", { message ("delayed assign"); promised.value }, eval.env=.GlobalEnv, assign.env=.GlobalEnv)
......
<p class='character'><hr class='hr'></p>
<ul>
</center><li>
<p class='character'>lll1</p>
</ul>
<ul>
</center><li>
<p class='character'>lll0</p>
</ul>
<ul>
</center><li>
<p class='character'>lll</p>
</ul>
<br><hr class='hr'>
<p class='character'><hr class='hr'></p>
<ul>
</center><li>
<p class='character'>lll2</p>
</ul>
<ul>
</center><li>
<p class='character'>lll1</p>
</ul>
<ul>
</center><li>
<p class='character'>lll</p>
</ul>
<br><hr class='hr'>
<p class='character'><hr class='hr'></p>
<ul>
</center><li>
<p class='character'>lll3</p>
</ul>
<ul>
</center><li>
<p class='character'>lll2</p>
</ul>
<ul>
</center><li>
<p class='character'>lll</p>
</ul>
<br><hr class='hr'>
<p class='character'><hr class='hr'></p>
<ul>
</center><li>
<p class='character'>lll4</p>
</ul>
<ul>
</center><li>
<p class='character'>lll3</p>
</ul>
<ul>
</center><li>
<p class='character'>lll</p>
</ul>
<br><hr class='hr'>
<p class='character'><hr class='hr'></p>
<ul>
</center><li>
<p class='character'>lll5</p>
</ul>
<ul>
</center><li>
<p class='character'>lll4</p>
</ul>
<ul>
</center><li>
<p class='character'>lll</p>
</ul>
<br><hr class='hr'>
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment