fix for left-over '*tmp*' object

git-svn-id: https://svn.r-project.org/R/trunk@39455 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Sep 21, 2006 · 99f62dd · 99f62dd
1 parent d2baf2b
commit 99f62dd
Show file tree

Hide file tree

Showing 4 changed files with 30 additions and 4 deletions.
diff --git a/NEWS b/NEWS
@@ -935,6 +935,9 @@ BUG FIXES
 	and bxp(), and they behaved differently.  Now those passed in
 	'...' have precedence in both cases.
 
+    o	A failed subassignment could leave behind an object '*tmp*'.
+	The fix also sometimes gives better error messages.
+
 
 
 

diff --git a/src/main/eval.c b/src/main/eval.c
@@ -1231,12 +1231,18 @@ static SEXP evalseq(SEXP expr, SEXP rho, int forcelocal,  R_varloc_t tmploc)
 
 static const char * const asym[] = {":=", "<-", "<<-", "="};
 
+static void tmp_cleanup(void *data)
+{
+    unbindVar(R_TmpvalSymbol, (SEXP) data);
+}
+
 
 static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
     SEXP expr, lhs, rhs, saverhs, tmp, tmp2;
     R_varloc_t tmploc;
     char buf[32];
+    RCNTXT cntxt;
 
     expr = CAR(args);
 
@@ -1266,6 +1272,13 @@ static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
 	errorcall(call, _("cannot do complex assignments in base environment"));
     defineVar(R_TmpvalSymbol, R_NilValue, rho);
     tmploc = R_findVarLocInFrame(rho, R_TmpvalSymbol);
+    /* Now set up a context to remove it when we are done, even in the
+     * case of an error.  This all helps error() provide a better call.
+     */
+    begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
+		 R_NilValue, R_NilValue);
+    cntxt.cend = &tmp_cleanup;
+    cntxt.cenddata = rho;
 
     /*  Do a partial evaluation down through the LHS. */
     lhs = evalseq(CADR(expr), rho,
@@ -1306,6 +1319,7 @@ static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
 			      CDDR(expr), tmp));
     expr = eval(expr, rho);
     UNPROTECT(5);
+    endcontext(&cntxt); /* which does not run the remove */
     unbindVar(R_TmpvalSymbol, rho);
 #ifdef CONSERVATIVE_COPYING
     return duplicate(saverhs);
@@ -1317,7 +1331,7 @@ static SEXP applydefine(SEXP call, SEXP op, SEXP args, SEXP rho)
 #endif
 }
 
-/* Defunct in in 1.5.0
+/* Defunct in 1.5.0
 SEXP attribute_hidden do_alias(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
     checkArity(op,args);

diff --git a/tests/reg-tests-1.R b/tests/reg-tests-1.R
@@ -4486,3 +4486,11 @@ stopifnot(!identical(pairlist(a=1, b=2), pairlist(a=1, aa=2)))
 stopifnot(!identical(structure(pi, a=1, b=2), structure(pi, a=1, aa=2)))
 stopifnot(identical(structure(pi, a=1, b=2), structure(pi, b=2, a=1)))
 ## ignored names of pairlists, but tested order of attributes < 2.4.0
+
+
+## failed subassign could leave '*tmp*' around
+## Parlamis Franklin, R-devel, 2006-09-20
+test <- 1:10
+try(test[2:4] <- expression(e)) # failed at least in 2.4.0
+stopifnot(!exists("*tmp*", where=1))
+## was true < 2.4.0
diff --git a/tests/reg-tests-2.Rout.save b/tests/reg-tests-2.Rout.save
@@ -1,5 +1,5 @@
 
-R version 2.5.0 Under development (unstable) (2006-09-19 r39398)
+R version 2.5.0 Under development (unstable) (2006-09-21 r39451)
 Copyright (C) 2006 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
@@ -4730,9 +4730,10 @@ out-of-range values treated as 0 in coercion to raw
 [1] 2 2
 > # but not allowed
 > try(df2[df2 == 2] <- 1:2)
-Error: NAs are not allowed in subscripted assignments
+Error in x[[v]][thisvar] <- if (N > 1) value[n + (1:nv)] else value : 
+	NAs are not allowed in subscripted assignments
 > try(m2[m2 == 2] <- 1:2)
-Error in try(m2[m2 == 2] <- 1:2) : NAs are not allowed in subscripted assignments
+Error in m2[m2 == 2] <- 1:2 : NAs are not allowed in subscripted assignments
 > ##
 > 
 >