Merged 62220 (NAMED issues from R Neal) from trunk.

git-svn-id: https://svn.r-project.org/R/branches/R-2-15-branch@62222 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Mar 12, 2013 · e0a79a4 · e0a79a4
1 parent d604b5e
commit e0a79a4
Show file tree

Hide file tree

Showing 4 changed files with 27 additions and 6 deletions.
diff --git a/src/main/apply.c b/src/main/apply.c
@@ -148,7 +148,10 @@ SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
 	    SEXP val; SEXPTYPE valType;
 	    PROTECT_INDEX indx;
 	    INTEGER(ind)[0] = i + 1;
-	    PROTECT_WITH_INDEX(val = eval(R_fcall, rho), &indx);
+	    val = val = eval(R_fcall, rho);
+	    if (NAMED(val))
+		val = duplicate(val);
+	    PROTECT_WITH_INDEX(val, &indx);
 	    if (length(val) != commonLen)
 	    	error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
 	               commonLen, i+1, length(val));
@@ -264,6 +267,8 @@ static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
 	/* PROTECT(R_fcall = lang2(FUN, X)); */
 	PROTECT(R_fcall = lang3(FUN, X, R_DotsSymbol));
 	ans = eval(R_fcall, rho);
+	if (NAMED(ans))
+	    ans = duplicate(ans);
 	UNPROTECT(1);
 	return(ans);
     } else if(replace) return duplicate(X);

diff --git a/src/main/envir.c b/src/main/envir.c
@@ -2625,7 +2625,10 @@ SEXP attribute_hidden do_eapply(SEXP call, SEXP op, SEXP args, SEXP rho)
 
     for(i = 0; i < k2; i++) {
 	INTEGER(ind)[0] = i+1;
-	SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
+	SEXP tmp = eval(R_fcall, rho);
+	if (NAMED(tmp))
+	    tmp = duplicate(tmp);
+	SET_VECTOR_ELT(ans, i, tmp);
     }
 
     if (useNms) {

diff --git a/src/main/mapply.c b/src/main/mapply.c
@@ -82,7 +82,10 @@ do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEXP rho)
 	    counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
 	    INTEGER(VECTOR_ELT(nindex, j))[0] = counters[j];
 	}
-	SET_VECTOR_ELT(ans, i, eval(fcall, rho));
+	SEXP tmp = eval(fcall, rho);
+	if (NAMED(tmp))
+	    tmp = duplicate(tmp);
+	SET_VECTOR_ELT(ans, i, tmp);
     }
 
     for(int j = 0; j < m; j++)

diff --git a/src/main/subset.c b/src/main/subset.c
@@ -44,6 +44,16 @@
 #undef _S4_subsettable
 
 
+static R_INLINE SEXP VECTOR_ELT_FIX_NAMED(SEXP y, int i) {
+    /* if RHS (container or element) has NAMED > 0 set NAMED = 2.
+       Duplicating might be safer/more consistent (**** PR15098) */
+    SEXP val = VECTOR_ELT(y, i);
+    if ((NAMED(y) || NAMED(val)))
+	if (NAMED(val) < 2)
+	    SET_NAMED(val, 2);
+    return val;
+}
+
 /* ExtractSubset does the transfer of elements from "x" to "result" */
 /* according to the integer subscripts given in "indx". */
 
@@ -100,7 +110,7 @@ static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx, SEXP call)
 	case VECSXP:
 	case EXPRSXP:
 	    if (0 <= ii && ii < nx && ii != NA_INTEGER)
-		SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
+		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
 	    else
 		SET_VECTOR_ELT(result, i, R_NilValue);
 	    break;
@@ -298,7 +308,7 @@ static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
 		    SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
 		    break;
 		case VECSXP:
-		    SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
+		    SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
 		    break;
 		case RAWSXP:
 		    RAW(result)[ij] = RAW(x)[iijj];
@@ -450,7 +460,7 @@ static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
 	    break;
 	case VECSXP:
 	    if (ii != NA_INTEGER)
-		SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
+		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
 	    else
 		SET_VECTOR_ELT(result, i, R_NilValue);
 	    break;