The R Project SVN
R
(root)/branches/R-typeset/src/main/options.c – Rev 83467
Rev 83415 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
/** R : A Computer Language for Statistical Data Analysis* Copyright (C) 1998-2022 The R Core Team.* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka** This program is free software; you can redistribute it and/or modify* it under the terms of the GNU General Public License as published by* the Free Software Foundation; either version 2 of the License, or* (at your option) any later version.** This program is distributed in the hope that it will be useful,* but WITHOUT ANY WARRANTY; without even the implied warranty of* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the* GNU General Public License for more details.** You should have received a copy of the GNU General Public License* along with this program; if not, a copy is available at* https://www.R-project.org/Licenses/*/#ifdef HAVE_CONFIG_H#include <config.h>#endif#include "Defn.h"#include <Internal.h>#include "Print.h"#include <Rinternals.h>/* The global var. R_Expressions is in Defn.h */#define R_MIN_EXPRESSIONS_OPT 25#define R_MAX_EXPRESSIONS_OPT 500000/* Interface to the (polymorphous!) options(...) command.** We have two kind of options:* 1) those used exclusively from R code,* typically initialized in Rprofile.* Their names need not appear here, but may, when we want* to make sure that they are assigned `valid' values only.** 2) Those used (and sometimes set) from C code;* Either accessing and/or setting a global C variable,* or just accessed by e.g. GetOption1(install("pager"))** A (complete?!) list of these (2):** "prompt"* "continue"* "expressions"* "width"* "digits"* "echo"* "verbose"* "keep.source"* "keep.source.pkgs"* "keep.parse.data"* "keep.parse.data.pkgs"* "browserNLdisabled"* "de.cellwidth" ../unix/X11/ & ../gnuwin32/dataentry.c* "device"* "pager"* "paper.size" ./devPS.c* "timeout" ./connections.c* "deparse.max.lines" ./deparse.c (& PrintCall() in ./eval.c, ./main.c* "check.bounds"* "error"* "error.messages"* "show.error.messages"* "warn"* "warning.length"* "warning.expression"* "nwarnings"* "matprod"* "PCRE_study"* "PCRE_use_JIT"** S additionally/instead has (and one might think about some)* "free", "keep"* "length", "memory"* "object.size"* "reference", "show"* "scrap"* R_NilValue is not a valid value for any option, but is used to signal a* missing option by FindTaggedItem/GetOption and higher-level functions.*/static SEXP Options(void){static SEXP sOptions = NULL;if(!sOptions) sOptions = install(".Options");return sOptions;}static SEXP FindTaggedItem(SEXP lst, SEXP tag){for ( ; lst != R_NilValue ; lst = CDR(lst)) {if (TAG(lst) == tag) {if (CAR(lst) == R_NilValue)error("option %s has NULL value", CHAR(PRINTNAME(tag)));return lst;}}return R_NilValue;}static SEXP makeErrorCall(SEXP fun){SEXP call;PROTECT(call = allocList(1));SET_TYPEOF(call, LANGSXP);SETCAR(call, fun);UNPROTECT(1);return call;}SEXP GetOption(SEXP tag, SEXP rho){return GetOption1(tag);}SEXP GetOption1(SEXP tag){SEXP opt = SYMVALUE(Options());if (!isList(opt)) error(_("corrupted options list"));opt = FindTaggedItem(opt, tag);return CAR(opt);}int FixupWidth(SEXP width, warn_type warn){int w = asInteger(width);if (w == NA_INTEGER || w < R_MIN_WIDTH_OPT || w > R_MAX_WIDTH_OPT) {switch(warn) {case iWARN: warning(_("invalid printing width %d, used 80"), w);case iSILENT:return 80; // for SILENT and WARNcase iERROR: error(_("invalid printing width"));}}return w;}int GetOptionWidth(void){return FixupWidth(GetOption1(install("width")), iWARN);}int FixupDigits(SEXP digits, warn_type warn){int d = asInteger(digits);if (d == NA_INTEGER || d < R_MIN_DIGITS_OPT || d > R_MAX_DIGITS_OPT) {switch(warn) {case iWARN: warning(_("invalid printing digits %d, used 7"), d);case iSILENT:return 7; // for SILENT and WARNcase iERROR: error(_("invalid printing digits %d"), d);}}return d;}int GetOptionDigits(void){return FixupDigits(GetOption1(install("digits")), iWARN);}attribute_hiddenint GetOptionCutoff(void){int w;w = asInteger(GetOption1(install("deparse.cutoff")));if (w == NA_INTEGER || w <= 0) {warning(_("invalid 'deparse.cutoff', used 60"));w = 60;}return w;}attribute_hiddenRboolean Rf_GetOptionDeviceAsk(void){int ask;ask = asLogical(GetOption1(install("device.ask.default")));if(ask == NA_LOGICAL) {warning(_("invalid value for \"device.ask.default\", using FALSE"));return FALSE;}return ask != 0;}/* Change the value of an option or add a new option or, *//* if called with value R_NilValue, remove that option. */static SEXP SetOption(SEXP tag, SEXP value){SEXP opt, old, t;PROTECT(value);t = opt = SYMVALUE(Options());if (!isList(opt))error(_("corrupted options list"));opt = FindTaggedItem(opt, tag);/* The option is being removed. */if (value == R_NilValue) {for ( ; t != R_NilValue ; t = CDR(t))if (TAG(CDR(t)) == tag) {old = CAR(CDR(t));SETCDR(t, CDDR(t));UNPROTECT(1); /* value */return old;}UNPROTECT(1); /* value */return R_NilValue;}/* If the option is new, a new slot *//* is added to the end of .Options */if (opt == R_NilValue) {while (CDR(t) != R_NilValue)t = CDR(t);SETCDR(t, allocList(1));opt = CDR(t);SET_TAG(opt, tag);}old = CAR(opt);SETCAR(opt, value);UNPROTECT(1); /* value */return old;}/* Set the width of lines for printing i.e. like options(width=...) *//* Returns the previous value for the options. */int attribute_hidden R_SetOptionWidth(int w){SEXP t, v;if (w < R_MIN_WIDTH_OPT) w = R_MIN_WIDTH_OPT;if (w > R_MAX_WIDTH_OPT) w = R_MAX_WIDTH_OPT;PROTECT(t = install("width"));PROTECT(v = ScalarInteger(w));v = SetOption(t, v);UNPROTECT(2);return INTEGER(v)[0];}int attribute_hidden R_SetOptionWarn(int w){SEXP t, v;t = install("warn");PROTECT(v = ScalarInteger(w));v = SetOption(t, v);UNPROTECT(1);return INTEGER(v)[0];}/* Note that options are stored as a dotted pair list *//* This is barely historical, but is also useful. */attribute_hidden void InitOptions(void){SEXP val, v;char *p;/* options set here should be included into mandatory[] in do_options */#ifdef HAVE_RL_COMPLETION_MATCHESPROTECT(v = val = allocList(31));#elsePROTECT(v = val = allocList(30));#endifSET_TAG(v, install("prompt"));SETCAR(v, mkString("> "));v = CDR(v);SET_TAG(v, install("continue"));SETCAR(v, mkString("+ "));v = CDR(v);SET_TAG(v, install("expressions"));SETCAR(v, ScalarInteger(R_Expressions));v = CDR(v);SET_TAG(v, install("width"));SETCAR(v, ScalarInteger(80));v = CDR(v);SET_TAG(v, install("deparse.cutoff"));SETCAR(v, ScalarInteger(60));v = CDR(v);SET_TAG(v, install("digits"));SETCAR(v, ScalarInteger(7));v = CDR(v);SET_TAG(v, install("echo"));SETCAR(v, ScalarLogical(!R_NoEcho));v = CDR(v);SET_TAG(v, install("verbose"));SETCAR(v, ScalarLogical(R_Verbose));v = CDR(v);SET_TAG(v, install("check.bounds"));SETCAR(v, ScalarLogical(0)); /* no checking */v = CDR(v);p = getenv("R_KEEP_PKG_SOURCE");R_KeepSource = (p && (strcmp(p, "yes") == 0)) ? 1 : 0;SET_TAG(v, install("keep.source")); /* overridden in Common.R */SETCAR(v, ScalarLogical(R_KeepSource));v = CDR(v);SET_TAG(v, install("keep.source.pkgs"));SETCAR(v, ScalarLogical(R_KeepSource));v = CDR(v);SET_TAG(v, install("keep.parse.data"));SETCAR(v, ScalarLogical(TRUE));v = CDR(v);p = getenv("R_KEEP_PKG_PARSE_DATA");SET_TAG(v, install("keep.parse.data.pkgs"));SETCAR(v, ScalarLogical((p && (strcmp(p, "yes") == 0)) ? TRUE : FALSE));v = CDR(v);SET_TAG(v, install("warning.length"));SETCAR(v, ScalarInteger(R_WarnLength));v = CDR(v);SET_TAG(v, install("nwarnings"));SETCAR(v, ScalarInteger(R_nwarnings));v = CDR(v);SET_TAG(v, install("OutDec"));SETCAR(v, mkString(OutDec));v = CDR(v);SET_TAG(v, install("browserNLdisabled"));SETCAR(v, ScalarLogical(FALSE));v = CDR(v);p = getenv("R_C_BOUNDS_CHECK");R_CBoundsCheck = (p && (strcmp(p, "yes") == 0)) ? 1 : 0;SET_TAG(v, install("CBoundsCheck"));SETCAR(v, ScalarLogical(R_CBoundsCheck));v = CDR(v);SET_TAG(v, install("matprod"));switch(R_Matprod) {case MATPROD_DEFAULT: p = "default"; break;case MATPROD_INTERNAL: p = "internal"; break;case MATPROD_BLAS: p = "blas"; break;case MATPROD_DEFAULT_SIMD: p = "default.simd"; break;}SETCAR(v, mkString(p));v = CDR(v);SET_TAG(v, install("PCRE_study"));if (R_PCRE_study == -1)SETCAR(v, ScalarLogical(TRUE));else if (R_PCRE_study == -2)SETCAR(v, ScalarLogical(FALSE));elseSETCAR(v, ScalarInteger(R_PCRE_study));v = CDR(v);SET_TAG(v, install("PCRE_use_JIT"));SETCAR(v, ScalarLogical(R_PCRE_use_JIT));v = CDR(v);SET_TAG(v, install("PCRE_limit_recursion"));R_PCRE_limit_recursion = NA_LOGICAL;SETCAR(v, ScalarLogical(R_PCRE_limit_recursion));v = CDR(v);SET_TAG(v, install("max.contour.segments"));SETCAR(v, ScalarInteger(max_contour_segments));v = CDR(v);SET_TAG(v, install("warnPartialMatchDollar"));SETCAR(v, ScalarLogical(R_warn_partial_match_dollar));v = CDR(v);SET_TAG(v, install("warnPartialMatchArgs"));SETCAR(v, ScalarLogical(R_warn_partial_match_args));v = CDR(v);SET_TAG(v, install("warnPartialMatchAttr"));SETCAR(v, ScalarLogical(R_warn_partial_match_attr));v = CDR(v);SET_TAG(v, install("showWarnCalls"));SETCAR(v, ScalarLogical(R_ShowWarnCalls));v = CDR(v);SET_TAG(v, install("showErrorCalls"));SETCAR(v, ScalarLogical(R_ShowErrorCalls));v = CDR(v);SET_TAG(v, install("showNCalls"));SETCAR(v, ScalarInteger(R_NShowCalls));v = CDR(v);SET_TAG(v, install("browserNLdisabled"));SETCAR(v, ScalarLogical(R_DisableNLinBrowser));v = CDR(v);/* options set here should be included into mandatory[] in do_options */#ifdef HAVE_RL_COMPLETION_MATCHES/* value from Rf_initialize_R */SET_TAG(v, install("rl_word_breaks"));SETCAR(v, mkString(" \t\n\"\\'`><=%;,|&{()}"));set_rl_word_breaks(" \t\n\"\\'`><=%;,|&{()}");#endifSET_SYMVALUE(install(".Options"), val);UNPROTECT(1);}attribute_hidden SEXP do_getOption(SEXP call, SEXP op, SEXP args, SEXP rho){checkArity(op, args);SEXP x = CAR(args);if (!isString(x) || LENGTH(x) != 1)error(_("'%s' must be a character string"), "x");return duplicate(GetOption1(installTrChar(STRING_ELT(x, 0))));}static Rboolean warned_on_strings_as_fact = FALSE; // -> once-per-session warning/* This needs to manage R_Visible */attribute_hidden SEXP 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 sessionframe.*/options = SYMVALUE(Options());/* This code is not re-entrant and people have used it infinalizers.If a re-entrancy lock needs to be added, note that itwould 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 ofname = 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);}PROTECT(argnames);Rboolean 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);SET_STRING_ELT(names, i, namei);if (argi == R_NilValue) {/* Handle option removal separately to simplify value checkingfor known options below; mandatory means not allowed to beremoved once set. It makes sense to also set these optionsat startup, because otherwise one could not reliably restorepreviously saved options (see also PR#18372).*/const char *mandatory[] = {"prompt", "continue", "expressions","width", "deparse.cutoff", "digits", "echo", "verbose","check.bounds", "keep.source", "keep.source.pkgs","keep.parse.data", "keep.parse.data.pkgs", "warning.length","nwarnings", "OutDec", "browserNLdisabled", "CBoundsCheck","matprod", "PCRE_study", "PCRE_use_JIT","PCRE_limit_recursion", "rl_word_breaks","max.contour.segments", "warnPartialMatchDollar","warnPartialMatchArgs", "warnPartialMatchAttr","showWarnCalls", "showErrorCalls", "showNCalls","browserNLdisabled",/* ^^^ from InitOptions ^^^ */"warn", "max.print", "show.error.messages",/* ^^^ from Common.R ^^^ */NULL};for(int j = 0; mandatory[j] != NULL; j++)if (streql(CHAR(namei), mandatory[j]))error(_("option '%s' cannot be deleted"), CHAR(namei));SET_VECTOR_ELT(value, i, SetOption(tag, R_NilValue));} else if (streql(CHAR(namei), "width")) {int k = asInteger(argi);if (k < R_MIN_WIDTH_OPT || k > R_MAX_WIDTH_OPT)error(_("invalid '%s' parameter, allowed %d...%d"),CHAR(namei), 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 '%s' parameter, allowed %d...%d"),CHAR(namei), 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(_("invalid '%s' parameter, allowed %d...%d"), CHAR(namei),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));int k;// k = asInteger(argi) wld give both error + warningif(TYPEOF(argi) == REALSXP) {int w;k = IntegerFromReal(REAL_ELT(argi, 0), &w);} else {k = asInteger(argi);}if (k == NA_INTEGER)error(_("invalid value for '%s'"), CHAR(namei));#ifdef _NOT_YET_char *p = getenv("R_WARN_BOUNDS_OPT");if ((p && (strcmp(p, "yes") == 0)) && (k < -1 || k > 2)) {int k_n = (k < 0) ? -1 : 2;REprintf(_("value for '%s' outside of -1:2 is set to %d\n"),CHAR(namei), k_n);k = k_n;}#endifSET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));}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_NoEcho = !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 errorwarning(_("'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_MATCHESset_rl_word_breaks(CHAR(STRING_ELT(argi, 0)));#endifSET_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 if (streql(CHAR(namei), "matprod")) {SEXP s = asChar(argi);if (s == NA_STRING || LENGTH(s) == 0)error(_("invalid value for '%s'"), CHAR(namei));if (streql(CHAR(s), "default"))R_Matprod = MATPROD_DEFAULT;else if (streql(CHAR(s), "internal"))R_Matprod = MATPROD_INTERNAL;else if (streql(CHAR(s), "blas"))R_Matprod = MATPROD_BLAS;else if (streql(CHAR(s), "default.simd")) {R_Matprod = MATPROD_DEFAULT_SIMD;#if !defined(_OPENMP) || !defined(HAVE_OPENMP_SIMDRED)warning(_("OpenMP SIMD is not supported in this build of R"));#endif} elseerror(_("invalid value for '%s'"), CHAR(namei));SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));}else if (streql(CHAR(namei), "PCRE_study")) {if (TYPEOF(argi) == LGLSXP) {int k = asLogical(argi) > 0;R_PCRE_study = k ? -1 : -2;SET_VECTOR_ELT(value, i,SetOption(tag, ScalarLogical(k)));} else {R_PCRE_study = asInteger(argi);if (R_PCRE_study < 0) {R_PCRE_study = -2;SET_VECTOR_ELT(value, i,SetOption(tag, ScalarLogical(-2)));} elseSET_VECTOR_ELT(value, i,SetOption(tag, ScalarInteger(R_PCRE_study)));}#ifdef HAVE_PCRE2if (R_PCRE_study != -2)warning(_("'PCRE_study' has no effect with PCRE2"));#endif}else if (streql(CHAR(namei), "PCRE_use_JIT")) {int use_JIT = asLogical(argi);R_PCRE_use_JIT = (use_JIT > 0); // NA_LOGICAL is < 0SET_VECTOR_ELT(value, i,SetOption(tag, ScalarLogical(R_PCRE_use_JIT)));}else if (streql(CHAR(namei), "PCRE_limit_recursion")) {R_PCRE_limit_recursion = asLogical(argi);SET_VECTOR_ELT(value, i,SetOption(tag, ScalarLogical(R_PCRE_limit_recursion)));/* could warn for PCRE2 >= 10.30, but the value is ignored also whenJIT is used */}else if (streql(CHAR(namei), "stringsAsFactors")) {int strings_as_fact;if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1 ||(strings_as_fact = asLogical(argi)) == NA_LOGICAL)error(_("invalid value for '%s'"), CHAR(namei));if(strings_as_fact && !warned_on_strings_as_fact) {warned_on_strings_as_fact = TRUE;warning(_("'%s' is deprecated and will be disabled"),"options(stringsAsFactors = TRUE)");}SET_VECTOR_ELT(value, i,SetOption(tag, ScalarLogical(strings_as_fact)));}else if (streql(CHAR(namei), "verbose")) {if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)error(_("invalid value for '%s'"), CHAR(namei));int k = asLogical(argi);R_Verbose = k;SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));}else {SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));}}else { /* querying arg */const char *tag;if (!isString(argi) || LENGTH(argi) <= 0)error(_("invalid argument"));tag = translateChar(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));visible = TRUE;}} /* for() */setAttrib(value, R_NamesSymbol, names);UNPROTECT(3); /* value, names, argnames */R_Visible = visible;return value;}