1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1998-2020 The R Core Team.
4 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
5 *
6 * This program is free software; you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation; either version 2 of the License, or
9 * (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU General Public License for more details.
15 *
16 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 #ifdef HAVE_CONFIG_H
22 #include <config.h>
23 #endif
24
25 #include "Defn.h"
26 #include <Internal.h>
27 #include "Print.h"
28 #include <Rinternals.h>
29
30 /* The global var. R_Expressions is in Defn.h */
31 #define R_MIN_EXPRESSIONS_OPT 25
32 #define R_MAX_EXPRESSIONS_OPT 500000
33
34 /* Interface to the (polymorphous!) options(...) command.
35 *
36 * We have two kind of options:
37 * 1) those used exclusively from R code,
38 * typically initialized in Rprofile.
39
40 * Their names need not appear here, but may, when we want
41 * to make sure that they are assigned `valid' values only.
42 *
43 * 2) Those used (and sometimes set) from C code;
44 * Either accessing and/or setting a global C variable,
45 * or just accessed by e.g. GetOption1(install("pager"))
46 *
47 * A (complete?!) list of these (2):
48 *
49 * "prompt"
50 * "continue"
51 * "expressions"
52 * "width"
53 * "digits"
54 * "echo"
55 * "verbose"
56 * "keep.source"
57 * "keep.source.pkgs"
58 * "keep.parse.data"
59 * "keep.parse.data.pkgs"
60 * "browserNLdisabled"
61
62 * "de.cellwidth" ../unix/X11/ & ../gnuwin32/dataentry.c
63 * "device"
64 * "pager"
65 * "paper.size" ./devPS.c
66
67 * "timeout" ./connections.c
68
69 * "deparse.max.lines" ./deparse.c (& PrintCall() in ./eval.c, ./main.c
70
71 * "check.bounds"
72 * "error"
73 * "error.messages"
74 * "show.error.messages"
75 * "warn"
76 * "warning.length"
77 * "warning.expression"
78 * "nwarnings"
79
80 * "matprod"
81 * "PCRE_study"
82 * "PCRE_use_JIT"
83
84 *
85 * S additionally/instead has (and one might think about some)
86 * "free", "keep"
87 * "length", "memory"
88 * "object.size"
89 * "reference", "show"
90 * "scrap"
91
92 * R_NilValue is not a valid value for any option, but is used to signal a
93 * missing option by FindTaggedItem/GetOption and higher-level functions.
94 */
95
96
Options(void)97 static SEXP Options(void)
98 {
99 static SEXP sOptions = NULL;
100 if(!sOptions) sOptions = install(".Options");
101 return sOptions;
102 }
103
FindTaggedItem(SEXP lst,SEXP tag)104 static SEXP FindTaggedItem(SEXP lst, SEXP tag)
105 {
106 for ( ; lst != R_NilValue ; lst = CDR(lst)) {
107 if (TAG(lst) == tag) {
108 if (CAR(lst) == R_NilValue)
109 error("option %s has NULL value", CHAR(PRINTNAME(tag)));
110 return lst;
111 }
112 }
113 return R_NilValue;
114 }
115
makeErrorCall(SEXP fun)116 static SEXP makeErrorCall(SEXP fun)
117 {
118 SEXP call;
119 PROTECT(call = allocList(1));
120 SET_TYPEOF(call, LANGSXP);
121 SETCAR(call, fun);
122 UNPROTECT(1);
123 return call;
124 }
125
GetOption(SEXP tag,SEXP rho)126 SEXP GetOption(SEXP tag, SEXP rho)
127 {
128 return GetOption1(tag);
129 }
130
131
GetOption1(SEXP tag)132 SEXP GetOption1(SEXP tag)
133 {
134 SEXP opt = SYMVALUE(Options());
135 if (!isList(opt)) error(_("corrupted options list"));
136 opt = FindTaggedItem(opt, tag);
137 return CAR(opt);
138 }
139
FixupWidth(SEXP width,warn_type warn)140 int FixupWidth(SEXP width, warn_type warn)
141 {
142 int w = asInteger(width);
143 if (w == NA_INTEGER || w < R_MIN_WIDTH_OPT || w > R_MAX_WIDTH_OPT) {
144 switch(warn) {
145 case iWARN: warning(_("invalid printing width %d, used 80"), w);
146 case iSILENT:
147 return 80; // for SILENT and WARN
148 case iERROR: error(_("invalid printing width"));
149 }
150 }
151 return w;
152 }
GetOptionWidth(void)153 int GetOptionWidth(void)
154 {
155 return FixupWidth(GetOption1(install("width")), iWARN);
156 }
157
FixupDigits(SEXP digits,warn_type warn)158 int FixupDigits(SEXP digits, warn_type warn)
159 {
160 int d = asInteger(digits);
161 if (d == NA_INTEGER || d < R_MIN_DIGITS_OPT || d > R_MAX_DIGITS_OPT) {
162 switch(warn) {
163 case iWARN: warning(_("invalid printing digits %d, used 7"), d);
164 case iSILENT:
165 return 7; // for SILENT and WARN
166 case iERROR: error(_("invalid printing digits %d"), d);
167 }
168 }
169 return d;
170 }
GetOptionDigits(void)171 int GetOptionDigits(void)
172 {
173 return FixupDigits(GetOption1(install("digits")), iWARN);
174 }
175
176 attribute_hidden
GetOptionCutoff(void)177 int GetOptionCutoff(void)
178 {
179 int w;
180 w = asInteger(GetOption1(install("deparse.cutoff")));
181 if (w == NA_INTEGER || w <= 0) {
182 warning(_("invalid 'deparse.cutoff', used 60"));
183 w = 60;
184 }
185 return w;
186 }
187
188 attribute_hidden
Rf_GetOptionDeviceAsk(void)189 Rboolean Rf_GetOptionDeviceAsk(void)
190 {
191 int ask;
192 ask = asLogical(GetOption1(install("device.ask.default")));
193 if(ask == NA_LOGICAL) {
194 warning(_("invalid value for \"device.ask.default\", using FALSE"));
195 return FALSE;
196 }
197 return ask != 0;
198 }
199
200
201 /* Change the value of an option or add a new option or, */
202 /* if called with value R_NilValue, remove that option. */
203
SetOption(SEXP tag,SEXP value)204 static SEXP SetOption(SEXP tag, SEXP value)
205 {
206 SEXP opt, old, t;
207 PROTECT(value);
208 t = opt = SYMVALUE(Options());
209 if (!isList(opt))
210 error(_("corrupted options list"));
211 opt = FindTaggedItem(opt, tag);
212
213 /* The option is being removed. */
214 if (value == R_NilValue) {
215 for ( ; t != R_NilValue ; t = CDR(t))
216 if (TAG(CDR(t)) == tag) {
217 old = CAR(CDR(t));
218 SETCDR(t, CDDR(t));
219 UNPROTECT(1); /* value */
220 return old;
221 }
222 UNPROTECT(1); /* value */
223 return R_NilValue;
224 }
225 /* If the option is new, a new slot */
226 /* is added to the end of .Options */
227 if (opt == R_NilValue) {
228 while (CDR(t) != R_NilValue)
229 t = CDR(t);
230 SETCDR(t, allocList(1));
231 opt = CDR(t);
232 SET_TAG(opt, tag);
233 }
234 old = CAR(opt);
235 SETCAR(opt, value);
236 UNPROTECT(1); /* value */
237 return old;
238 }
239
240 /* Set the width of lines for printing i.e. like options(width=...) */
241 /* Returns the previous value for the options. */
242
R_SetOptionWidth(int w)243 int attribute_hidden R_SetOptionWidth(int w)
244 {
245 SEXP t, v;
246 if (w < R_MIN_WIDTH_OPT) w = R_MIN_WIDTH_OPT;
247 if (w > R_MAX_WIDTH_OPT) w = R_MAX_WIDTH_OPT;
248 PROTECT(t = install("width"));
249 PROTECT(v = ScalarInteger(w));
250 v = SetOption(t, v);
251 UNPROTECT(2);
252 return INTEGER(v)[0];
253 }
254
R_SetOptionWarn(int w)255 int attribute_hidden R_SetOptionWarn(int w)
256 {
257 SEXP t, v;
258
259 t = install("warn");
260 PROTECT(v = ScalarInteger(w));
261 v = SetOption(t, v);
262 UNPROTECT(1);
263 return INTEGER(v)[0];
264 }
265
266 /* Note that options are stored as a dotted pair list */
267 /* This is barely historical, but is also useful. */
268
InitOptions(void)269 void attribute_hidden InitOptions(void)
270 {
271 SEXP val, v;
272 char *p;
273
274 /* options set here should be included into mandatory[] in do_options */
275 #ifdef HAVE_RL_COMPLETION_MATCHES
276 PROTECT(v = val = allocList(23));
277 #else
278 PROTECT(v = val = allocList(22));
279 #endif
280
281 SET_TAG(v, install("prompt"));
282 SETCAR(v, mkString("> "));
283 v = CDR(v);
284
285 SET_TAG(v, install("continue"));
286 SETCAR(v, mkString("+ "));
287 v = CDR(v);
288
289 SET_TAG(v, install("expressions"));
290 SETCAR(v, ScalarInteger(R_Expressions));
291 v = CDR(v);
292
293 SET_TAG(v, install("width"));
294 SETCAR(v, ScalarInteger(80));
295 v = CDR(v);
296
297 SET_TAG(v, install("deparse.cutoff"));
298 SETCAR(v, ScalarInteger(60));
299 v = CDR(v);
300
301 SET_TAG(v, install("digits"));
302 SETCAR(v, ScalarInteger(7));
303 v = CDR(v);
304
305 SET_TAG(v, install("echo"));
306 SETCAR(v, ScalarLogical(!R_NoEcho));
307 v = CDR(v);
308
309 SET_TAG(v, install("verbose"));
310 SETCAR(v, ScalarLogical(R_Verbose));
311 v = CDR(v);
312
313 SET_TAG(v, install("check.bounds"));
314 SETCAR(v, ScalarLogical(0)); /* no checking */
315 v = CDR(v);
316
317 p = getenv("R_KEEP_PKG_SOURCE");
318 R_KeepSource = (p && (strcmp(p, "yes") == 0)) ? 1 : 0;
319
320 SET_TAG(v, install("keep.source")); /* overridden in Common.R */
321 SETCAR(v, ScalarLogical(R_KeepSource));
322 v = CDR(v);
323
324 SET_TAG(v, install("keep.source.pkgs"));
325 SETCAR(v, ScalarLogical(R_KeepSource));
326 v = CDR(v);
327
328 SET_TAG(v, install("keep.parse.data"));
329 SETCAR(v, ScalarLogical(TRUE));
330 v = CDR(v);
331
332 p = getenv("R_KEEP_PKG_PARSE_DATA");
333 SET_TAG(v, install("keep.parse.data.pkgs"));
334 SETCAR(v, ScalarLogical((p && (strcmp(p, "yes") == 0)) ? TRUE : FALSE));
335 v = CDR(v);
336
337 SET_TAG(v, install("warning.length"));
338 SETCAR(v, ScalarInteger(1000));
339 v = CDR(v);
340
341 SET_TAG(v, install("nwarnings"));
342 SETCAR(v, ScalarInteger(50));
343 v = CDR(v);
344
345 SET_TAG(v, install("OutDec"));
346 SETCAR(v, mkString("."));
347 v = CDR(v);
348
349 SET_TAG(v, install("browserNLdisabled"));
350 SETCAR(v, ScalarLogical(FALSE));
351 v = CDR(v);
352
353 p = getenv("R_C_BOUNDS_CHECK");
354 R_CBoundsCheck = (p && (strcmp(p, "yes") == 0)) ? 1 : 0;
355
356 SET_TAG(v, install("CBoundsCheck"));
357 SETCAR(v, ScalarLogical(R_CBoundsCheck));
358 v = CDR(v);
359
360 SET_TAG(v, install("matprod"));
361 switch(R_Matprod) {
362 case MATPROD_DEFAULT: p = "default"; break;
363 case MATPROD_INTERNAL: p = "internal"; break;
364 case MATPROD_BLAS: p = "blas"; break;
365 case MATPROD_DEFAULT_SIMD: p = "default.simd"; break;
366 }
367 SETCAR(v, mkString(p));
368 v = CDR(v);
369
370 SET_TAG(v, install("PCRE_study"));
371 if (R_PCRE_study == -1)
372 SETCAR(v, ScalarLogical(TRUE));
373 else if (R_PCRE_study == -2)
374 SETCAR(v, ScalarLogical(FALSE));
375 else
376 SETCAR(v, ScalarInteger(R_PCRE_study));
377 v = CDR(v);
378
379 SET_TAG(v, install("PCRE_use_JIT"));
380 SETCAR(v, ScalarLogical(R_PCRE_use_JIT));
381 v = CDR(v);
382
383 SET_TAG(v, install("PCRE_limit_recursion"));
384 R_PCRE_limit_recursion = NA_LOGICAL;
385 SETCAR(v, ScalarLogical(R_PCRE_limit_recursion));
386 v = CDR(v);
387 /* options set here should be included into mandatory[] in do_options */
388
389 #ifdef HAVE_RL_COMPLETION_MATCHES
390 /* value from Rf_initialize_R */
391 SET_TAG(v, install("rl_word_breaks"));
392 SETCAR(v, mkString(" \t\n\"\\'`><=%;,|&{()}"));
393 set_rl_word_breaks(" \t\n\"\\'`><=%;,|&{()}");
394 #endif
395
396 SET_SYMVALUE(install(".Options"), val);
397 UNPROTECT(1);
398 }
399
400
do_getOption(SEXP call,SEXP op,SEXP args,SEXP rho)401 SEXP attribute_hidden do_getOption(SEXP call, SEXP op, SEXP args, SEXP rho)
402 {
403 checkArity(op, args);
404 SEXP x = CAR(args);
405 if (!isString(x) || LENGTH(x) != 1)
406 error(_("'%s' must be a character string"), "x");
407 return duplicate(GetOption1(installTrChar(STRING_ELT(x, 0))));
408 }
409
410
411 static Rboolean warned_on_strings_as_fact = FALSE; // -> once-per-session warning
412
413 /* This needs to manage R_Visible */
do_options(SEXP call,SEXP op,SEXP args,SEXP rho)414 SEXP attribute_hidden do_options(SEXP call, SEXP op, SEXP args, SEXP rho)
415 {
416 SEXP names, value, options;
417
418 /* Locate the options values in the symbol table.
419 This will need to change if options are to live in the session
420 frame.
421 */
422
423 options = SYMVALUE(Options());
424
425 /* This code is not re-entrant and people have used it in
426 finalizers.
427
428 If a re-entrancy lock needs to be added, note that it
429 would apply to R_SetOption* too.
430 */
431
432 checkArity(op, args);
433 if (args == R_NilValue) {
434 /* This is the zero argument case.
435 We alloc up a vector list and write the system values into it.
436 */
437 int n = length(options);
438 PROTECT(value = allocVector(VECSXP, n));
439 PROTECT(names = allocVector(STRSXP, n));
440 for (int i = 0; i < n; i++) {
441 SET_STRING_ELT(names, i, PRINTNAME(TAG(options)));
442 SET_VECTOR_ELT(value, i, duplicate(CAR(options)));
443 options = CDR(options);
444 }
445 SEXP sind = PROTECT(allocVector(INTSXP, n));
446 int *indx = INTEGER(sind);
447 for (int i = 0; i < n; i++) indx[i] = i;
448 orderVector1(indx, n, names, TRUE, FALSE, R_NilValue);
449 SEXP value2 = PROTECT(allocVector(VECSXP, n));
450 SEXP names2 = PROTECT(allocVector(STRSXP, n));
451 for(int i = 0; i < n; i++) {
452 SET_STRING_ELT(names2, i, STRING_ELT(names, indx[i]));
453 SET_VECTOR_ELT(value2, i, VECTOR_ELT(value, indx[i]));
454 }
455 setAttrib(value2, R_NamesSymbol, names2);
456 UNPROTECT(5);
457 R_Visible = TRUE;
458 return value2;
459 }
460
461 /* The arguments to "options" can either be a sequence of
462 name = value form, or can be a single list.
463 This means that we must code so that both forms will work.
464 [ Vomits quietly onto shoes ... ]
465 */
466
467 int n = length(args);
468 if (n == 1 && (isPairList(CAR(args)) || isVectorList(CAR(args)))
469 && TAG(args) == R_NilValue ) {
470 args = CAR(args);
471 n = length(args);
472 }
473 PROTECT(value = allocVector(VECSXP, n));
474 PROTECT(names = allocVector(STRSXP, n));
475
476 SEXP argnames = R_NilValue;
477 switch (TYPEOF(args)) {
478 case NILSXP:
479 case LISTSXP:
480 break;
481 case VECSXP:
482 if(n > 0) {
483 argnames = getAttrib(args, R_NamesSymbol);
484 if(LENGTH(argnames) != n)
485 error(_("list argument has no valid names"));
486 }
487 break;
488 default:
489 UNIMPLEMENTED_TYPE("options", args);
490 }
491 PROTECT(argnames);
492
493 Rboolean visible = FALSE;
494 for (int i = 0 ; i < n ; i++) { /* i-th argument */
495 SEXP argi = R_NilValue, namei = R_NilValue;
496 switch (TYPEOF(args)) {
497 case LISTSXP:
498 argi = CAR(args);
499 namei = EnsureString(TAG(args)); /* gives "" for no tag */
500 args = CDR(args);
501 break;
502 case VECSXP:
503 argi = VECTOR_ELT(args, i);
504 namei = STRING_ELT(argnames, i);
505 break;
506 default: /* already checked, but be safe here */
507 UNIMPLEMENTED_TYPE("options", args);
508 }
509
510 if (*CHAR(namei)) { /* name = value ---> assignment */
511 SEXP tag = installTrChar(namei);
512 SET_STRING_ELT(names, i, namei);
513
514 if (argi == R_NilValue) {
515 /* Handle option removal separately to simplify value checking
516 for known options below; mandatory means not allowed to be
517 removed once set, but not all have to be set at startup. */
518 const char *mandatory[] = {"prompt", "continue", "expressions",
519 "width", "deparse.cutoff", "digits", "echo", "verbose",
520 "check.bounds", "keep.source", "keep.source.pkgs",
521 "keep.parse.data", "keep.parse.data.pkgs", "warning.length",
522 "nwarnings", "OutDec", "browserNLdisabled", "CBoundsCheck",
523 "matprod", "PCRE_study", "PCRE_use_JIT",
524 "PCRE_limit_recursion", "rl_word_breaks",
525 /* ^^^ from InitOptions ^^^ */
526 "warn", "max.print", "show.error.messages",
527 /* ^^^ from Common.R ^^^ */
528 NULL};
529 for(int j = 0; mandatory[j] != NULL; j++)
530 if (streql(CHAR(namei), mandatory[j]))
531 error(_("option '%s' cannot be deleted"), CHAR(namei));
532 SET_VECTOR_ELT(value, i, SetOption(tag, R_NilValue));
533 } else if (streql(CHAR(namei), "width")) {
534 int k = asInteger(argi);
535 if (k < R_MIN_WIDTH_OPT || k > R_MAX_WIDTH_OPT)
536 error(_("invalid '%s' parameter, allowed %d...%d"),
537 CHAR(namei), R_MIN_WIDTH_OPT, R_MAX_WIDTH_OPT);
538 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
539 }
540 else if (streql(CHAR(namei), "deparse.cutoff")) {
541 int k = asInteger(argi);
542 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
543 }
544 else if (streql(CHAR(namei), "digits")) {
545 int k = asInteger(argi);
546 if (k < R_MIN_DIGITS_OPT || k > R_MAX_DIGITS_OPT)
547 error(_("invalid '%s' parameter, allowed %d...%d"),
548 CHAR(namei), R_MIN_DIGITS_OPT, R_MAX_DIGITS_OPT);
549 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
550 }
551 else if (streql(CHAR(namei), "expressions")) {
552 int k = asInteger(argi);
553 if (k < R_MIN_EXPRESSIONS_OPT || k > R_MAX_EXPRESSIONS_OPT)
554 error(_("invalid '%s' parameter, allowed %d...%d"), CHAR(namei),
555 R_MIN_EXPRESSIONS_OPT, R_MAX_EXPRESSIONS_OPT);
556 R_Expressions = R_Expressions_keep = k;
557 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
558 }
559 else if (streql(CHAR(namei), "keep.source")) {
560 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
561 error(_("invalid value for '%s'"), CHAR(namei));
562 int k = asLogical(argi);
563 R_KeepSource = k;
564 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
565 }
566 else if (streql(CHAR(namei), "editor") && isString(argi)) {
567 SEXP s = asChar(argi);
568 if (s == NA_STRING || LENGTH(s) == 0)
569 error(_("invalid value for '%s'"), CHAR(namei));
570 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarString(s)));
571 }
572 else if (streql(CHAR(namei), "continue")) {
573 SEXP s = asChar(argi);
574 if (s == NA_STRING || LENGTH(s) == 0)
575 error(_("invalid value for '%s'"), CHAR(namei));
576 /* We want to make sure these are in the native encoding */
577 SET_VECTOR_ELT(value, i,
578 SetOption(tag, mkString(translateChar(s))));
579 }
580 else if (streql(CHAR(namei), "prompt")) {
581 SEXP s = asChar(argi);
582 if (s == NA_STRING || LENGTH(s) == 0)
583 error(_("invalid value for '%s'"), CHAR(namei));
584 /* We want to make sure these are in the native encoding */
585 SET_VECTOR_ELT(value, i,
586 SetOption(tag, mkString(translateChar(s))));
587 }
588 else if (streql(CHAR(namei), "contrasts")) {
589 if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 2)
590 error(_("invalid value for '%s'"), CHAR(namei));
591 SET_VECTOR_ELT(value, i, SetOption(tag, argi));
592 }
593 else if (streql(CHAR(namei), "check.bounds")) {
594 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
595 error(_("invalid value for '%s'"), CHAR(namei));
596 int k = asLogical(argi);
597 /* R_CheckBounds = k; */
598 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
599 }
600 else if (streql(CHAR(namei), "warn")) {
601 if (!isNumeric(argi) || LENGTH(argi) != 1)
602 error(_("invalid value for '%s'"), CHAR(namei));
603 int k;
604 // k = asInteger(argi) wld give both error + warning
605 if(TYPEOF(argi) == REALSXP) {
606 int w;
607 k = IntegerFromReal(REAL_ELT(argi, 0), &w);
608 } else {
609 k = asInteger(argi);
610 }
611 if (k == NA_INTEGER)
612 error(_("invalid value for '%s'"), CHAR(namei));
613 #ifdef _NOT_YET_
614 char *p = getenv("R_WARN_BOUNDS_OPT");
615 if ((p && (strcmp(p, "yes") == 0)) && (k < -1 || k > 2)) {
616 int k_n = (k < 0) ? -1 : 2;
617 REprintf(_("value for '%s' outside of -1:2 is set to %d\n"),
618 CHAR(namei), k_n);
619 k = k_n;
620 }
621 #endif
622 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
623 }
624 else if (streql(CHAR(namei), "warning.length")) {
625 int k = asInteger(argi);
626 if (k < 100 || k > 8170)
627 error(_("invalid value for '%s'"), CHAR(namei));
628 R_WarnLength = k;
629 SET_VECTOR_ELT(value, i, SetOption(tag, argi));
630 }
631 else if ( streql(CHAR(namei), "warning.expression") ) {
632 if( !isLanguage(argi) && ! isExpression(argi) )
633 error(_("invalid value for '%s'"), CHAR(namei));
634 SET_VECTOR_ELT(value, i, SetOption(tag, argi));
635 }
636 else if (streql(CHAR(namei), "max.print")) {
637 int k = asInteger(argi);
638 if (k < 1) error(_("invalid value for '%s'"), CHAR(namei));
639 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
640 }
641 else if (streql(CHAR(namei), "nwarnings")) {
642 int k = asInteger(argi);
643 if (k < 1) error(_("invalid value for '%s'"), CHAR(namei));
644 R_nwarnings = k;
645 R_CollectWarnings = 0; /* force a reset */
646 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
647 }
648 else if ( streql(CHAR(namei), "error") ) {
649 if(isFunction(argi))
650 argi = makeErrorCall(argi);
651 else if( !isLanguage(argi) && !isExpression(argi) )
652 error(_("invalid value for '%s'"), CHAR(namei));
653 SET_VECTOR_ELT(value, i, SetOption(tag, argi));
654 }
655 /* handle this here to avoid GetOption during error handling */
656 else if ( streql(CHAR(namei), "show.error.messages") ) {
657 if( !isLogical(argi) && LENGTH(argi) != 1 )
658 error(_("invalid value for '%s'"), CHAR(namei));
659 SET_VECTOR_ELT(value, i, SetOption(tag, argi));
660 R_ShowErrorMessages = LOGICAL(argi)[0];
661 }
662 else if (streql(CHAR(namei), "echo")) {
663 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
664 error(_("invalid value for '%s'"), CHAR(namei));
665 int k = asLogical(argi);
666 /* Should be quicker than checking options(echo)
667 every time R prompts for input:
668 */
669 R_NoEcho = !k;
670 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
671 }
672 else if (streql(CHAR(namei), "OutDec")) {
673 if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 1)
674 error(_("invalid value for '%s'"), CHAR(namei));
675 static char sdec[11];
676 if(R_nchar(STRING_ELT(argi, 0), Chars,
677 /* allowNA = */ FALSE, /* keepNA = */ FALSE,
678 "OutDec") != 1) // will become an error
679 warning(_("'OutDec' must be a string of one character"));
680 strncpy(sdec, CHAR(STRING_ELT(argi, 0)), 10);
681 sdec[10] = '\0';
682 OutDec = sdec;
683 SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
684 }
685 else if (streql(CHAR(namei), "max.contour.segments")) {
686 int k = asInteger(argi);
687 if (k < 0) // also many times above: rely on NA_INTEGER < <finite_int>
688 error(_("invalid value for '%s'"), CHAR(namei));
689 max_contour_segments = k;
690 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
691 }
692 else if (streql(CHAR(namei), "rl_word_breaks")) {
693 if (TYPEOF(argi) != STRSXP || LENGTH(argi) != 1)
694 error(_("invalid value for '%s'"), CHAR(namei));
695 #ifdef HAVE_RL_COMPLETION_MATCHES
696 set_rl_word_breaks(CHAR(STRING_ELT(argi, 0)));
697 #endif
698 SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
699 }
700 else if (streql(CHAR(namei), "warnPartialMatchDollar")) {
701 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
702 error(_("invalid value for '%s'"), CHAR(namei));
703 int k = asLogical(argi);
704 R_warn_partial_match_dollar = k;
705 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
706 }
707 else if (streql(CHAR(namei), "warnPartialMatchArgs")) {
708 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
709 error(_("invalid value for '%s'"), CHAR(namei));
710 int k = asLogical(argi);
711 R_warn_partial_match_args = k;
712 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
713 }
714 else if (streql(CHAR(namei), "warnPartialMatchAttr")) {
715 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
716 error(_("invalid value for '%s'"), CHAR(namei));
717 int k = asLogical(argi);
718 R_warn_partial_match_attr = k;
719 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
720 }
721 else if (streql(CHAR(namei), "showWarnCalls")) {
722 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
723 error(_("invalid value for '%s'"), CHAR(namei));
724 int k = asLogical(argi);
725 R_ShowWarnCalls = k;
726 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
727 }
728 else if (streql(CHAR(namei), "showErrorCalls")) {
729 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
730 error(_("invalid value for '%s'"), CHAR(namei));
731 int k = asLogical(argi);
732 R_ShowErrorCalls = k;
733 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
734 }
735 else if (streql(CHAR(namei), "showNCalls")) {
736 int k = asInteger(argi);
737 if (k < 30 || k > 500 || k == NA_INTEGER || LENGTH(argi) != 1)
738 error(_("invalid value for '%s'"), CHAR(namei));
739 R_NShowCalls = k;
740 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarInteger(k)));
741 }
742 else if (streql(CHAR(namei), "par.ask.default")) {
743 error(_("\"par.ask.default\" has been replaced by \"device.ask.default\""));
744 }
745 else if (streql(CHAR(namei), "browserNLdisabled")) {
746 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
747 error(_("invalid value for '%s'"), CHAR(namei));
748 int k = asLogical(argi);
749 if (k == NA_LOGICAL)
750 error(_("invalid value for '%s'"), CHAR(namei));
751 R_DisableNLinBrowser = k;
752 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
753 }
754 else if (streql(CHAR(namei), "CBoundsCheck")) {
755 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1)
756 error(_("invalid value for '%s'"), CHAR(namei));
757 int k = asLogical(argi);
758 R_CBoundsCheck = k;
759 SET_VECTOR_ELT(value, i, SetOption(tag, ScalarLogical(k)));
760 }
761 else if (streql(CHAR(namei), "matprod")) {
762 SEXP s = asChar(argi);
763 if (s == NA_STRING || LENGTH(s) == 0)
764 error(_("invalid value for '%s'"), CHAR(namei));
765 if (streql(CHAR(s), "default"))
766 R_Matprod = MATPROD_DEFAULT;
767 else if (streql(CHAR(s), "internal"))
768 R_Matprod = MATPROD_INTERNAL;
769 else if (streql(CHAR(s), "blas"))
770 R_Matprod = MATPROD_BLAS;
771 else if (streql(CHAR(s), "default.simd")) {
772 R_Matprod = MATPROD_DEFAULT_SIMD;
773 #if !defined(_OPENMP) || !defined(HAVE_OPENMP_SIMDRED)
774 warning(_("OpenMP SIMD is not supported in this build of R"));
775 #endif
776 } else
777 error(_("invalid value for '%s'"), CHAR(namei));
778 SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
779 }
780 else if (streql(CHAR(namei), "PCRE_study")) {
781 if (TYPEOF(argi) == LGLSXP) {
782 int k = asLogical(argi) > 0;
783 R_PCRE_study = k ? -1 : -2;
784 SET_VECTOR_ELT(value, i,
785 SetOption(tag, ScalarLogical(k)));
786 } else {
787 R_PCRE_study = asInteger(argi);
788 if (R_PCRE_study < 0) {
789 R_PCRE_study = -2;
790 SET_VECTOR_ELT(value, i,
791 SetOption(tag, ScalarLogical(-2)));
792 } else
793 SET_VECTOR_ELT(value, i,
794 SetOption(tag, ScalarInteger(R_PCRE_study)));
795 }
796 #ifdef HAVE_PCRE2
797 if (R_PCRE_study != -2)
798 warning(_("'PCRE_study' has no effect with PCRE2"));
799 #endif
800 }
801 else if (streql(CHAR(namei), "PCRE_use_JIT")) {
802 int use_JIT = asLogical(argi);
803 R_PCRE_use_JIT = (use_JIT > 0); // NA_LOGICAL is < 0
804 SET_VECTOR_ELT(value, i,
805 SetOption(tag, ScalarLogical(R_PCRE_use_JIT)));
806 }
807 else if (streql(CHAR(namei), "PCRE_limit_recursion")) {
808 R_PCRE_limit_recursion = asLogical(argi);
809 SET_VECTOR_ELT(value, i,
810 SetOption(tag, ScalarLogical(R_PCRE_limit_recursion)));
811 /* could warn for PCRE2 >= 10.30, but the value is ignored also when
812 JIT is used */
813 }
814 else if (streql(CHAR(namei), "stringsAsFactors")) {
815 int strings_as_fact;
816 if (TYPEOF(argi) != LGLSXP || LENGTH(argi) != 1 ||
817 (strings_as_fact = asLogical(argi)) == NA_LOGICAL)
818 error(_("invalid value for '%s'"), CHAR(namei));
819 if(strings_as_fact && !warned_on_strings_as_fact) {
820 warned_on_strings_as_fact = TRUE;
821 warning(_("'%s' is deprecated and will be disabled"),
822 "options(stringsAsFactors = TRUE)");
823 }
824 SET_VECTOR_ELT(value, i,
825 SetOption(tag, ScalarLogical(strings_as_fact)));
826 }
827 else {
828 SET_VECTOR_ELT(value, i, SetOption(tag, duplicate(argi)));
829 }
830 }
831 else { /* querying arg */
832 const char *tag;
833 if (!isString(argi) || LENGTH(argi) <= 0)
834 error(_("invalid argument"));
835 tag = translateChar(STRING_ELT(argi, 0));
836 if (streql(tag, "par.ask.default")) {
837 error(_("\"par.ask.default\" has been replaced by \"device.ask.default\""));
838 }
839
840 SET_VECTOR_ELT(value, i, duplicate(CAR(FindTaggedItem(options, install(tag)))));
841 SET_STRING_ELT(names, i, STRING_ELT(argi, 0));
842 visible = TRUE;
843 }
844 } /* for() */
845 setAttrib(value, R_NamesSymbol, names);
846 UNPROTECT(3); /* value, names, argnames */
847 R_Visible = visible;
848 return value;
849 }
850