use backticks more consistently when deparsing.

fix PR#9216: the loop variable in a for() loop was not readonly for a list.


git-svn-id: https://svn.r-project.org/R/trunk@39252 00db46b3-68df-0310-9c12-caf00c1e9a41

NEWS

@@ -826,6 +826,13 @@ BUG FIXES
 
     o	[.acf now handles an empty first index.
 
+    o	Deparsing uses backticks more consistently to quote
+	non-syntactic names.
+
+    o	Assigning to the symbol in a for() loop with a
+	list/expression/pairlist index could alter the index.  Now the
+	loop variable is explicitly read-only.  (PR#9216)
+
 
 
 

src/library/base/man/Control.Rd

@@ -39,10 +39,10 @@ next
 }
 \details{
   \code{break} breaks out of a \code{for}, \code{while} or \code{repeat}
-  loop; control is transferred to the first statement outside the inner-most loop.
-  \code{next} halts the processing of the current iteration and advances the
-  looping index. Both \code{break} and \code{next} apply only to the innermost 
-  of nested loops.
+  loop; control is transferred to the first statement outside the
+  inner-most loop. \code{next} halts the processing of the current
+  iteration and advances the looping index.  Both \code{break} and
+  \code{next} apply only to the innermost of nested loops.
 
   Note that it is a common mistake to forget to put braces (\code{\{ .. \}})
   around your statements, e.g., after \code{if(..)} or \code{for(....)}.
@@ -54,9 +54,10 @@ next
 
   The index \code{seq} in a \code{for} loop is evaluated at the start of
   the loop; changing it subsequently does not affect the loop.  The
-  variable \code{var} has the same type as \code{seq}.  If \code{seq} is
-  a factor (which is not strictly allowed) then its internal codes are
-  used: the effect is that of \code{\link{as.integer}} not
+  variable \code{var} has the same type as \code{seq}, and is read-only:
+  assigning to it does not alter \code{seq}.  If \code{seq} is a factor
+  (which is not strictly allowed) then its internal codes are used: the
+  effect is that of \code{\link{as.integer}} not
   \code{\link{as.vector}}.
 }
 \value{

src/main/deparse.c

@@ -370,7 +370,7 @@ SEXP attribute_hidden do_dump(SEXP call, SEXP op, SEXP args, SEXP rho)
 		SET_STRING_ELT(outnames, nout++, STRING_ELT(names, i));
 		/* figure out if we need to quote the name */
 		if(!isValidName(obj_name))
-		    Rprintf("\"%s\" <-\n", obj_name);
+		    Rprintf("`%s` <-\n", obj_name);
 		else
 		    Rprintf("%s <-\n", obj_name);
 		tval = deparse1(CAR(o), 0, opts);
@@ -387,7 +387,7 @@ SEXP attribute_hidden do_dump(SEXP call, SEXP op, SEXP args, SEXP rho)
 	    for (i = 0, nout = 0; i < nobjs; i++) {
 		if (CAR(o) == R_UnboundValue) continue;
 		SET_STRING_ELT(outnames, nout++, STRING_ELT(names, i));
-		res = Rconn_printf(con, "\"%s\" <-\n", 
+		res = Rconn_printf(con, "`%s` <-\n", 
 				   CHAR(STRING_ELT(names, i)));
 		if(!havewarned &&
 		   res < strlen(CHAR(STRING_ELT(names, i))) + 4)
@@ -976,9 +976,9 @@ static void deparse2buff(SEXP s, LocalParseData *d)
 		    print2buff("next", d);
 		    break;
 		case PP_SUBASS:
-		    print2buff("\"", d);
+		    print2buff("`", d);
 		    print2buff(CHAR(PRINTNAME(op)), d);
-		    print2buff("\"(", d);
+		    print2buff("`(", d);
 		    args2buff(s, 0, 0, d);
 		    print2buff(")", d);
 		    break;
@@ -1028,9 +1028,9 @@ static void deparse2buff(SEXP s, LocalParseData *d)
 			if ( isSymbol(CAR(s)) ){
 			    if ( !isValidName(CHAR(PRINTNAME(CAR(s)))) ){
 
-				print2buff("\"", d);
+				print2buff("`", d);
 				print2buff(CHAR(PRINTNAME(CAR(s))), d);
-				print2buff("\"", d);
+				print2buff("`", d);
 			    } else
 				print2buff(CHAR(PRINTNAME(CAR(s))), d);
 			}

src/main/eval.c

@@ -914,9 +914,9 @@ SEXP attribute_hidden do_if(SEXP call, SEXP op, SEXP args, SEXP rho)
 
 SEXP attribute_hidden do_for(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
-    int dbg;
+    int dbg, nprotect = 5;
     volatile int i, n, bgn;
-    SEXP sym, body;
+    SEXP sym, body, val0, el;
     volatile SEXP ans, v, val;
     RCNTXT cntxt;
     PROTECT_INDEX vpi, api;
@@ -941,6 +941,36 @@ SEXP attribute_hidden do_for(SEXP call, SEXP op, SEXP args, SEXP rho)
     }
     ans = R_NilValue;
 
+
+    if(NAMED(val) > 0) {
+	/* If we have a list, we want to protect ourselves against the
+	 * body of the loop assigning to the element.  So we make a
+	 * shallow copy here */
+	switch(TYPEOF(val)) {
+	case EXPRSXP:
+	case VECSXP:
+	    val0 = val;
+	    PROTECT(val = allocVector(TYPEOF(val0), n)); nprotect++;
+	    for(i = 0; i < n; i++) {
+		el = VECTOR_ELT(val0, i);
+		SET_NAMED(el, 2);
+		SET_VECTOR_ELT(val, i, el);
+	    }
+	    break;
+	case LISTSXP:
+	    val0 = val;
+	    PROTECT(val = allocList(n)); nprotect++;
+	    for(el = val; CDR(val0) != R_NilValue; 
+		val0 = CDR(val0), el = CDR(el)){
+		SET_NAMED(CAR(val0), 2);
+		SETCAR(el, CAR(val0));
+	    }
+	    break;
+	default:
+	    ;
+	}
+    }
+
     dbg = DEBUG(rho);
     bgn = BodyHasBraces(body);
 
@@ -992,15 +1022,16 @@ SEXP attribute_hidden do_for(SEXP call, SEXP op, SEXP args, SEXP rho)
 	    setVar(sym, CAR(val), rho);
 	    val = CDR(val);
 	    break;
-	default: errorcall(call, _("invalid for() loop sequence"));
+	default:
+	    errorcall(call, _("invalid for() loop sequence"));
 	}
 	REPROTECT(ans = eval(body, rho), api);
     for_next:
-	; /* needed for strict ISO C compilance, according to gcc 2.95.2 */
+	; /* needed for strict ISO C compliance, according to gcc 2.95.2 */
     }
  for_break:
     endcontext(&cntxt);
-    UNPROTECT(5);
+    UNPROTECT(nprotect);
     R_Visible = 0;
     SET_DEBUG(rho, dbg);
     return ans;

tests/method-dispatch.Rout.save

@@ -1,17 +1,19 @@
 
-R : Copyright 2003, The R Development Core Team
-Version 1.8.0 Under development (unstable) (2003-07-02)
+R version 2.5.0 Under development (unstable) (2006-09-11 r39251)
+Copyright (C) 2006 The R Foundation for Statistical Computing
+ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
 You are welcome to redistribute it under certain conditions.
-Type `license()' or `licence()' for distribution details.
+Type 'license()' or 'licence()' for distribution details.
 
 R is a collaborative project with many contributors.
-Type `contributors()' for more information.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
 
-Type `demo()' for some demos, `help()' for on-line help, or
-`help.start()' for a HTML browser interface to help.
-Type `q()' to quit R.
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
 
 > #### Testing  UseMethod() and even more NextMethod()
 > ####
@@ -34,19 +36,19 @@ Type `q()' to quit R.
 > ## The next 4 give a warning each about incompatible methods:
 > x > y
 [1] FALSE FALSE  TRUE
-Warning message: 
+Warning message:
 Incompatible methods (">.foo", ">.bar") for ">" 
 > y < x # should be the same (warning msg not, however)
 [1] FALSE FALSE  TRUE
-Warning message: 
+Warning message:
 Incompatible methods ("Ops.bar", "Ops.foo") for "<" 
 > x == y
 [1] FALSE  TRUE FALSE
-Warning message: 
+Warning message:
 Incompatible methods ("Ops.foo", "Ops.bar") for "==" 
 > x <= y
 [1]  TRUE  TRUE FALSE
-Warning message: 
+Warning message:
 Incompatible methods ("Ops.foo", "Ops.bar") for "<=" 
 > 
 > x > 3 ##[1] ">.foo"
@@ -90,7 +92,7 @@ abc: Before dispatching; x has class `expression':  expression(sin(x))
 'expression' method of abc: abc.expression(e1) 
 > abc(e0[[1]])
 abc: Before dispatching; x has class `(': language, mode "(": (x)
-'(' method of abc: "abc.("(e0[[1]]) 
+'(' method of abc: `abc.(`(e0[[1]]) 
 > abc(e1[[1]])
 abc: Before dispatching; x has class `call': language sin(x)
 abc.default(e1[[1]])

tests/reg-tests-2.R

@@ -1951,4 +1951,15 @@ row.names(B) <- c("2002-09-15", "2002-10-15", "2002-11-15", "2002-12-15")
 merge(A, B, by=0, all=TRUE)
 
 
+## assigning to a list loop index could alter the index (PR#9216)
+L <- list(a = list(txt = "original value"))
+f <- function(LL) {
+    for (ll in LL) ll$txt <- "changed in f"
+    LL
+}
+f(L)
+L
+## both were changed < 2.4.0
+
+
 ### end of tests added in 2.4.0 ###

tests/reg-tests-2.Rout.save

@@ -1,5 +1,5 @@
 
-R version 2.4.0 Under development (unstable) (2006-08-30 r39024)
+R version 2.5.0 Under development (unstable) (2006-09-11 r39251)
 Copyright (C) 2006 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
@@ -2457,7 +2457,7 @@ x3  0.81       -0.97
 14     71
 15     72
 Warning message:
-drop argument will be ignored in: "[.data.frame"(women, "height", drop = FALSE) 
+drop argument will be ignored in: `[.data.frame`(women, "height", drop = FALSE) 
 > women["height", drop = TRUE]   # ditto
    height
 1      58
@@ -2476,7 +2476,7 @@ drop argument will be ignored in: "[.data.frame"(women, "height", drop = FALSE)
 14     71
 15     72
 Warning message:
-drop argument will be ignored in: "[.data.frame"(women, "height", drop = TRUE) 
+drop argument will be ignored in: `[.data.frame`(women, "height", drop = TRUE) 
 > women[,"height", drop = FALSE] # no warning
    height
 1      58
@@ -3167,12 +3167,12 @@ $wt.res
 > ## Indexing non-existent columns in a data frame
 > x <- data.frame(a = 1, b = 2)
 > try(x[c("a", "c")])
-Error in "[.data.frame"(x, c("a", "c")) : undefined columns selected
+Error in `[.data.frame`(x, c("a", "c")) : undefined columns selected
 > try(x[, c("a", "c")])
-Error in "[.data.frame"(x, , c("a", "c")) : 
+Error in `[.data.frame`(x, , c("a", "c")) : 
 	undefined columns selected
 > try(x[1, c("a", "c")])
-Error in "[.data.frame"(x, 1, c("a", "c")) : 
+Error in `[.data.frame`(x, 1, c("a", "c")) : 
 	undefined columns selected
 > ## Second succeeded, third gave uniformative error message in 1.7.x.
 > 
@@ -4801,7 +4801,7 @@ coef[0] = 1
 > ## using NULL as a replacement value
 > DF <- data.frame(A=1:2, B=3:4)
 > try(DF[2, 1:3] <- NULL)
-Error in "[<-.data.frame"(`*tmp*`, 2, 1:3, value = NULL) : 
+Error in `[<-.data.frame`(`*tmp*`, 2, 1:3, value = NULL) : 
 	replacement has 0 items, need 3
 > ## wrong error message in R < 2.2.0
 > 
@@ -5477,5 +5477,26 @@ Levels: 7 8 9 10 11 12
 6 2003-02-15  4 NA
 > 
 > 
+> ## assigning to a list loop index could alter the index (PR#9216)
+> L <- list(a = list(txt = "original value"))
+> f <- function(LL) {
++     for (ll in LL) ll$txt <- "changed in f"
++     LL
++ }
+> f(L)
+$a
+$a$txt
+[1] "original value"
+
+
+> L
+$a
+$a$txt
+[1] "original value"
+
+
+> ## both were changed < 2.4.0
+> 
+> 
 > ### end of tests added in 2.4.0 ###
 >