Commit 41a097a5 authored by Radford Neal's avatar Radford Neal

numerous detailed performance improvements, introduce install_translated

parent 627d38f4
Ensure that evaluated arguments are not changed by evaluation
of later arguments. Adds tests for this. Other minor related mods.
of later arguments. Adds tests for this.
Other performance improvements too, including introduction of
install_translated.
......@@ -365,8 +365,10 @@
Rf_gammalims
Rf_gpptr
Rf_i1mach
Rf_install_translated
Rf_internalArraySubscript
Rf_internalTypeCheck
Rf_invalid_assignment_error
Rf_isNAcol
Rf_labelformat
Rf_lfastchoose
......
......@@ -729,7 +729,14 @@ extern void helpers_wait_until_not_being_computed2 (SEXP, SEXP);
#define WAIT_UNTIL_COMPUTED_2(x1,x2) \
( ! helpers_is_being_computed(x1) && ! helpers_is_being_computed(x2) \
? (void) 0 \
: helpers_wait_until_not_being_computed2(x1,x2) ) \
: helpers_wait_until_not_being_computed2(x1,x2) )
/* Macro to wait until variable not in use. */
#define WAIT_UNTIL_NOT_IN_USE(x) \
( ! helpers_is_in_use(x) \
? (void) 0 \
: helpers_wait_until_not_in_use(x) )
#else
......@@ -1292,11 +1299,13 @@ extern0 Rboolean known_to_be_utf8 INI_as(FALSE);
# define InitTempDir Rf_InitTempDir
# define InitTypeTables Rf_InitTypeTables
# define initStack Rf_initStack
# define install_translated Rf_install_translated
# define IntegerFromComplex Rf_IntegerFromComplex
# define IntegerFromLogical Rf_IntegerFromLogical
# define IntegerFromReal Rf_IntegerFromReal
# define IntegerFromString Rf_IntegerFromString
# define internalTypeCheck Rf_internalTypeCheck
# define invalid_assignment_error Rf_invalid_assignment_error
# define isValidName Rf_isValidName
# define jump_to_toplevel Rf_jump_to_toplevel
# define KillAllDevices Rf_KillAllDevices
......@@ -1507,6 +1516,7 @@ void Init_R_Variables(SEXP);
void InitTempDir(void);
void InitTypeTables(void);
void initStack(void);
SEXP install_translated (SEXP);
void internalTypeCheck(SEXP, SEXP, SEXPTYPE);
Rboolean isMethodsDispatchOn(void);
int isValidName(const char *);
......@@ -1662,6 +1672,7 @@ R_NORETURN void dotdotdot_error(void);
R_NORETURN void apply_non_function_error(void);
R_NORETURN void arg_missing_error(SEXP sym);
R_NORETURN void unbound_var_error(SEXP sym);
R_NORETURN void invalid_assignment_error(SEXP call);
R_NORETURN void out_of_bounds_error(SEXP call);
R_NORETURN void nonsubsettable_error(SEXP call, SEXP x);
R_NORETURN void PRSEEN_error(SEXP e);
......
......@@ -632,7 +632,7 @@ extern void helpers_wait_until_not_in_use(SEXP);
#define NAMEDCNT(x) \
( helpers_is_in_use(x) && UPTR_FROM_SEXP(x)->sxpinfo.nmcnt != MAX_NAMEDCNT \
? (helpers_wait_until_not_in_use(x), UPTR_FROM_SEXP(x)->sxpinfo.nmcnt) \
? (WAIT_UNTIL_NOT_IN_USE(x), UPTR_FROM_SEXP(x)->sxpinfo.nmcnt) \
: UPTR_FROM_SEXP(x)->sxpinfo.nmcnt )
#define NAMEDCNT_EQ_0(x) \
......
......@@ -227,7 +227,7 @@ SEXP getAttrib(SEXP vec, SEXP name)
&& TYPEOF(vec) != LISTSXP && TYPEOF(vec) != LANGSXP)
return R_NilValue;
if (isString(name)) name = install(translateChar(STRING_ELT(name, 0)));
if (isString(name)) name = install_translated (STRING_ELT(name,0));
/* special test for c(NA, n) rownames of data frames: */
if (name == R_RowNamesSymbol) {
......@@ -353,7 +353,7 @@ SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
PROTECT3(vec,name,val);
if (isString(name))
name = install(translateChar(STRING_ELT(name, 0)));
name = install_translated (STRING_ELT(name,0));
if (val == R_NilValue) {
UNPROTECT(3);
......@@ -1099,7 +1099,7 @@ SEXP namesgets(SEXP vec, SEXP val)
if (STRING_ELT(val, i) != R_NilValue
&& STRING_ELT(val, i) != R_NaString
&& *CHAR(STRING_ELT(val, i)) != 0) /* test of length */
SET_TAG(s, install(translateChar(STRING_ELT(val, i))));
SET_TAG(s, install_translated (STRING_ELT(val,i)));
else
SET_TAG_NIL(s);
}
......@@ -1239,7 +1239,7 @@ SEXP dimnamesgets(SEXP vec, SEXP val)
top = VECTOR_ELT(val, 0);
i = 0;
for (val = vec; !isNull(val); val = CDR(val))
SET_TAG(val, install(translateChar(STRING_ELT(top, i++))));
SET_TAG(val, install_translated (STRING_ELT(top,i++)));
}
UNPROTECT(2);
return vec;
......@@ -1496,7 +1496,7 @@ static SEXP do_attributesgets(SEXP call, SEXP op, SEXP args, SEXP env)
}
for (i = 0; i < nattrs; i++) {
if (i == i0) continue;
setAttrib(object, install(translateChar(STRING_ELT(names, i))),
setAttrib(object, install_translated (STRING_ELT(names,i)),
VECTOR_ELT(attrs, i));
}
}
......@@ -1971,9 +1971,9 @@ SEXP R_do_slot_assign(SEXP obj, SEXP name, SEXP value)
/* Ensure that name is a symbol */
if(isString(name) && LENGTH(name) == 1)
name = install(translateChar(STRING_ELT(name, 0)));
name = install_translated (STRING_ELT(name,0));
if(TYPEOF(name) == CHARSXP)
name = install(translateChar(name));
name = install_translated (name);
if(!isSymbol(name) )
error(_("invalid type or length for slot name"));
......@@ -2026,7 +2026,7 @@ static SEXP do_AT(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
* test expression should kick out on the first element. */
if(!(isSymbol(nlist) || (isString(nlist) && LENGTH(nlist) == 1)))
error(_("invalid type or length for slot name"));
if(isString(nlist)) nlist = install(translateChar(STRING_ELT(nlist, 0)));
if(isString(nlist)) nlist = install_translated (STRING_ELT(nlist,0));
PROTECT(object = eval(CAR(args), env));
if(!s_dot_Data) init_slot_handling();
if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) {
......
......@@ -200,7 +200,7 @@ static SEXP do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
if (!isString(CAR(args)) || length(CAR(args)) == 0)
error(_("invalid first argument"));
name = install(translateChar(STRING_ELT(CAR(args), 0)));
name = install_translated (STRING_ELT(CAR(args),0));
args = CDR(args);
expr = CAR(args);
......@@ -322,7 +322,7 @@ static SEXP do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
fun = CAR(args);
if (TYPEOF(fun) == STRSXP && length(fun)==1) {
PROTECT(s = install(translateChar(STRING_ELT(fun, 0))));
PROTECT(s = install_translated (STRING_ELT(fun,0)));
fun = findFun(s, rho);
SETCAR(args, fun);
UNPROTECT(1);
......
......@@ -836,7 +836,7 @@ SEXP VectorToPairList(SEXP x)
SETCAR(xptr, VECTOR_ELT(x, i));
SET_NAMEDCNT_MAX(CAR(xptr));
if (named && CHAR(STRING_ELT(xnames, i))[0] != '\0') /* ASCII */
SET_TAG(xptr, install(translateChar(STRING_ELT(xnames, i))));
SET_TAG(xptr, install_translated (STRING_ELT(xnames,i)));
xptr = CDR(xptr);
}
if (len>0) /* can't set attributes on NULL */
......@@ -1359,7 +1359,7 @@ SEXP CreateTag(SEXP x)
if (isNull(x) || isSymbol(x))
return x;
else if (isString(x) && LENGTH(x) >= 1 && LENGTH(STRING_ELT(x, 0)) >= 1)
return install(translateChar(STRING_ELT(x, 0)));
return install_translated (STRING_ELT(x,0));
else
return installChar(STRING_ELT(deparse1(x, 1, SIMPLEDEPARSE), 0));
}
......@@ -1644,7 +1644,7 @@ static SEXP do_asfunction(SEXP call, SEXP op, SEXP args, SEXP rho)
for (i = 0; i < n - 1; i++) {
SETCAR(pargs, VECTOR_ELT(arglist, i));
if (names != R_NilValue && *CHAR(STRING_ELT(names, i)) != '\0') /* ASCII */
SET_TAG(pargs, install(translateChar(STRING_ELT(names, i))));
SET_TAG(pargs, install_translated (STRING_ELT(names,i)));
else
SET_TAG_NIL(pargs);
pargs = CDR(pargs);
......@@ -1689,7 +1689,7 @@ static SEXP do_ascall(SEXP call, SEXP op, SEXP args, SEXP rho)
for (i = 0; i < n; i++) {
SETCAR(ap, VECTOR_ELT(args, i));
if (names != R_NilValue && !StringBlank(STRING_ELT(names, i)))
SET_TAG(ap, install(translateChar(STRING_ELT(names, i))));
SET_TAG(ap, install_translated (STRING_ELT(names,i)));
ap = CDR(ap);
}
UNPROTECT(2); /* ap, names */
......@@ -2744,7 +2744,7 @@ static SEXP do_call(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
*/
if (!isString(rfun) || length(rfun) != 1)
errorcall_return(call, _("first argument must be a character string"));
PROTECT(rfun = install(translateChar(STRING_ELT(rfun, 0))));
PROTECT(rfun = install_translated (STRING_ELT(rfun,0)));
PROTECT(evargs = duplicate(CDR(args)));
for (rest = evargs; rest != R_NilValue; rest = CDR(rest))
SETCAR(rest, eval(CAR(rest), rho));
......@@ -2785,14 +2785,14 @@ static SEXP do_docall(SEXP call, SEXP op, SEXP args, SEXP rho)
PROTECT(c = call = allocList(n + 1));
SET_TYPEOF(c, LANGSXP);
if( isString(fun) )
SETCAR(c, install(translateChar(STRING_ELT(fun, 0))));
SETCAR(c, install_translated (STRING_ELT(fun,0)));
else
SETCAR(c, fun);
c = CDR(c);
for (i = 0; i < n; i++) {
SETCAR(c, VECTOR_ELT(args, i));
if (ItemName(names, i) != R_NilValue)
SET_TAG(c, install(translateChar(ItemName(names, i))));
SET_TAG(c, install_translated (ItemName(names,i)));
c = CDR(c);
}
call = eval(call, envir);
......
......@@ -40,7 +40,7 @@ static SEXP do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP fn = CAR(args);
if (isValidString(fn))
fn = findFun (install(translateChar(STRING_ELT(fn,0))), rho);
fn = findFun (install_translated (STRING_ELT(fn,0)), rho);
if (TYPEOF(fn) != CLOSXP && TYPEOF(fn) != SPECIALSXP
&& TYPEOF(fn) != BUILTINSXP )
......@@ -75,7 +75,7 @@ static SEXP do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
SEXP fn = CAR(args);
if (isValidString(fn))
fn = findFun (install(translateChar(STRING_ELT(fn,0))), rho);
fn = findFun (install_translated (STRING_ELT(fn,0)), rho);
if (TYPEOF(fn) != CLOSXP && TYPEOF(fn) != BUILTINSXP
&& TYPEOF(fn) != SPECIALSXP)
......
......@@ -406,7 +406,7 @@ static SEXP do_dump(SEXP call, SEXP op, SEXP args, SEXP rho)
PROTECT(o = objs = allocList(nobjs));
for (j = 0, nout = 0; j < nobjs; j++, o = CDR(o)) {
SET_TAG(o, install(translateChar(STRING_ELT(names, j))));
SET_TAG(o, install_translated (STRING_ELT(names,j)));
SETCAR(o, findVar(TAG(o), source));
if (CAR(o) == R_UnboundValue)
warning(_("object '%s' not found"), CHAR(PRINTNAME(TAG(o))));
......
......@@ -652,7 +652,7 @@ static SEXP do_D(SEXP call, SEXP op, SEXP args, SEXP env)
error(_("variable must be a character string"));
if (length(var) > 1)
warning(_("only the first element is used as variable name"));
var = install(translateChar(STRING_ELT(var, 0)));
var = install_translated (STRING_ELT(var,0));
InitDerivSymbols();
PROTECT(expr = D(expr, var));
expr = AddParens(expr);
......@@ -965,14 +965,14 @@ static SEXP do_deriv(SEXP call, SEXP op, SEXP args, SEXP env)
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, install(translateChar(STRING_ELT(names, i)))));
PROTECT(ans = D(ans, install_translated (STRING_ELT(names,i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, install(translateChar(STRING_ELT(names, j)))));
PROTECT(ans2 = D(ans2, install_translated (STRING_ELT(names,j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
......@@ -996,13 +996,13 @@ static SEXP do_deriv(SEXP call, SEXP op, SEXP args, SEXP env)
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, install(translateChar(STRING_ELT(names, i)))));
PROTECT(ans = D(ans, install_translated (STRING_ELT(names,i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, install(translateChar(STRING_ELT(names, j)))));
PROTECT(ans2 = D(ans2, install_translated (STRING_ELT(names,j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
......@@ -1012,7 +1012,7 @@ static SEXP do_deriv(SEXP call, SEXP op, SEXP args, SEXP env)
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, install(translateChar(STRING_ELT(names, i)))));
PROTECT(ans = D(ans, install_translated (STRING_ELT(names,i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
......@@ -1021,7 +1021,7 @@ static SEXP do_deriv(SEXP call, SEXP op, SEXP args, SEXP env)
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, install(translateChar(STRING_ELT(names, j)))));
PROTECT(ans2 = D(ans2, install_translated (STRING_ELT(names,j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
......@@ -1115,7 +1115,7 @@ static SEXP do_deriv(SEXP call, SEXP op, SEXP args, SEXP env)
PROTECT(ans = allocList(len_names));
SET_FORMALS(funarg, ans);
for(i = 0; i < len_names; i++) {
SET_TAG(ans, install(translateChar(STRING_ELT(names, i))));
SET_TAG(ans, install_translated (STRING_ELT(names,i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
......
......@@ -806,6 +806,9 @@ SEXP attribute_hidden Rf_find_binding_in_frame (SEXP rho, SEXP symbol,
{
SEXP loc;
if (!isEnvironment(rho)) /* somebody does this... */
return R_NilValue;
if (SEXP32_FROM_SEXP(rho) == LASTSYMENV(symbol)) {
loc = LASTSYMBINDING(symbol);
if (BINDING_VALUE(loc) == R_UnboundValue)
......@@ -814,32 +817,32 @@ SEXP attribute_hidden Rf_find_binding_in_frame (SEXP rho, SEXP symbol,
return loc;
}
if (IS_USER_DATABASE(rho)) {
R_ObjectTable *table = (R_ObjectTable *)R_ExternalPtrAddr(HASHTAB(rho));
SEXP val = table->get(CHAR(PRINTNAME(symbol)), canCache, table);
/* Better to use exists() here if we don't actually need the value? */
if (val == R_UnboundValue)
loc = R_NilValue;
else {
/* The result should probably be identified as being from
a user database, or maybe use an active binding
mechanism to allow setting a new value to get back to
the data base. */
loc = cons_with_tag (val, R_NilValue, symbol);
/* If the database has a canCache method, then call that.
Otherwise, we believe the setting for canCache. */
if(canCache && table->canCache)
*canCache = table->canCache(CHAR(PRINTNAME(symbol)), table);
}
if (IS_BASE(rho) || OBJECT(rho)) { /* user databases have OBJECT set */
if (IS_USER_DATABASE(rho)) {
R_ObjectTable *table = (R_ObjectTable *)
R_ExternalPtrAddr(HASHTAB(rho));
SEXP val = table->get(CHAR(PRINTNAME(symbol)), canCache, table);
/* Better to use exists here if we don't actually need the value? */
if (val == R_UnboundValue)
loc = R_NilValue;
else {
/* The result should probably be identified as being from
a user database, or maybe use an active binding
mechanism to allow setting a new value to get back to
the data base. */
loc = cons_with_tag (val, R_NilValue, symbol);
/* If the database has a canCache method, then call that.
Otherwise, we believe the setting for canCache. */
if (canCache && table->canCache)
*canCache = table->canCache(CHAR(PRINTNAME(symbol)), table);
}
}
else if (IS_BASE(rho))
error(
"'find_binding_in_frame' cannot be used on the base environment");
}
else if (IS_BASE(rho))
error("'find_binding_in_frame' cannot be used on the base environment");
else if (!isEnvironment(rho)) /* somebody does this... */
return R_NilValue;
else if (HASHTAB(rho) == R_NilValue) {
else if (FRAME(rho) != R_NilValue) {
loc = FRAME(rho);
SEARCH_LOOP (rho, loc, symbol, goto found);
......@@ -854,12 +857,14 @@ SEXP attribute_hidden Rf_find_binding_in_frame (SEXP rho, SEXP symbol,
LASTSYMBINDING(symbol) = loc;
}
}
else {
else if (HASHTAB(rho) != R_NilValue) {
int hashcode;
hashcode = SYM_HASH(symbol) % HASHLEN(rho);
/* Will return 'R_NilValue' if not found */
loc = R_HashGetLoc(rho, hashcode, symbol, HASHTAB(rho));
hashcode = SYM_HASH(symbol) % HASHLEN(rho);
/* Will return 'R_NilValue' if not found */
loc = R_HashGetLoc(rho, hashcode, symbol, HASHTAB(rho));
}
else
return R_NilValue;
return loc;
}
......@@ -966,6 +971,9 @@ SEXP findVarInFrame3(SEXP rho, SEXP symbol, int option)
{
SEXP value;
if (!isEnvironment(rho))
error(_("argument to '%s' is not an environment"), "findVarInFrame3");
if (SEXP32_FROM_SEXP(rho) == LASTSYMENV(symbol)) {
SEXP binding = LASTSYMBINDING(symbol); /* won't be an active binding */
if ( ! BINDING_IS_LOCKED(binding)) {
......@@ -1039,10 +1047,7 @@ SEXP findVarInFrame3_nolast(SEXP rho, SEXP symbol, int option)
}
}
else if (!isEnvironment(rho))
error(_("argument to '%s' is not an environment"), "findVarInFrame3");
else if (HASHTAB(rho) == R_NilValue) {
else if (FRAME(rho) != R_NilValue) {
if (LASTENVNOTFOUND(symbol) != SEXP32_FROM_SEXP(rho)) {
loc = FRAME(rho);
......@@ -1073,7 +1078,7 @@ SEXP findVarInFrame3_nolast(SEXP rho, SEXP symbol, int option)
value = option==2 ? R_NilValue : BINDING_VALUE(loc);
}
else {
else if (HASHTAB(rho) != R_NilValue) {
int hashcode;
hashcode = SYM_HASH(symbol) % HASHLEN(rho);
loc = R_HashGetLoc(rho, hashcode, symbol, HASHTAB(rho));
......@@ -1563,13 +1568,13 @@ int set_var_in_frame (SEXP symbol, SEXP value, SEXP rho, int create, int incdec)
return TRUE; /* should have either succeeded, or raised an error */
}
if (HASHTAB(rho) == R_NilValue) {
if (FRAME(rho) != R_NilValue) {
if (LASTENVNOTFOUND(symbol) != SEXP32_FROM_SEXP(rho)) {
loc = FRAME(rho);
SEARCH_LOOP (rho, loc, symbol, goto found_update_last);
}
}
else { /* hashed environment */
else if (HASHTAB(rho) != R_NilValue) {
hashcode = SYM_HASH(symbol) % HASHLEN(rho);
loc = VECTOR_ELT(HASHTAB(rho), hashcode);
SEARCH_LOOP (rho, loc, symbol, goto found);
......@@ -1813,7 +1818,7 @@ static SEXP do_assign(SEXP call, SEXP op, SEXP args, SEXP rho)
else {
if (length(CAR(args)) > 1)
warning(_("only the first element is used as variable name"));
name = install(translateChar(STRING_ELT(CAR(args), 0)));
name = install_translated (STRING_ELT(CAR(args),0));
}
PROTECT(val = CADR(args));
aenv = CADDR(args);
......@@ -1860,7 +1865,7 @@ static SEXP do_list2env(SEXP call, SEXP op, SEXP args, SEXP rho)
error(_("names(x) must be a character vector of the same length as x"));
for (int i = 0; i < n; i++) {
SEXP name = install(translateChar(STRING_ELT(xnms, i)));
SEXP name = install_translated (STRING_ELT(xnms,i));
defineVar(name, VECTOR_ELT(x, i), envir);
}
......@@ -1906,7 +1911,7 @@ static SEXP do_remove(SEXP call, SEXP op, SEXP args, SEXP rho)
for (i = 0; i < LENGTH(name); i++) {
value = R_NoObject;
tsym = install(translateChar(STRING_ELT(name, i)));
tsym = install_translated (STRING_ELT(name,i));
tenv = envarg;
while (tenv != R_EmptyEnv) {
value = RemoveVariable(tsym, tenv);
......@@ -1986,7 +1991,7 @@ static SEXP do_get(SEXP call, SEXP op, SEXP args, SEXP rho)
if (!isValidStringF(CAR(args)))
error(_("invalid first argument"));
else
t1 = install(translateChar(STRING_ELT(CAR(args), 0)));
t1 = install_translated (STRING_ELT(CAR(args),0));
/* envir : originally, the "where=" argument */
......@@ -2275,7 +2280,7 @@ static SEXP do_missing(SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
sym = CAR(args);
if (isString(sym) && length(sym)==1)
sym = install(translateChar(STRING_ELT(CAR(args), 0)));
sym = install_translated (STRING_ELT(CAR(args),0));
if (!isSymbol(sym))
errorcall(call, _("invalid use of 'missing'"));
......@@ -3474,7 +3479,7 @@ static SEXP checkNSname(SEXP call, SEXP name)
break;
case STRSXP:
if (LENGTH(name) >= 1) {
name = install(translateChar(STRING_ELT(name, 0)));
name = install_translated (STRING_ELT(name,0));
break;
}
/* else fall through */
......@@ -3558,8 +3563,8 @@ static SEXP do_importIntoEnv(SEXP call, SEXP op, SEXP args, SEXP rho)
n = LENGTH(impnames);
for (i = 0; i < n; i++) {
impsym = install(translateChar(STRING_ELT(impnames, i)));
expsym = install(translateChar(STRING_ELT(expnames, i)));
impsym = install_translated (STRING_ELT(impnames,i));
expsym = install_translated (STRING_ELT(expnames,i));
/* find the binding--may be a CONS cell or a symbol */
SEXP binding = R_NilValue;
......
......@@ -1917,6 +1917,10 @@ R_NORETURN void too_deep_error(void)
));
}
R_NORETURN void attribute_hidden invalid_assignment_error (SEXP call)
{
errorcall (call, _("invalid assignment left-hand side"));
}
R_NORETURN void attribute_hidden dotdotdot_error(void)
{
......
......@@ -134,7 +134,7 @@ static SEXP VectorToPairListNamed(SEXP x)
for (i = 0; i < len_x; i++) {
if (CHAR(STRING_ELT(xnames,i))[0] != 0) {
SETCAR (xptr, VECTOR_ELT(x,i));
SET_TAG (xptr, install (translateChar (STRING_ELT(xnames,i))));
SET_TAG (xptr, install_translated (STRING_ELT(xnames,i)));
xptr = CDR(xptr);
}
}
......@@ -2178,12 +2178,13 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
/* -- ASSIGNMENT TO A SIMPLE VARIABLE -- */
/* Handle <<- or assignment to base environment or user database
without trying the optimizations done below. */
/* Handle <<-, or assignment to the base environment, or a user
database (which has object bit set) without trying the
optimizations done below. */
if (opval == 2 || IS_BASE(rho) || IS_USER_DATABASE(rho)) {
if (opval || IS_BASE(rho) || OBJECT(rho)) {
rhs = evalv (rhs, rho, VARIANT_PENDING_OK);
if (opval == 2) {
if (opval) {
set_var_nonlocal (lhs, rhs, ENCLOS(rho), 3);
goto done;
}
......@@ -2251,7 +2252,7 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
&& !NAMEDCNT_GT_1(v)) {
SET_NAMEDCNT_NOT_0(v);
(void) POP_IF_TOP_OF_STACK(rhs);
helpers_wait_until_not_in_use(v); /* won't be being computed */
WAIT_UNTIL_NOT_IN_USE(v); /* won't be being computed */
switch (rhs_type_etc) {
case REALSXP:
*REAL(v) = *REAL(rhs);
......@@ -2301,12 +2302,12 @@ static SEXP do_set (SEXP call, SEXP op, SEXP args, SEXP rho, int variant)
else if (TYPEOF(lhs) == STRSXP && LENGTH(lhs) == 1) {
/* Convert lhs string to a symbol and try again */
lhs = install(translateChar(STRING_ELT(lhs, 0)));
lhs = install_translated (STRING_ELT(lhs,0));
goto redo;
}
else {
errorcall (call, _("invalid assignment left-hand side"));
invalid_assignment_error(call);
}
done:
......@@ -2377,7 +2378,7 @@ SEXP attribute_hidden Rf_set_subassign (SEXP call, SEXP lhs, SEXP rhs, SEXP rho,
(unless this is the <<- operator). Save and protect the binding
cell used. */
if (opval == 2) /* <<- */
if (opval) /* <<- */
varval = findVar (var, ENCLOS(rho));
else {
varval = findVarInFramePendingOK (rho, var);
......@@ -2654,7 +2655,7 @@ SEXP attribute_hidden Rf_set_subassign (SEXP call, SEXP lhs, SEXP rhs, SEXP rho,
SET_NAMEDCNT_NOT_0(varval);
}
else {
if (opval == 2) /* <<- */
if (opval) /* <<- */
set_var_nonlocal (var, newval, ENCLOS(rho), 3);
else
set_var_in_frame (var, newval, rho, TRUE, 3);
......@@ -5218,7 +5219,7 @@ static SEXP do_subassign3(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
and 'into' is not an object. */
if (VARIANT_KIND(variant) == VARIANT_FAST_SUB) {
if (name == R_NilValue) name = install(translateChar(schar));
if (name == R_NilValue) name = install_translated(schar);
return R_subassign3_dflt (call, into, name, value);
}
......@@ -5234,7 +5235,7 @@ static SEXP do_subassign3(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
}
else {
PROTECT(into);
if (name == R_NilValue) name = install(translateChar(schar));
if (name == R_NilValue) name = install_translated(schar);
value = EVALV (value, env, 0);
UNPROTECT(1);
return R_subassign3_dflt (call, into, name, value);
......@@ -5260,7 +5261,7 @@ static SEXP do_subassign3(SEXP call, SEXP op, SEXP args, SEXP env, int variant)
}
PROTECT(ans);
if (name == R_NilValue) name = install(translateChar(schar));
if (name == R_NilValue) name = install_translated(schar);
UNPROTECT(4);
return R_subassign3_dflt(call, CAR(ans), name, CADDR(ans));
......@@ -5283,11 +5284,11 @@ attribute_hidden FUNTAB R_FunTab_eval[] =
{"{", do_begin, 0, 1200, -1, {PP_CURLY, PREC_FN, 0}},
{"return", do_return, 0, 1200, -1, {PP_RETURN, PREC_FN, 0}},
{"function", do_function, 0, 1000, -1, {PP_FUNCTION,PREC_FN, 0}},
{"<-", do_set, 1, 1100, 2, {PP_ASSIGN, PREC_LEFT, 1}},
{"=", do_set, 3, 1100, 2, {PP_ASSIGN, PREC_EQ, 1}},
{"<<-", do_set, 2, 1100, 2, {PP_ASSIGN2, PREC_LEFT, 1}},
{"->", do_set, 11, 1100, 2, {PP_ASSIGN, PREC_RIGHT, 1}},
{"->>", do_set, 12, 1100, 2, {PP_ASSIGN2, PREC_RIGHT, 1}},
{"<-", do_set, 0, 1100, 2, {PP_ASSIGN, PREC_LEFT, 1}},
{"=", do_set, 0, 1100, 2, {PP_ASSIGN, PREC_EQ, 1}},
{"<<-", do_set, 1, 1100, 2, {PP_ASSIGN2, PREC_LEFT, 1}},
{"->", do_set, 10, 1100, 2, {PP_ASSIGN, PREC_RIGHT, 1}},
{"->>", do_set, 11, 1100, 2, {PP_ASSIGN2, PREC_RIGHT, 1}},
{"eval", do_eval, 0, 1211, 3, {PP_FUNCALL, PREC_FN, 0}},
{"eval.with.vis",do_eval, 1, 1211, 3, {PP_FUNCALL, PREC_FN, 0}},
{"Recall", do_recall, 0, 210, -1, {PP_FUNCALL, PREC_FN, 0}},
......
......@@ -80,7 +80,7 @@ SEXP attribute_hidden do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEX
UNPROTECT(3);
PROTECT(fcall = LCONS(tmp2, fcall));
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, install(translateChar(STRING_ELT(vnames, j))));
SET_TAG(fcall, install_translated (STRING_ELT(vnames,j)));
}
UNPROTECT(1);
......
......@@ -678,10 +678,8 @@ void sggc_after_marking (int level, int rep)
for (SEXP *var_list = helpers_var_list(0); *var_list; var_list++) {
SEXP v = *var_list;
if (NOT_MARKED(v)) {
if (helpers_is_being_computed(v))
helpers_wait_until_not_being_computed(v);
if (helpers_is_in_use(v))
helpers_wait_until_not_in_use(v);
WAIT_UNTIL_COMPUTED(v);
WAIT_UNTIL_NOT_IN_USE(v);
}
}
}
......@@ -2023,7 +2021,7 @@ SEXP reallocVector (SEXP vec, R_len_t length, int init)
return vec;
if (new_chunks >= (curr_chunks>>1) || curr_chunks - new_chunks < 4) {
WAIT_UNTIL_COMPUTED(vec);
helpers_wait_until_not_in_use(vec);
WAIT_UNTIL_NOT_IN_USE(vec);
LENGTH(vec) = length;
if (length == 1)
UNSET_VEC_DOTS_TR_BIT(vec);
......@@ -2055,7 +2053,7 @@ SEXP reallocVector (SEXP vec, R_len_t length, int init)
vec = SEXP_FROM_CPTR(cp);
WAIT_UNTIL_COMPUTED(old_vec);
helpers_wait_until_not_in_use(old_vec);
WAIT_UNTIL_NOT_IN_USE(old_vec);
if (init || !isVectorNonpointer(old_vec)) {
sggc_nchunks_t copy_chunks
......@@ -2084,7 +2082,7 @@ SEXP reallocVector (SEXP vec, R_len_t length, int init)
}
else {
WAIT_UNTIL_COMPUTED(vec);
helpers_wait_until_not_in_use(vec);
WAIT_UNTIL_NOT_IN_USE(vec);
LENGTH(vec) = length;
}
......
......@@ -172,7 +172,7 @@ static void CheckRHS(SEXP v)
}
if (isSymbol(v) && framenames != R_NilValue) {
for (i = 0; i < LENGTH(framenames); i++) {
s = install(translateChar(STRING_ELT(framenames, i)));
s = install_translated (STRING_ELT(framenames,i));
if (v == s) {
t = allocVector(STRSXP, LENGTH(framenames)-1);
for (j = 0; j < LENGTH(t); j++) {
......@@ -207,7 +207,7 @@ static void ExtractVars(SEXP formula, int checkonly)
if (formula == dotSymbol && framenames != R_NilValue) {
haveDot = TRUE;
for (i = 0; i < LENGTH(framenames); i++) {
v = install(translateChar(STRING_ELT(framenames, i)));
v = install_translated (STRING_ELT(framenames,i));
if (!MatchVar(v, CADR(varlist))) InstallVar(v);
}
} else
......@@ -1038,11 +1038,11 @@ static SEXP do_termsform(SEXP call, SEXP op, SEXP args, SEXP rho)
if (haveDot) {
if(length(framenames)) {
PROTECT_INDEX ind;
PROTECT_WITH_INDEX(rhs = install(translateChar(STRING_ELT(framenames, 0))),