...
 
Commits (7)
......@@ -408,10 +408,13 @@ static void ListAnswer(SEXP x, SEXP grad, int recursive, struct BindData *data)
case EXPRSXP:
len = LENGTH(x);
if (recursive != 0) {
for (i = 0; i < len; i++)
ListAnswer(VECTOR_ELT(x,i), grad == R_NilValue ? R_NilValue
: subset2_list_gradient(grad,i,len),
recursive == 1, data);
for (i = 0; i < len; i++) {
SEXP g = grad == R_NilValue ? R_NilValue
: subset2_list_gradient(grad,i,len);
PROTECT(g);
ListAnswer(VECTOR_ELT(x,i), g, recursive == 1, data);
UNPROTECT(1);
}
}
else {
for (i = 0; i < len; i++)
......@@ -467,8 +470,11 @@ static void AtomicAnswer(SEXP x, SEXP grad, struct BindData *data)
case VECSXP:
n = LENGTH(x);
for (i = 0; i < n; i++) {
AtomicAnswer (VECTOR_ELT(x, i), grad == R_NilValue ? R_NilValue
: subset2_list_gradient(grad,i,n), data);
SEXP g = grad == R_NilValue ? R_NilValue
: subset2_list_gradient(grad,i,n);
PROTECT(g);
AtomicAnswer (VECTOR_ELT(x,i), g, data);
UNPROTECT(1);
}
break;
default:
......@@ -1271,10 +1277,11 @@ static SEXP cbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
if (argkind[n] != 3) {
if (argkind[n] == 2 || arg_len[n] >= lenmin) {
if (TYPEOF(argval[n]) != VECSXP) {
argval[n] = coerceVector(argval[n],mode);
PROTECT (argval[n] = coerceVector(argval[n],mode));
if (arggrad[n] != R_NilValue)
arggrad[n] = as_list_gradient (arggrad[n],
LENGTH(argval[n]));
UNPROTECT(1);
}
}
else {
......@@ -1564,10 +1571,11 @@ static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
if (argkind[n] != 3) {
if (argkind[n] == 2 || arg_len[n] >= lenmin) {
if (TYPEOF(argval[n]) != VECSXP) {
argval[n] = coerceVector(argval[n],mode);
PROTECT(argval[n] = coerceVector(argval[n],mode));
if (arggrad[n] != R_NilValue)
arggrad[n] = as_list_gradient (arggrad[n],
LENGTH(argval[n]));
UNPROTECT(1);
}
}
else {
......@@ -1636,12 +1644,13 @@ static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
}
if (arggrad[n] != R_NilValue) {
R_len_t vlen = LENGTH(argval[n]);
for (h = j; h < m; h++)
for (h = j; h < m; h++) {
grad = subassign_range_list_gradient (grad,
subset_range_list_gradient (arggrad[n],
(h*idx) % vlen, ((h+1)*idx-1) % vlen, vlen),
i+h*rows, i+h*rows+idx-1, LENGTH(result));
UNPROTECT_PROTECT(grad);
UNPROTECT_PROTECT(grad);
}
}
}
}
......@@ -1678,12 +1687,13 @@ static SEXP rbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho,
}
if (arggrad[n] != R_NilValue) {
R_len_t vlen = LENGTH(argval[n]);
for (h = j; h < m; h++)
for (h = j; h < m; h++) {
grad = subassign_range_numeric_gradient (grad,
subset_range_numeric_gradient (arggrad[n],
(h*idx) % vlen, ((h+1)*idx-1) % vlen, vlen),
i+h*rows, i+h*rows+idx-1, LENGTH(result));
UNPROTECT_PROTECT(grad);
UNPROTECT_PROTECT(grad);
}
}
}
i += idx;
......
......@@ -1078,6 +1078,7 @@ static SEXP do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
x = lengthgets (x, len);
if (HAS_GRADIENT_IN_CELL(args)) {
PROTECT(x);
SEXP x_grad = GRADIENT_IN_CELL(args);
if (LENGTH(x) == olen) {
R_gradient = x_grad;
......@@ -1091,6 +1092,7 @@ static SEXP do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
R_gradient = set_length_numeric_gradient (x_grad, len);
R_variant_result = VARIANT_GRADIENT_FLAG;
}
UNPROTECT(1);
}
UNPROTECT(1); /* args */
......
......@@ -780,12 +780,14 @@ static SEXP RemoveFromList(SEXP thing, SEXP list, SEXP *value)
SEXP last = R_NilValue;
SEXP curr = list;
R_gradient = R_NilValue;
while (curr != R_NilValue) {
if (TAG(curr) == thing) {
*value = CAR(curr);
R_gradient = HAS_GRADIENT_IN_CELL(curr) ? GRADIENT_IN_CELL(curr)
: R_NilValue;
if (HAS_GRADIENT_IN_CELL(curr))
R_gradient = GRADIENT_IN_CELL(curr);
SETCAR(curr, R_UnboundValue); /* in case binding is cached */
LOCK_BINDING(curr); /* in case binding is cached */
if (last==R_NilValue)
......
......@@ -1225,8 +1225,10 @@ static SEXP do_for (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
}
if (bcell == R_NilValue || CAR(bcell) != v) {
PROTECT(v_grad);
set_var_in_frame (sym, v, rho, TRUE, 3);
REPROTECT(bcell = R_binding_cell, bix);
UNPROTECT(1);
}
if (STORE_GRAD(rho) && bcell != R_NilValue)
......@@ -1603,6 +1605,8 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if (NAMEDCNT_GT_0(rhs)
&& (rhs_type_etc&~TYPE_ET_CETERA_TYPE)==0 /* scalar, no attr, n.b.c. */
&& (((NONPOINTER_VECTOR_TYPES & ~(1<<CPLXSXP)) >> rhs_type_etc) & 1)) {
PROTECT (R_variant_result & VARIANT_GRADIENT_FLAG ? R_gradient
: R_NilValue);
if (v == R_UnboundValue)
v = findVarInFrame3_nolast (rho, lhs, 7);
if (TYPE_ETC(v) == rhs_type_etc /* won't be if R_UnboundValue */
......@@ -1613,10 +1617,12 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
WAIT_UNTIL_NOT_IN_USE(v); /* won't be being computed */
memcpy(REAL(v),REAL(rhs),sizeof(double)); /* others no bigger */
rhs = v; /* for return value */
UNPROTECT(1);
goto done;
}
if (POP_IF_TOP_OF_STACK(rhs))
rhs = DUP_STACK_VALUE(rhs);
UNPROTECT(1);
}
/* Assign rhs to lhs using the binding cell found above. */
......
......@@ -1341,7 +1341,7 @@ static SEXP do_pmin(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
int max = PRIMVAL(op) == 1;
SEXP a, x, ans, grad;
SEXP a, x, ans;
int i, j, n, len, narm;
SEXPTYPE type, anstype;
......@@ -1416,7 +1416,6 @@ static SEXP do_pmin(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
}
PROTECT(ans = allocVector(anstype, len));
PROTECT(grad = R_NilValue);
x = CAR(args);
if (TYPEOF(x) != anstype) {
......@@ -1502,6 +1501,9 @@ static SEXP do_pmin(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if ((variant & VARIANT_GRADIENT) && anstype == REALSXP) {
SEXP dup_ans = duplicate(ans); /* so can be modified below */
PROTECT(dup_ans);
SEXP grad = R_NilValue;
PROTECT(grad);
for (a = args; a != R_NilValue; a = CDR(a)) {
SEXP v = CAR(a);
if (HAS_GRADIENT_IN_CELL(a)) {
......@@ -1518,14 +1520,14 @@ static SEXP do_pmin(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
if (j >= n) j = 0;
}
}
if (grad != R_NilValue) {
R_gradient = grad;
R_variant_result = VARIANT_GRADIENT_FLAG;
}
UNPROTECT(2);
}
if (grad != R_NilValue) {
R_gradient = grad;
R_variant_result = VARIANT_GRADIENT_FLAG;
}
UNPROTECT(3);
UNPROTECT(2);
return ans;
}
......