1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1999-2020 The R Core Team
4 * Copyright (C) 1995-1998 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
22 #ifdef HAVE_CONFIG_H
23 #include <config.h>
24 #endif
25
26 #define R_USE_SIGNALS 1
27 #include <Defn.h>
28 #include <Internal.h>
29 #include <Print.h>
30 #include <Fileio.h>
31 #include <Rconnections.h>
32
33 #include <R_ext/RS.h> /* for Memzero */
34
35 attribute_hidden
asVecSize(SEXP x)36 R_xlen_t asVecSize(SEXP x)
37 {
38 if (isVectorAtomic(x) && LENGTH(x) >= 1) {
39 switch (TYPEOF(x)) {
40 case INTSXP:
41 {
42 int res = INTEGER(x)[0];
43 if(res == NA_INTEGER) error(_("vector size cannot be NA"));
44 return (R_xlen_t) res;
45 }
46 case REALSXP:
47 {
48 double d = REAL(x)[0];
49 if(ISNAN(d)) error(_("vector size cannot be NA/NaN"));
50 if(!R_FINITE(d)) error(_("vector size cannot be infinite"));
51 if(d > R_XLEN_T_MAX) error(_("vector size specified is too large"));
52 return (R_xlen_t) d;
53 }
54 case STRSXP:
55 {
56 double d = asReal(x);
57 if(ISNAN(d)) error(_("vector size cannot be NA/NaN"));
58 if(!R_FINITE(d)) error(_("vector size cannot be infinite"));
59 if(d > R_XLEN_T_MAX) error(_("vector size specified is too large"));
60 return (R_xlen_t) d;
61 }
62 default:
63 break;
64 }
65 }
66 return -999; /* which gives error in the caller */
67 }
68
do_delayed(SEXP call,SEXP op,SEXP args,SEXP rho)69 SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho)
70 {
71 SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv;
72 checkArity(op, args);
73
74 if (!isString(CAR(args)) || LENGTH(CAR(args)) == 0)
75 error(_("invalid first argument"));
76 else
77 name = installTrChar(STRING_ELT(CAR(args), 0));
78 args = CDR(args);
79 expr = CAR(args);
80
81 args = CDR(args);
82 eenv = CAR(args);
83 if (isNull(eenv)) {
84 error(_("use of NULL environment is defunct"));
85 eenv = R_BaseEnv;
86 } else
87 if (!isEnvironment(eenv))
88 error(_("invalid '%s' argument"), "eval.env");
89
90 args = CDR(args);
91 aenv = CAR(args);
92 if (isNull(aenv)) {
93 error(_("use of NULL environment is defunct"));
94 aenv = R_BaseEnv;
95 } else
96 if (!isEnvironment(aenv))
97 error(_("invalid '%s' argument"), "assign.env");
98
99 defineVar(name, mkPROMISE(expr, eenv), aenv);
100 return R_NilValue;
101 }
102
103 /* makeLazy(names, values, expr, eenv, aenv) */
do_makelazy(SEXP call,SEXP op,SEXP args,SEXP rho)104 SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
105 {
106 SEXP names, values, val, expr, eenv, aenv, expr0;
107 R_xlen_t i;
108
109 checkArity(op, args);
110 names = CAR(args); args = CDR(args);
111 if (!isString(names))
112 error(_("invalid first argument"));
113 values = CAR(args); args = CDR(args);
114 expr = CAR(args); args = CDR(args);
115 eenv = CAR(args); args = CDR(args);
116 if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env");
117 aenv = CAR(args);
118 if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env");
119
120 for(i = 0; i < XLENGTH(names); i++) {
121 SEXP name = installTrChar(STRING_ELT(names, i));
122 PROTECT(val = eval(VECTOR_ELT(values, i), eenv));
123 PROTECT(expr0 = duplicate(expr));
124 SETCAR(CDR(expr0), val);
125 defineVar(name, mkPROMISE(expr0, eenv), aenv);
126 UNPROTECT(2);
127 }
128 return R_NilValue;
129 }
130
131 /* This is a primitive SPECIALSXP */
do_onexit(SEXP call,SEXP op,SEXP args,SEXP rho)132 SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
133 {
134 RCNTXT *ctxt;
135 SEXP code, oldcode, argList;
136 int addit = FALSE;
137 int after = TRUE;
138 static SEXP do_onexit_formals = NULL;
139
140 checkArity(op, args);
141 if (do_onexit_formals == NULL)
142 do_onexit_formals = allocFormalsList3(install("expr"),
143 install("add"),
144 install("after"));
145
146 PROTECT(argList = matchArgs_NR(do_onexit_formals, args, call));
147 if (CAR(argList) == R_MissingArg) code = R_NilValue;
148 else code = CAR(argList);
149
150 if (CADR(argList) != R_MissingArg) {
151 addit = asLogical(PROTECT(eval(CADR(argList), rho)));
152 UNPROTECT(1);
153 if (addit == NA_INTEGER)
154 errorcall(call, _("invalid '%s' argument"), "add");
155 }
156 if (CADDR(argList) != R_MissingArg) {
157 after = asLogical(PROTECT(eval(CADDR(argList), rho)));
158 UNPROTECT(1);
159 if (after == NA_INTEGER)
160 errorcall(call, _("invalid '%s' argument"), "lifo");
161 }
162
163 ctxt = R_GlobalContext;
164 /* Search for the context to which the on.exit action is to be
165 attached. Lexical scoping is implemented by searching for the
166 first closure call context with an environment matching the
167 expression evaluation environment. */
168 while (ctxt != R_ToplevelContext &&
169 !((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
170 ctxt = ctxt->nextcontext;
171 if (ctxt->callflag & CTXT_FUNCTION)
172 {
173 if (code == R_NilValue && ! addit)
174 ctxt->conexit = R_NilValue;
175 else {
176 oldcode = ctxt->conexit;
177 if (oldcode == R_NilValue || ! addit)
178 ctxt->conexit = CONS(code, R_NilValue);
179 else {
180 if (after) {
181 SEXP codelist = PROTECT(CONS(code, R_NilValue));
182 ctxt->conexit = listAppend(shallow_duplicate(oldcode), codelist);
183 UNPROTECT(1);
184 } else {
185 ctxt->conexit = CONS(code, oldcode);
186 }
187 }
188 }
189 }
190 UNPROTECT(1);
191 return R_NilValue;
192 }
193
do_args(SEXP call,SEXP op,SEXP args,SEXP rho)194 SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
195 {
196 SEXP s;
197
198 checkArity(op,args);
199 if (TYPEOF(CAR(args)) == STRSXP && LENGTH(CAR(args)) == 1) {
200 PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0)));
201 SETCAR(args, findFun(s, rho));
202 UNPROTECT(1);
203 }
204
205 if (TYPEOF(CAR(args)) == CLOSXP) {
206 s = allocSExp(CLOSXP);
207 SET_FORMALS(s, FORMALS(CAR(args)));
208 SET_BODY(s, R_NilValue);
209 SET_CLOENV(s, R_GlobalEnv);
210 return s;
211 }
212
213 if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
214 char *nm = PRIMNAME(CAR(args));
215 SEXP env, s2;
216 PROTECT_INDEX xp;
217
218 PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
219 install(".ArgsEnv"), TRUE),
220 &xp);
221
222 if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
223 PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
224 if(s2 != R_UnboundValue) {
225 s = duplicate(s2);
226 SET_BODY(s, R_NilValue);
227 SET_CLOENV(s, R_GlobalEnv);
228 UNPROTECT(2);
229 return s;
230 }
231 UNPROTECT(1); /* s2 */
232 REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
233 TRUE), xp);
234 if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
235 PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
236 if(s2 != R_UnboundValue) {
237 s = allocSExp(CLOSXP);
238 SET_FORMALS(s, FORMALS(s2));
239 SET_BODY(s, R_NilValue);
240 SET_CLOENV(s, R_GlobalEnv);
241 UNPROTECT(2);
242 return s;
243 }
244 UNPROTECT(2);
245 }
246 return R_NilValue;
247 }
248
do_formals(SEXP call,SEXP op,SEXP args,SEXP rho)249 SEXP attribute_hidden do_formals(SEXP call, SEXP op, SEXP args, SEXP rho)
250 {
251 checkArity(op, args);
252 if (TYPEOF(CAR(args)) == CLOSXP) {
253 SEXP f = FORMALS(CAR(args));
254 RAISE_NAMED(f, NAMED(CAR(args)));
255 return f;
256 } else {
257 if(!(TYPEOF(CAR(args)) == BUILTINSXP ||
258 TYPEOF(CAR(args)) == SPECIALSXP))
259 warningcall(call, _("argument is not a function"));
260 return R_NilValue;
261 }
262 }
263
do_body(SEXP call,SEXP op,SEXP args,SEXP rho)264 SEXP attribute_hidden do_body(SEXP call, SEXP op, SEXP args, SEXP rho)
265 {
266 checkArity(op, args);
267 if (TYPEOF(CAR(args)) == CLOSXP) {
268 SEXP b = BODY_EXPR(CAR(args));
269 RAISE_NAMED(b, NAMED(CAR(args)));
270 return b;
271 } else {
272 if(!(TYPEOF(CAR(args)) == BUILTINSXP ||
273 TYPEOF(CAR(args)) == SPECIALSXP))
274 warningcall(call, _("argument is not a function"));
275 return R_NilValue;
276 }
277 }
278
do_bodyCode(SEXP call,SEXP op,SEXP args,SEXP rho)279 SEXP attribute_hidden do_bodyCode(SEXP call, SEXP op, SEXP args, SEXP rho)
280 {
281 checkArity(op, args);
282 if (TYPEOF(CAR(args)) == CLOSXP) {
283 SEXP bc = BODY(CAR(args));
284 RAISE_NAMED(bc, NAMED(CAR(args)));
285 return bc;
286 } else return R_NilValue;
287 }
288
289 /* get environment from a subclass if possible; else return NULL */
290 #define simple_as_environment(arg) (IS_S4_OBJECT(arg) && (TYPEOF(arg) == S4SXP) ? R_getS4DataSlot(arg, ENVSXP) : arg)
291
292
do_envir(SEXP call,SEXP op,SEXP args,SEXP rho)293 SEXP attribute_hidden do_envir(SEXP call, SEXP op, SEXP args, SEXP rho)
294 {
295 checkArity(op, args);
296 if (TYPEOF(CAR(args)) == CLOSXP)
297 return CLOENV(CAR(args));
298 else if (CAR(args) == R_NilValue)
299 return R_GlobalContext->sysparent;
300 else return getAttrib(CAR(args), R_DotEnvSymbol);
301 }
302
do_envirgets(SEXP call,SEXP op,SEXP args,SEXP rho)303 SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
304 {
305 SEXP env, s = CAR(args);
306
307 checkArity(op, args);
308 check1arg(args, call, "x");
309
310 env = CADR(args);
311
312 if (TYPEOF(CAR(args)) == CLOSXP
313 && (isEnvironment(env) ||
314 isEnvironment(env = simple_as_environment(env)) ||
315 isNull(env))) {
316 if (isNull(env))
317 error(_("use of NULL environment is defunct"));
318 if(MAYBE_SHARED(s) ||
319 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(s)))
320 /* this copies but does not duplicate args or code */
321 s = duplicate(s);
322 if (TYPEOF(BODY(s)) == BCODESXP)
323 /* switch to interpreted version if compiled */
324 SET_BODY(s, R_ClosureExpr(CAR(args)));
325 SET_CLOENV(s, env);
326 }
327 else if (isNull(env) || isEnvironment(env) ||
328 isEnvironment(env = simple_as_environment(env)))
329 setAttrib(s, R_DotEnvSymbol, env);
330 else
331 error(_("replacement object is not an environment"));
332 return s;
333 }
334
335
336 /** do_newenv() : .Internal(new.env(hash, parent, size))
337 *
338 * @return a newly created environment()
339 */
do_newenv(SEXP call,SEXP op,SEXP args,SEXP rho)340 SEXP attribute_hidden do_newenv(SEXP call, SEXP op, SEXP args, SEXP rho)
341 {
342 SEXP enclos;
343 int hash, size = 0;
344
345 checkArity(op, args);
346
347 hash = asInteger(CAR(args));
348 args = CDR(args);
349 enclos = CAR(args);
350 if (isNull(enclos))
351 error(_("use of NULL environment is defunct"));
352
353 if( !isEnvironment(enclos) &&
354 !isEnvironment((enclos = simple_as_environment(enclos))))
355 error(_("'enclos' must be an environment"));
356
357 if( hash ) {
358 size = asInteger(CADR(args));
359 if (size == NA_INTEGER)
360 size = 0; /* so it will use the internal default */
361 }
362 else size = 0;
363 return R_NewEnv(enclos, hash, size);
364 }
365
do_parentenv(SEXP call,SEXP op,SEXP args,SEXP rho)366 SEXP attribute_hidden do_parentenv(SEXP call, SEXP op, SEXP args, SEXP rho)
367 {
368 checkArity(op, args);
369 SEXP arg = CAR(args);
370
371 if( !isEnvironment(arg) &&
372 !isEnvironment((arg = simple_as_environment(arg))))
373 error( _("argument is not an environment"));
374 if( arg == R_EmptyEnv )
375 error(_("the empty environment has no parent"));
376 return( ENCLOS(arg) );
377 }
378
R_IsImportsEnv(SEXP env)379 static Rboolean R_IsImportsEnv(SEXP env)
380 {
381 if (isNull(env) || !isEnvironment(env))
382 return FALSE;
383 if (ENCLOS(env) != R_BaseNamespace)
384 return FALSE;
385 SEXP name = getAttrib(env, R_NameSymbol);
386 if (!isString(name) || LENGTH(name) != 1)
387 return FALSE;
388
389 const char *imports_prefix = "imports:";
390 const char *name_string = CHAR(STRING_ELT(name, 0));
391 if (!strncmp(name_string, imports_prefix, strlen(imports_prefix)))
392 return TRUE;
393 else
394 return FALSE;
395 }
396
do_parentenvgets(SEXP call,SEXP op,SEXP args,SEXP rho)397 SEXP attribute_hidden do_parentenvgets(SEXP call, SEXP op, SEXP args, SEXP rho)
398 {
399 SEXP env, parent;
400 checkArity(op, args);
401
402 env = CAR(args);
403 if (isNull(env)) {
404 error(_("use of NULL environment is defunct"));
405 env = R_BaseEnv;
406 } else
407 if( !isEnvironment(env) &&
408 !isEnvironment((env = simple_as_environment(env))))
409 error(_("argument is not an environment"));
410 if( env == R_EmptyEnv )
411 error(_("can not set parent of the empty environment"));
412 if (R_EnvironmentIsLocked(env) && R_IsNamespaceEnv(env))
413 error(_("can not set the parent environment of a namespace"));
414 if (R_EnvironmentIsLocked(env) && R_IsImportsEnv(env))
415 error(_("can not set the parent environment of package imports"));
416 parent = CADR(args);
417 if (isNull(parent)) {
418 error(_("use of NULL environment is defunct"));
419 parent = R_BaseEnv;
420 } else
421 if( !isEnvironment(parent) &&
422 !isEnvironment((parent = simple_as_environment(parent))))
423 error(_("'parent' is not an environment"));
424
425 SET_ENCLOS(env, parent);
426
427 return( CAR(args) );
428 }
429
do_envirName(SEXP call,SEXP op,SEXP args,SEXP rho)430 SEXP attribute_hidden do_envirName(SEXP call, SEXP op, SEXP args, SEXP rho)
431 {
432 SEXP env = CAR(args), ans=mkString(""), res;
433
434 checkArity(op, args);
435 PROTECT(ans);
436 if (TYPEOF(env) == ENVSXP ||
437 TYPEOF((env = simple_as_environment(env))) == ENVSXP) {
438 if (env == R_GlobalEnv) ans = mkString("R_GlobalEnv");
439 else if (env == R_BaseEnv) ans = mkString("base");
440 else if (env == R_EmptyEnv) ans = mkString("R_EmptyEnv");
441 else if (R_IsPackageEnv(env))
442 ans = ScalarString(STRING_ELT(R_PackageEnvName(env), 0));
443 else if (R_IsNamespaceEnv(env))
444 ans = ScalarString(STRING_ELT(R_NamespaceEnvSpec(env), 0));
445 else if (!isNull(res = getAttrib(env, R_NameSymbol))) ans = res;
446 }
447 UNPROTECT(1); /* ans */
448 return ans;
449 }
450
451 #ifdef Win32
452 # include "rgui_UTF8.h"
453 #endif
454 /* Uses R_alloc but called by a .Internal. Result may be R_alloc-ed */
trChar(SEXP x)455 static const char *trChar(SEXP x)
456 {
457 size_t n = strlen(CHAR(x));
458 cetype_t ienc = getCharCE(x);
459
460 if (ienc == CE_BYTES) {
461 const char *p = CHAR(x), *q;
462 char *pp = R_alloc(4*n+1, 1), *qq = pp, buf[5];
463 for (q = p; *q; q++) {
464 unsigned char k = (unsigned char) *q;
465 if (k >= 0x20 && k < 0x80) {
466 *qq++ = *q;
467 } else {
468 snprintf(buf, 5, "\\x%02x", k);
469 for(int j = 0; j < 4; j++) *qq++ = buf[j];
470 }
471 }
472 *qq = '\0';
473 return pp;
474 } else {
475 #ifdef Win32
476 static char buf[106];
477 char *p;
478 /* Long strings will be rare, and few per cat() call so we
479 can afford to be profligate here: translateChar is */
480 if (n < 100) p = buf; else p = R_alloc(n+7, 1);
481 if (WinUTF8out && ienc == CE_UTF8) {
482 strcpy(p, UTF8in); strcat(p, CHAR(x)); strcat(p, UTF8out);
483 return p;
484 } else
485 #endif
486 return translateChar(x);
487 }
488 }
489
cat_newline(SEXP labels,int * width,int lablen,int ntot)490 static void cat_newline(SEXP labels, int *width, int lablen, int ntot)
491 {
492 Rprintf("\n");
493 *width = 0;
494 if (labels != R_NilValue) {
495 Rprintf("%s ", EncodeString(STRING_ELT(labels, ntot % lablen),
496 1, 0, Rprt_adj_left));
497 *width += Rstrlen(STRING_ELT(labels, ntot % lablen), 0) + 1;
498 }
499 }
500
cat_sepwidth(SEXP sep,int * width,int ntot)501 static void cat_sepwidth(SEXP sep, int *width, int ntot)
502 {
503 if (sep == R_NilValue || LENGTH(sep) == 0)
504 *width = 0;
505 else
506 *width = Rstrlen(STRING_ELT(sep, ntot % LENGTH(sep)), 0);
507 }
508
cat_printsep(SEXP sep,int ntot)509 static void cat_printsep(SEXP sep, int ntot)
510 {
511 const char *sepchar;
512 if (sep == R_NilValue || LENGTH(sep) == 0)
513 return;
514
515 sepchar = trChar(STRING_ELT(sep, ntot % LENGTH(sep)));
516 Rprintf("%s", sepchar);
517 return;
518 }
519
520 typedef struct cat_info {
521 Rboolean wasopen;
522 int changedcon;
523 Rconnection con;
524 #ifdef Win32
525 Rboolean saveWinUTF8out;
526 #endif
527 } cat_info;
528
cat_cleanup(void * data)529 static void cat_cleanup(void *data)
530 {
531 cat_info *pci = (cat_info *) data;
532 Rconnection con = pci->con;
533 Rboolean wasopen = pci->wasopen;
534 int changedcon = pci->changedcon;
535
536 con->fflush(con);
537 if(changedcon) switch_stdout(-1, 0);
538 /* previous line might have closed it */
539 if(!wasopen && con->isopen) con->close(con);
540 #ifdef Win32
541 WinUTF8out = pci->saveWinUTF8out;
542 #endif
543 }
544
do_cat(SEXP call,SEXP op,SEXP args,SEXP rho)545 SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
546 {
547 cat_info ci;
548 RCNTXT cntxt;
549 SEXP objs, file, fill, sepr, labs, s;
550 int ifile;
551 Rconnection con;
552 int append;
553 int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines;
554 char buf[512];
555 const char *p = "";
556
557 checkArity(op, args);
558
559 /* Use standard printing defaults */
560 PrintDefaults();
561
562 objs = CAR(args);
563 args = CDR(args);
564
565 file = CAR(args);
566 ifile = asInteger(file);
567 con = getConnection(ifile);
568 if(!con->canwrite) /* if it is not open, we may not know yet */
569 error(_("cannot write to this connection"));
570 args = CDR(args);
571
572 sepr = CAR(args);
573 if (!isString(sepr))
574 error(_("invalid '%s' specification"), "sep");
575 nlsep = 0;
576 for (i = 0; i < LENGTH(sepr); i++)
577 if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */
578 args = CDR(args);
579
580 fill = CAR(args);
581 if ((!isNumeric(fill) && !isLogical(fill)) || (LENGTH(fill) != 1))
582 error(_("invalid '%s' argument"), "fill");
583 if (isLogical(fill)) {
584 if (asLogical(fill) == 1)
585 pwidth = R_print.width;
586 else
587 pwidth = INT_MAX;
588 }
589 else pwidth = asInteger(fill);
590 if(pwidth <= 0) {
591 warning(_("non-positive 'fill' argument will be ignored"));
592 pwidth = INT_MAX;
593 }
594 args = CDR(args);
595
596 labs = CAR(args);
597 if (!isString(labs) && labs != R_NilValue)
598 error(_("invalid '%s' argument"), "labels");
599 lablen = length(labs);
600 args = CDR(args);
601
602 append = asLogical(CAR(args));
603 if (append == NA_LOGICAL)
604 error(_("invalid '%s' specification"), "append");
605
606 ci.wasopen = con->isopen;
607
608 ci.changedcon = switch_stdout(ifile, 0);
609 /* will open new connection if required, and check for writeable */
610 #ifdef Win32
611 /* do this after re-sinking output */
612 ci.saveWinUTF8out = WinUTF8out;
613 WinCheckUTF8();
614 #endif
615
616 ci.con = con;
617
618 /* set up a context which will close the connection if there is an error */
619 begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
620 R_NilValue, R_NilValue);
621 cntxt.cend = &cat_cleanup;
622 cntxt.cenddata = &ci;
623
624 nobjs = length(objs);
625 width = 0;
626 ntot = 0;
627 nlines = 0;
628 for (iobj = 0; iobj < nobjs; iobj++) {
629 s = VECTOR_ELT(objs, iobj);
630 if (iobj != 0 && !isNull(s))
631 cat_printsep(sepr, ntot++);
632 n = length(s);
633 /* 0-length objects are ignored */
634 if (n > 0) {
635 if (labs != R_NilValue && (iobj == 0)
636 && (asInteger(fill) > 0)) {
637 Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen)));
638 /* FIXME -- Rstrlen allows for double-width chars */
639 width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1;
640 nlines++;
641 }
642 if (isString(s))
643 p = trChar(STRING_ELT(s, 0));
644 else if (isSymbol(s)) /* length 1 */
645 p = CHAR(PRINTNAME(s));
646 else if (isVectorAtomic(s)) {
647 /* Not a string, as that is covered above.
648 Thus the maximum size is about 60.
649 The copy is needed as cat_newline might reuse the buffer.
650 Use strncpy is in case these assumptions change.
651 */
652 p = EncodeElement0(s, 0, 0, OutDec);
653 strncpy(buf, p, 511); buf[511] = '\0';
654 p = buf;
655 }
656 #ifdef fixed_cat
657 else if (isVectorList(s)) {
658 /* FIXME: call EncodeElement() for every element of s.
659
660 Real Problem: `s' can be large;
661 should do line breaking etc.. (buf is of limited size)
662 */
663 }
664 #endif
665 else
666 error(_("argument %d (type '%s') cannot be handled by 'cat'"),
667 1+iobj, type2char(TYPEOF(s)));
668 /* FIXME : cat(...) should handle ANYTHING */
669 size_t w = strlen(p);
670 cat_sepwidth(sepr, &sepw, ntot);
671 if ((iobj > 0) && (width + w + sepw > pwidth)) {
672 cat_newline(labs, &width, lablen, nlines);
673 nlines++;
674 }
675 for (i = 0; i < n; i++, ntot++) {
676 Rprintf("%s", p);
677 width += (int)(w + sepw);
678 if (i < (n - 1)) {
679 cat_printsep(sepr, ntot);
680 if (isString(s))
681 p = trChar(STRING_ELT(s, i+1));
682 else {
683 p = EncodeElement0(s, i+1, 0, OutDec);
684 strncpy(buf, p, 511); buf[511] = '\0';
685 p = buf;
686 }
687 w = (int) strlen(p);
688 cat_sepwidth(sepr, &sepw, ntot);
689 /* This is inconsistent with the version above.
690 As from R 2.3.0, fill <= 0 is ignored. */
691 if ((width + w + sepw > pwidth) && pwidth) {
692 cat_newline(labs, &width, lablen, nlines);
693 nlines++;
694 }
695 } else ntot--; /* we don't print sep after last, so don't advance */
696 }
697 }
698 }
699 if ((pwidth != INT_MAX) || nlsep)
700 Rprintf("\n");
701
702 /* end the context after anything that could raise an error but before
703 doing the cleanup so the cleanup doesn't get done twice */
704 endcontext(&cntxt);
705
706 cat_cleanup(&ci);
707
708 return R_NilValue;
709 }
710
do_makelist(SEXP call,SEXP op,SEXP args,SEXP rho)711 SEXP attribute_hidden do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho)
712 {
713 int n, havenames;
714 /* compute number of args and check for names */
715 SEXP next;
716 for (next = args, n = 0, havenames = FALSE;
717 next != R_NilValue;
718 next = CDR(next)) {
719 if (TAG(next) != R_NilValue)
720 havenames = TRUE;
721 n++;
722 }
723
724 SEXP list = PROTECT(allocVector(VECSXP, n));
725 SEXP names = PROTECT(havenames ? allocVector(STRSXP, n) : R_NilValue);
726 for (int i = 0; i < n; i++) {
727 if (havenames) {
728 if (TAG(args) != R_NilValue)
729 SET_STRING_ELT(names, i, PRINTNAME(TAG(args)));
730 else
731 SET_STRING_ELT(names, i, R_BlankString);
732 }
733 if (NAMED(CAR(args)))
734 ENSURE_NAMEDMAX(CAR(args));
735 SET_VECTOR_ELT(list, i, CAR(args));
736 args = CDR(args);
737 }
738 if (havenames) {
739 setAttrib(list, R_NamesSymbol, names);
740 }
741 UNPROTECT(2);
742 return list;
743 }
744
745 /* This is a primitive SPECIALSXP */
do_expression(SEXP call,SEXP op,SEXP args,SEXP rho)746 SEXP attribute_hidden do_expression(SEXP call, SEXP op, SEXP args, SEXP rho)
747 {
748 SEXP a, ans, nms;
749 int i, n, named;
750 named = 0;
751 n = length(args);
752 PROTECT(ans = allocVector(EXPRSXP, n));
753 a = args;
754 for (i = 0; i < n; i++) {
755 if(MAYBE_REFERENCED(CAR(a)))
756 SET_VECTOR_ELT(ans, i, duplicate(CAR(a)));
757 else
758 SET_VECTOR_ELT(ans, i, CAR(a));
759 if (TAG(a) != R_NilValue) named = 1;
760 a = CDR(a);
761 }
762 if (named) {
763 PROTECT(nms = allocVector(STRSXP, n));
764 a = args;
765 for (i = 0; i < n; i++) {
766 if (TAG(a) != R_NilValue)
767 SET_STRING_ELT(nms, i, PRINTNAME(TAG(a)));
768 else
769 SET_STRING_ELT(nms, i, R_BlankString);
770 a = CDR(a);
771 }
772 setAttrib(ans, R_NamesSymbol, nms);
773 UNPROTECT(1);
774 }
775 UNPROTECT(1);
776 return ans;
777 }
778
779 /* vector(mode="logical", length=0) */
do_makevector(SEXP call,SEXP op,SEXP args,SEXP rho)780 SEXP attribute_hidden do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
781 {
782 R_xlen_t len;
783 SEXP s;
784 SEXPTYPE mode;
785 checkArity(op, args);
786 if (length(CADR(args)) != 1) error(_("invalid '%s' argument"), "length");
787 len = asVecSize(CADR(args));
788 if (len < 0) error(_("invalid '%s' argument"), "length");
789 s = coerceVector(CAR(args), STRSXP);
790 if (length(s) != 1) error(_("invalid '%s' argument"), "mode");
791 mode = str2type(CHAR(STRING_ELT(s, 0))); /* ASCII */
792 if (mode == -1 && streql(CHAR(STRING_ELT(s, 0)), "double"))
793 mode = REALSXP;
794 switch (mode) {
795 case LGLSXP:
796 case INTSXP:
797 case REALSXP:
798 case CPLXSXP:
799 case STRSXP:
800 case EXPRSXP:
801 case VECSXP:
802 case RAWSXP:
803 s = allocVector(mode, len);
804 break;
805 case LISTSXP:
806 if (len > INT_MAX) error("too long for a pairlist");
807 s = allocList((int) len);
808 break;
809 default:
810 error(_("vector: cannot make a vector of mode '%s'."),
811 translateChar(STRING_ELT(s, 0))); /* should be ASCII */
812 }
813 if (mode == INTSXP || mode == LGLSXP)
814 Memzero(INTEGER(s), len);
815 else if (mode == REALSXP)
816 Memzero(REAL(s), len);
817 else if (mode == CPLXSXP)
818 Memzero(COMPLEX(s), len);
819 else if (mode == RAWSXP)
820 Memzero(RAW(s), len);
821 /* other cases: list/expression have "NULL", ok */
822 return s;
823 }
824
825
826 /* do_lengthgets: assign a length to a vector or a list */
827 /* (if it is vectorizable). We could probably be fairly */
828 /* clever with memory here if we wanted to. */
829
830 /* used in connections.c, attrib.c, seq.c, .. */
xlengthgets(SEXP x,R_xlen_t len)831 SEXP xlengthgets(SEXP x, R_xlen_t len)
832 {
833 R_xlen_t lenx, i;
834 SEXP rval, names, xnames, t;
835 if (!isVector(x) && !isList(x))
836 error(_("cannot set length of non-(vector or list)"));
837 if (len < 0) error(_("invalid value")); // e.g. -999 from asVecSize()
838 if (isNull(x) && len > 0)
839 warning(_("length of NULL cannot be changed"));
840 lenx = xlength(x);
841 if (lenx == len)
842 return (x);
843 PROTECT(rval = allocVector(TYPEOF(x), len));
844 PROTECT(xnames = getAttrib(x, R_NamesSymbol));
845 if (xnames != R_NilValue)
846 names = allocVector(STRSXP, len);
847 else names = R_NilValue; /*- just for -Wall --- should we do this ? */
848 switch (TYPEOF(x)) {
849 case NILSXP:
850 break;
851 case LGLSXP:
852 case INTSXP:
853 for (i = 0; i < len; i++)
854 if (i < lenx) {
855 INTEGER(rval)[i] = INTEGER(x)[i];
856 if (xnames != R_NilValue)
857 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
858 }
859 else
860 INTEGER(rval)[i] = NA_INTEGER;
861 break;
862 case REALSXP:
863 for (i = 0; i < len; i++)
864 if (i < lenx) {
865 REAL(rval)[i] = REAL(x)[i];
866 if (xnames != R_NilValue)
867 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
868 }
869 else
870 REAL(rval)[i] = NA_REAL;
871 break;
872 case CPLXSXP:
873 for (i = 0; i < len; i++)
874 if (i < lenx) {
875 COMPLEX(rval)[i] = COMPLEX(x)[i];
876 if (xnames != R_NilValue)
877 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
878 }
879 else {
880 COMPLEX(rval)[i].r = NA_REAL;
881 COMPLEX(rval)[i].i = NA_REAL;
882 }
883 break;
884 case STRSXP:
885 for (i = 0; i < len; i++)
886 if (i < lenx) {
887 SET_STRING_ELT(rval, i, STRING_ELT(x, i));
888 if (xnames != R_NilValue)
889 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
890 }
891 else
892 SET_STRING_ELT(rval, i, NA_STRING);
893 break;
894 case LISTSXP:
895 for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) {
896 SETCAR(t, CAR(x));
897 SET_TAG(t, TAG(x));
898 }
899 break;
900 case VECSXP:
901 for (i = 0; i < len; i++)
902 if (i < lenx) {
903 SET_VECTOR_ELT(rval, i, VECTOR_ELT(x, i));
904 if (xnames != R_NilValue)
905 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
906 }
907 break;
908 case RAWSXP:
909 for (i = 0; i < len; i++)
910 if (i < lenx) {
911 RAW(rval)[i] = RAW(x)[i];
912 if (xnames != R_NilValue)
913 SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
914 }
915 else
916 RAW(rval)[i] = (Rbyte) 0;
917 break;
918 default:
919 UNIMPLEMENTED_TYPE("length<-", x);
920 }
921 if (isVector(x) && xnames != R_NilValue)
922 setAttrib(rval, R_NamesSymbol, names);
923 // *not* keeping "class": in line with x[1:k]
924 UNPROTECT(2);
925 return rval;
926 }
927
928 /* older version */
lengthgets(SEXP x,R_len_t len)929 SEXP lengthgets(SEXP x, R_len_t len)
930 {
931 return xlengthgets(x, (R_xlen_t) len);
932 }
933
934
do_lengthgets(SEXP call,SEXP op,SEXP args,SEXP rho)935 SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
936 {
937 SEXP x, ans;
938
939 checkArity(op, args);
940 check1arg(args, call, "x");
941
942 x = CAR(args);
943
944 /* DispatchOrEval internal generic: length<- */
945 if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
946 rho, &ans, 0, 1))
947 return(ans);
948 // more 'x' checks in xlengthgets()
949 if (length(CADR(args)) != 1)
950 error(_("wrong length for '%s' argument"), "value");
951 R_xlen_t len = asVecSize(CADR(args));
952 #ifndef LONG_VECTOR_SUPPORT
953 if (len > R_LEN_T_MAX) {
954 error(_("vector size specified is too large"));
955 return x; /* -Wall */
956 }
957 #endif
958 return xlengthgets(x, len);
959 }
960
961 /* Expand dots in args, but do not evaluate */
expandDots(SEXP el,SEXP rho)962 static SEXP expandDots(SEXP el, SEXP rho)
963 {
964 SEXP ans, tail;
965
966 PROTECT(el); /* in do_switch, this is already protected */
967 PROTECT(ans = tail = CONS(R_NilValue, R_NilValue));
968
969 while (el != R_NilValue) {
970 if (CAR(el) == R_DotsSymbol) {
971 SEXP h = PROTECT(findVar(CAR(el), rho));
972 if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
973 while (h != R_NilValue) {
974 SETCDR(tail, CONS(CAR(h), R_NilValue));
975 tail = CDR(tail);
976 if(TAG(h) != R_NilValue) SET_TAG(tail, TAG(h));
977 h = CDR(h);
978 }
979 } else if (h != R_MissingArg)
980 error(_("'...' used in an incorrect context"));
981 UNPROTECT(1); /* h */
982 } else {
983 SETCDR(tail, CONS(CAR(el), R_NilValue));
984 tail = CDR(tail);
985 if(TAG(el) != R_NilValue) SET_TAG(tail, TAG(el));
986 }
987 el = CDR(el);
988 }
989 UNPROTECT(2);
990 return CDR(ans);
991 }
992
993 /* This function is used in do_switch to record the default value and
994 to detect multiple defaults, which are not allowed as of 2.13.x */
995
setDflt(SEXP arg,SEXP dflt)996 static SEXP setDflt(SEXP arg, SEXP dflt)
997 {
998 if (dflt) {
999 SEXP dflt1, dflt2;
1000 PROTECT(dflt1 = deparse1line(dflt, TRUE));
1001 PROTECT(dflt2 = deparse1line(CAR(arg), TRUE));
1002 error(_("duplicate 'switch' defaults: '%s' and '%s'"),
1003 CHAR(STRING_ELT(dflt1, 0)), CHAR(STRING_ELT(dflt2, 0)));
1004 UNPROTECT(2); /* won't get here, but just for good form */
1005 }
1006 return(CAR(arg));
1007 }
1008
1009 /* For switch, evaluate the first arg, if it is a character then try
1010 to match the name with the remaining args, and evaluate the match. If
1011 the value is missing then take the next non-missing arg as the value.
1012 Then things like switch(as.character(answer), yes=, YES=1, no=, NO=2,
1013 3) will work. But if there is no 'next', return NULL. One arg beyond
1014 the first is allowed to be unnamed; it becomes the default value if
1015 there is no match.
1016
1017 If the value of the first arg is not a character string
1018 then coerce it to an integer k and choose the kth argument from those
1019 that remain provided 1 < k < nargs.
1020
1021 Changed in 2.11.0 to be primitive, so the wrapper does not partially
1022 match to EXPR, and to return NULL invisibly if it is an error
1023 condition.
1024
1025 This is a SPECIALSXP, so arguments need to be evaluated as needed.
1026 And (see names.c) X=2, so it defaults to a visible value.
1027 */
1028
1029
do_switch(SEXP call,SEXP op,SEXP args,SEXP rho)1030 SEXP attribute_hidden do_switch(SEXP call, SEXP op, SEXP args, SEXP rho)
1031 {
1032 int argval, nargs = length(args);
1033 SEXP x, y, z, w, ans, dflt = NULL;
1034
1035 if (nargs < 1) errorcall(call, _("'EXPR' is missing"));
1036 check1arg(args, call, "EXPR");
1037 PROTECT(x = eval(CAR(args), rho));
1038 if (!isVector(x) || LENGTH(x) != 1)
1039 errorcall(call, _("EXPR must be a length 1 vector"));
1040 if (isFactor(x))
1041 warningcall(call,
1042 _("EXPR is a \"factor\", treated as integer.\n"
1043 " Consider using '%s' instead."),
1044 "switch(as.character( * ), ...)");
1045 if (nargs > 1) {
1046 /* There is a complication: if called from lapply
1047 there may be a ... argument */
1048 PROTECT(w = expandDots(CDR(args), rho));
1049 if (isString(x)) {
1050 for (y = w; y != R_NilValue; y = CDR(y)) {
1051 if (TAG(y) != R_NilValue) {
1052 if (pmatch(STRING_ELT(x, 0), TAG(y), 1 /* exact */)) {
1053 /* Find the next non-missing argument.
1054 (If there is none, return NULL.) */
1055 while (CAR(y) == R_MissingArg) {
1056 y = CDR(y);
1057 if (y == R_NilValue) break;
1058 if (TAG(y) == R_NilValue) dflt = setDflt(y, dflt);
1059 }
1060 if (y == R_NilValue) {
1061 UNPROTECT(2);
1062 R_Visible = FALSE;
1063 return R_NilValue;
1064 }
1065 /* Check for multiple defaults following y. This loop
1066 is not necessary to determine the value of the
1067 switch(), but it should be fast and will detect
1068 typos. */
1069 for (z = CDR(y); z != R_NilValue; z = CDR(z))
1070 if (TAG(z) == R_NilValue) dflt = setDflt(z, dflt);
1071
1072 ans = eval(CAR(y), rho);
1073 UNPROTECT(2);
1074 return ans;
1075 }
1076 } else
1077 dflt = setDflt(y, dflt);
1078 }
1079 if (dflt) {
1080 ans = eval(dflt, rho);
1081 UNPROTECT(2);
1082 return ans;
1083 }
1084 /* fall through to error */
1085 } else { /* Treat as numeric */
1086 argval = asInteger(x);
1087 if (argval != NA_INTEGER && argval >= 1 && argval <= length(w)) {
1088 SEXP alt = CAR(nthcdr(w, argval - 1));
1089 if (alt == R_MissingArg)
1090 error("empty alternative in numeric switch");
1091 ans = eval(alt, rho);
1092 UNPROTECT(2);
1093 return ans;
1094 }
1095 /* fall through to error */
1096 }
1097 UNPROTECT(1); /* w */
1098 } else
1099 warningcall(call, _("'switch' with no alternatives"));
1100 /* an error */
1101 UNPROTECT(1); /* x */
1102 R_Visible = FALSE;
1103 return R_NilValue;
1104 }
1105