in source/src/main/options.c [345:673]
SEXP attribute_hidden do_options(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP names, value, options;
/* Locate the options values in the symbol table.
This will need to change if options are to live in the session
frame.
*/
options = SYMVALUE(Options());
/* This code is not re-entrant and people have used it in
finalizers.
If a re-entrancy lock needs to be added, note that it
would apply to R_SetOption* too.
*/
checkArity(op, args);
if (args == R_NilValue) {
/* This is the zero argument case.
We alloc up a vector list and write the system values into it.
*/
int n = length(options);
PROTECT(value = allocVector(VECSXP, n));
PROTECT(names = allocVector(STRSXP, n));
for (int i = 0; i < n; i++) {
SET_STRING_ELT(names, i, PRINTNAME(TAG(options)));
SET_VECTOR_ELT(value, i, duplicate(CAR(options)));
options = CDR(options);
}
SEXP sind = PROTECT(allocVector(INTSXP, n));
int *indx = INTEGER(sind);
for (int i = 0; i < n; i++) indx[i] = i;
orderVector1(indx, n, names, TRUE, FALSE, R_NilValue);
SEXP value2 = PROTECT(allocVector(VECSXP, n));
SEXP names2 = PROTECT(allocVector(STRSXP, n));
for(int i = 0; i < n; i++) {
SET_STRING_ELT(names2, i, STRING_ELT(names, indx[i]));
SET_VECTOR_ELT(value2, i, VECTOR_ELT(value, indx[i]));
}
setAttrib(value2, R_NamesSymbol, names2);
UNPROTECT(5);
R_Visible = TRUE;
return value2;
}
/* The arguments to "options" can either be a sequence of
name = value form, or can be a single list.
This means that we must code so that both forms will work.
[ Vomits quietly onto shoes ... ]
*/
int n = length(args);
if (n == 1 && (isPairList(CAR(args)) || isVectorList(CAR(args)))
&& TAG(args) == R_NilValue ) {
args = CAR(args);
n = length(args);
}
PROTECT(value = allocVector(VECSXP, n));
PROTECT(names = allocVector(STRSXP, n));
SEXP argnames = R_NilValue;
switch (TYPEOF(args)) {
case NILSXP:
case LISTSXP:
break;
case VECSXP:
if(n > 0) {
argnames = getAttrib(args, R_NamesSymbol);
if(LENGTH(argnames) != n)
error(_("list argument has no valid names"));
}
break;
default:
UNIMPLEMENTED_TYPE("options", args);
}
R_Visible = FALSE;
for (int i = 0 ; i < n ; i++) { /* i-th argument */
SEXP argi = R_NilValue, namei = R_NilValue;
switch (TYPEOF(args)) {
case LISTSXP:
argi = CAR(args);
namei = EnsureString(TAG(args)); /* gives "" for no tag */
args = CDR(args);
break;
case VECSXP:
argi = VECTOR_ELT(args, i);
namei = STRING_ELT(argnames, i);
break;
default: /* already checked, but be safe here */
UNIMPLEMENTED_TYPE("options", args);
}
if (*CHAR(namei)) { /* name = value ---> assignment */
SEXP tag = installTrChar(namei);
if (streql(CHAR(namei), "width")) {
int k = asInteger(argi);
if (k < R_MIN_WIDTH_OPT || k > R_MAX_WIDTH_OPT)
error(_("invalid 'width' parameter, allowed %d...%d"),
R_MIN_WIDTH_OPT, R_MAX_WIDTH_OPT);
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "deparse.cutoff")) {
int k = asInteger(argi);
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "digits")) {
int k = asInteger(argi);
if (k < R_MIN_DIGITS_OPT || k > R_MAX_DIGITS_OPT)
error(_("invalid 'digits' parameter, allowed %d...%d"),
R_MIN_DIGITS_OPT, R_MAX_DIGITS_OPT);
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "expressions")) {
int k = asInteger(argi);
if (k < R_MIN_EXPRESSIONS_OPT || k > R_MAX_EXPRESSIONS_OPT)
error(_("'expressions' parameter invalid, allowed %d...%d"),
R_MIN_EXPRESSIONS_OPT, R_MAX_EXPRESSIONS_OPT);
R_Expressions = R_Expressions_keep = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "keep.source")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_KeepSource = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "editor") && isString(argi)) {
SEXP s = asChar(argi);
if (s == NA_STRING || LENGTH(s) == 0)
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarString(s)));
}
else if (streql(CHAR(namei), "continue")) {
SEXP s = asChar(argi);
if (s == NA_STRING || LENGTH(s) == 0)
error(_("invalid value for '%s'"), CHAR(namei));
/* We want to make sure these are in the native encoding */
SET_VECTOR_ELT(value, i,
SetOption(tag, mkString(translateChar(s))));
}
else if (streql(CHAR(namei), "prompt")) {
SEXP s = asChar(argi);
if (s == NA_STRING || LENGTH(s) == 0)
error(_("invalid value for '%s'"), CHAR(namei));
/* We want to make sure these are in the native encoding */
SET_VECTOR_ELT(value, i,
SetOption(tag, mkString(translateChar(s))));
}
else if (streql(CHAR(namei), "contrasts")) {
if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 2)
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
}
else if (streql(CHAR(namei), "check.bounds")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
/* R_CheckBounds = k; */
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "warn")) {
if (!isNumeric(argi) || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
}
else if (streql(CHAR(namei), "warning.length")) {
int k = asInteger(argi);
if (k < 100 || k > 8170)
error(_("invalid value for '%s'"), CHAR(namei));
R_WarnLength = k;
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
}
else if ( streql(CHAR(namei), "warning.expression") ) {
if( !isLanguage(argi) && ! isExpression(argi) )
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
}
else if (streql(CHAR(namei), "max.print")) {
int k = asInteger(argi);
if (k < 1) error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "nwarnings")) {
int k = asInteger(argi);
if (k < 1) error(_("invalid value for '%s'"), CHAR(namei));
R_nwarnings = k;
R_CollectWarnings = 0; /* force a reset */
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if ( streql(CHAR(namei), "error") ) {
if(isFunction(argi))
argi = makeErrorCall(argi);
else if( !isLanguage(argi) && !isExpression(argi) )
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
}
/* handle this here to avoid GetOption during error handling */
else if ( streql(CHAR(namei), "show.error.messages") ) {
if( !isLogical(argi) && LENGTH(argi) != 1 )
error(_("invalid value for '%s'"), CHAR(namei));
SET_VECTOR_ELT(value, i, SetOption(tag, argi));
R_ShowErrorMessages = LOGICAL(argi)[0];
}
else if (streql(CHAR(namei), "echo")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
/* Should be quicker than checking options(echo)
every time R prompts for input:
*/
R_Slave = !k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "OutDec")) {
if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
static char sdec[11];
if(R_nchar(STRING_ELT(argi, 0), Chars,
/* allowNA = */ FALSE, /* keepNA = */ FALSE,
"OutDec") != 1) // will become an error
warning(_("'OutDec' must be a string of one character"));
strncpy(sdec, CHAR(STRING_ELT(argi, 0)), 10);
sdec[10] = '\0';
OutDec = sdec;
SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
}
else if (streql(CHAR(namei), "max.contour.segments")) {
int k = asInteger(argi);
if (k < 0) // also many times above: rely on NA_INTEGER < <finite_int>
error(_("invalid value for '%s'"), CHAR(namei));
max_contour_segments = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "rl_word_breaks")) {
if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
#ifdef HAVE_RL_COMPLETION_MATCHES
set_rl_word_breaks(CHAR(STRING_ELT(argi, 0)));
#endif
SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
}
else if (streql(CHAR(namei), "warnPartialMatchDollar")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_warn_partial_match_dollar = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "warnPartialMatchArgs")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_warn_partial_match_args = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "warnPartialMatchAttr")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_warn_partial_match_attr = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "showWarnCalls")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_ShowWarnCalls = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "showErrorCalls")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_ShowErrorCalls = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "showNCalls")) {
int k = asInteger(argi);
if (k < 30 || k > 500 || k == NA_INTEGER || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
R_NShowCalls = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
}
else if (streql(CHAR(namei), "par.ask.default")) {
error(_("\"par.ask.default\" has been replaced by \"device.ask.default\""));
}
else if (streql(CHAR(namei), "browserNLdisabled")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
if (k == NA_LOGICAL)
error(_("invalid value for '%s'"), CHAR(namei));
R_DisableNLinBrowser = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else if (streql(CHAR(namei), "CBoundsCheck")) {
if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
error(_("invalid value for '%s'"), CHAR(namei));
int k = asLogical(argi);
R_CBoundsCheck = k;
SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
}
else {
SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
}
SET_STRING_ELT(names, i, namei);
}
else { /* querying arg */
const char *tag;
if (!isString(argi) || LENGTH(argi) <= 0)
error(_("invalid argument"));
tag = CHAR(STRING_ELT(argi, 0));
if (streql(tag, "par.ask.default")) {
error(_("\"par.ask.default\" has been replaced by \"device.ask.default\""));
}
SET_VECTOR_ELT(value, i, duplicate(CAR(FindTaggedItem(options, install(tag)))));
SET_STRING_ELT(names, i, STRING_ELT(argi, 0));
R_Visible = TRUE;
}
} /* for() */
setAttrib(value, R_NamesSymbol, names);
UNPROTECT(2);
return value;
}