| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1999-2018 The R Core Team |
| * Copyright (C) 1995-1998 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 |
| |
| #define R_USE_SIGNALS 1 |
| #include <Defn.h> |
| #include <Internal.h> |
| #include <Print.h> |
| #include <Fileio.h> |
| #include <Rconnections.h> |
| |
| #include <R_ext/RS.h> /* for Memzero */ |
| |
| attribute_hidden |
| R_xlen_t asVecSize(SEXP x) |
| { |
| if (isVectorAtomic(x) && LENGTH(x) >= 1) { |
| switch (TYPEOF(x)) { |
| case INTSXP: |
| { |
| int res = INTEGER(x)[0]; |
| if(res == NA_INTEGER) error(_("vector size cannot be NA")); |
| return (R_xlen_t) res; |
| } |
| case REALSXP: |
| { |
| double d = REAL(x)[0]; |
| if(ISNAN(d)) error(_("vector size cannot be NA/NaN")); |
| if(!R_FINITE(d)) error(_("vector size cannot be infinite")); |
| if(d > R_XLEN_T_MAX) error(_("vector size specified is too large")); |
| return (R_xlen_t) d; |
| } |
| case STRSXP: |
| { |
| double d = asReal(x); |
| if(ISNAN(d)) error(_("vector size cannot be NA/NaN")); |
| if(!R_FINITE(d)) error(_("vector size cannot be infinite")); |
| if(d > R_XLEN_T_MAX) error(_("vector size specified is too large")); |
| return (R_xlen_t) d; |
| } |
| default: |
| break; |
| } |
| } |
| return -999; /* which gives error in the caller */ |
| } |
| |
| SEXP attribute_hidden do_delayed(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP name = R_NilValue /* -Wall */, expr, eenv, aenv; |
| checkArity(op, args); |
| |
| if (!isString(CAR(args)) || LENGTH(CAR(args)) == 0) |
| error(_("invalid first argument")); |
| else |
| name = installTrChar(STRING_ELT(CAR(args), 0)); |
| args = CDR(args); |
| expr = CAR(args); |
| |
| args = CDR(args); |
| eenv = CAR(args); |
| if (isNull(eenv)) { |
| error(_("use of NULL environment is defunct")); |
| eenv = R_BaseEnv; |
| } else |
| if (!isEnvironment(eenv)) |
| error(_("invalid '%s' argument"), "eval.env"); |
| |
| args = CDR(args); |
| aenv = CAR(args); |
| if (isNull(aenv)) { |
| error(_("use of NULL environment is defunct")); |
| aenv = R_BaseEnv; |
| } else |
| if (!isEnvironment(aenv)) |
| error(_("invalid '%s' argument"), "assign.env"); |
| |
| defineVar(name, mkPROMISE(expr, eenv), aenv); |
| return R_NilValue; |
| } |
| |
| /* makeLazy(names, values, expr, eenv, aenv) */ |
| SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP names, values, val, expr, eenv, aenv, expr0; |
| R_xlen_t i; |
| |
| checkArity(op, args); |
| names = CAR(args); args = CDR(args); |
| if (!isString(names)) |
| error(_("invalid first argument")); |
| values = CAR(args); args = CDR(args); |
| expr = CAR(args); args = CDR(args); |
| eenv = CAR(args); args = CDR(args); |
| if (!isEnvironment(eenv)) error(_("invalid '%s' argument"), "eval.env"); |
| aenv = CAR(args); |
| if (!isEnvironment(aenv)) error(_("invalid '%s' argument"), "assign.env"); |
| |
| for(i = 0; i < XLENGTH(names); i++) { |
| SEXP name = installTrChar(STRING_ELT(names, i)); |
| PROTECT(val = eval(VECTOR_ELT(values, i), eenv)); |
| PROTECT(expr0 = duplicate(expr)); |
| SETCAR(CDR(expr0), val); |
| defineVar(name, mkPROMISE(expr0, eenv), aenv); |
| UNPROTECT(2); |
| } |
| return R_NilValue; |
| } |
| |
| /* This is a primitive SPECIALSXP */ |
| SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| RCNTXT *ctxt; |
| SEXP code, oldcode, argList; |
| int addit = FALSE; |
| int after = TRUE; |
| static SEXP do_onexit_formals = NULL; |
| |
| checkArity(op, args); |
| if (do_onexit_formals == NULL) |
| do_onexit_formals = allocFormalsList3(install("expr"), |
| install("add"), |
| install("after")); |
| |
| PROTECT(argList = matchArgs(do_onexit_formals, args, call)); |
| if (CAR(argList) == R_MissingArg) code = R_NilValue; |
| else code = CAR(argList); |
| |
| if (CADR(argList) != R_MissingArg) { |
| addit = asLogical(PROTECT(eval(CADR(args), rho))); |
| UNPROTECT(1); |
| if (addit == NA_INTEGER) |
| errorcall(call, _("invalid '%s' argument"), "add"); |
| } |
| if (CADDR(argList) != R_MissingArg) { |
| after = asLogical(PROTECT(eval(CADDR(args), rho))); |
| UNPROTECT(1); |
| if (after == NA_INTEGER) |
| errorcall(call, _("invalid '%s' argument"), "lifo"); |
| } |
| |
| ctxt = R_GlobalContext; |
| /* Search for the context to which the on.exit action is to be |
| attached. Lexical scoping is implemented by searching for the |
| first closure call context with an environment matching the |
| expression evaluation environment. */ |
| while (ctxt != R_ToplevelContext && |
| !((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) ) |
| ctxt = ctxt->nextcontext; |
| if (ctxt->callflag & CTXT_FUNCTION) |
| { |
| if (code == R_NilValue && ! addit) |
| ctxt->conexit = R_NilValue; |
| else { |
| oldcode = ctxt->conexit; |
| if (oldcode == R_NilValue || ! addit) |
| ctxt->conexit = CONS(code, R_NilValue); |
| else { |
| if (after) { |
| SEXP codelist = PROTECT(CONS(code, R_NilValue)); |
| ctxt->conexit = listAppend(shallow_duplicate(oldcode), codelist); |
| UNPROTECT(1); |
| } else { |
| ctxt->conexit = CONS(code, oldcode); |
| } |
| } |
| } |
| } |
| UNPROTECT(1); |
| return R_NilValue; |
| } |
| |
| SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP s; |
| |
| checkArity(op,args); |
| if (TYPEOF(CAR(args)) == STRSXP && LENGTH(CAR(args)) == 1) { |
| PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0))); |
| SETCAR(args, findFun(s, rho)); |
| UNPROTECT(1); |
| } |
| |
| if (TYPEOF(CAR(args)) == CLOSXP) { |
| s = allocSExp(CLOSXP); |
| SET_FORMALS(s, FORMALS(CAR(args))); |
| SET_BODY(s, R_NilValue); |
| SET_CLOENV(s, R_GlobalEnv); |
| return s; |
| } |
| |
| if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) { |
| char *nm = PRIMNAME(CAR(args)); |
| SEXP env, s2; |
| PROTECT_INDEX xp; |
| |
| PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv, |
| install(".ArgsEnv"), TRUE), |
| &xp); |
| |
| if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp); |
| PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE)); |
| if(s2 != R_UnboundValue) { |
| s = duplicate(s2); |
| SET_BODY(s, R_NilValue); |
| SET_CLOENV(s, R_GlobalEnv); |
| UNPROTECT(2); |
| return s; |
| } |
| UNPROTECT(1); /* s2 */ |
| REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"), |
| TRUE), xp); |
| if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp); |
| PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE)); |
| if(s2 != R_UnboundValue) { |
| s = allocSExp(CLOSXP); |
| SET_FORMALS(s, FORMALS(s2)); |
| SET_BODY(s, R_NilValue); |
| SET_CLOENV(s, R_GlobalEnv); |
| UNPROTECT(2); |
| return s; |
| } |
| UNPROTECT(2); |
| } |
| return R_NilValue; |
| } |
| |
| SEXP attribute_hidden do_formals(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| if (TYPEOF(CAR(args)) == CLOSXP) { |
| SEXP f = FORMALS(CAR(args)); |
| RAISE_NAMED(f, NAMED(CAR(args))); |
| return f; |
| } else { |
| if(!(TYPEOF(CAR(args)) == BUILTINSXP || |
| TYPEOF(CAR(args)) == SPECIALSXP)) |
| warningcall(call, _("argument is not a function")); |
| return R_NilValue; |
| } |
| } |
| |
| SEXP attribute_hidden do_body(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| if (TYPEOF(CAR(args)) == CLOSXP) { |
| SEXP b = BODY_EXPR(CAR(args)); |
| RAISE_NAMED(b, NAMED(CAR(args))); |
| return b; |
| } else { |
| if(!(TYPEOF(CAR(args)) == BUILTINSXP || |
| TYPEOF(CAR(args)) == SPECIALSXP)) |
| warningcall(call, _("argument is not a function")); |
| return R_NilValue; |
| } |
| } |
| |
| SEXP attribute_hidden do_bodyCode(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| if (TYPEOF(CAR(args)) == CLOSXP) { |
| SEXP bc = BODY(CAR(args)); |
| RAISE_NAMED(bc, NAMED(CAR(args))); |
| return bc; |
| } else return R_NilValue; |
| } |
| |
| /* get environment from a subclass if possible; else return NULL */ |
| #define simple_as_environment(arg) (IS_S4_OBJECT(arg) && (TYPEOF(arg) == S4SXP) ? R_getS4DataSlot(arg, ENVSXP) : arg) |
| |
| |
| SEXP attribute_hidden do_envir(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| if (TYPEOF(CAR(args)) == CLOSXP) |
| return CLOENV(CAR(args)); |
| else if (CAR(args) == R_NilValue) |
| return R_GlobalContext->sysparent; |
| else return getAttrib(CAR(args), R_DotEnvSymbol); |
| } |
| |
| SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP env, s = CAR(args); |
| |
| checkArity(op, args); |
| check1arg(args, call, "x"); |
| |
| env = CADR(args); |
| |
| if (TYPEOF(CAR(args)) == CLOSXP |
| && (isEnvironment(env) || |
| isEnvironment(env = simple_as_environment(env)) || |
| isNull(env))) { |
| if (isNull(env)) |
| error(_("use of NULL environment is defunct")); |
| if(MAYBE_SHARED(s)) |
| /* this copies but does not duplicate args or code */ |
| s = duplicate(s); |
| if (TYPEOF(BODY(s)) == BCODESXP) |
| /* switch to interpreted version if compiled */ |
| SET_BODY(s, R_ClosureExpr(CAR(args))); |
| SET_CLOENV(s, env); |
| } |
| else if (isNull(env) || isEnvironment(env) || |
| isEnvironment(env = simple_as_environment(env))) |
| setAttrib(s, R_DotEnvSymbol, env); |
| else |
| error(_("replacement object is not an environment")); |
| return s; |
| } |
| |
| |
| /** do_newenv() : .Internal(new.env(hash, parent, size)) |
| * |
| * @return a newly created environment() |
| */ |
| SEXP attribute_hidden do_newenv(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP enclos, size, ans; |
| int hash; |
| |
| checkArity(op, args); |
| |
| hash = asInteger(CAR(args)); |
| args = CDR(args); |
| enclos = CAR(args); |
| if (isNull(enclos)) { |
| error(_("use of NULL environment is defunct")); |
| enclos = R_BaseEnv; |
| } else |
| if( !isEnvironment(enclos) && |
| !isEnvironment((enclos = simple_as_environment(enclos)))) |
| error(_("'enclos' must be an environment")); |
| |
| if( hash ) { |
| args = CDR(args); |
| PROTECT(size = coerceVector(CAR(args), INTSXP)); |
| if (INTEGER(size)[0] == NA_INTEGER) |
| INTEGER(size)[0] = 0; /* so it will use the internal default */ |
| ans = R_NewHashedEnv(enclos, size); |
| UNPROTECT(1); |
| } else |
| ans = NewEnvironment(R_NilValue, R_NilValue, enclos); |
| return ans; |
| } |
| |
| SEXP attribute_hidden do_parentenv(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| SEXP arg = CAR(args); |
| |
| if( !isEnvironment(arg) && |
| !isEnvironment((arg = simple_as_environment(arg)))) |
| error( _("argument is not an environment")); |
| if( arg == R_EmptyEnv ) |
| error(_("the empty environment has no parent")); |
| return( ENCLOS(arg) ); |
| } |
| |
| static Rboolean R_IsImportsEnv(SEXP env) |
| { |
| if (isNull(env) || !isEnvironment(env)) |
| return FALSE; |
| if (ENCLOS(env) != R_BaseNamespace) |
| return FALSE; |
| SEXP name = getAttrib(env, R_NameSymbol); |
| if (!isString(name) || LENGTH(name) != 1) |
| return FALSE; |
| |
| const char *imports_prefix = "imports:"; |
| const char *name_string = CHAR(STRING_ELT(name, 0)); |
| if (!strncmp(name_string, imports_prefix, strlen(imports_prefix))) |
| return TRUE; |
| else |
| return FALSE; |
| } |
| |
| SEXP attribute_hidden do_parentenvgets(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP env, parent; |
| checkArity(op, args); |
| |
| env = CAR(args); |
| if (isNull(env)) { |
| error(_("use of NULL environment is defunct")); |
| env = R_BaseEnv; |
| } else |
| if( !isEnvironment(env) && |
| !isEnvironment((env = simple_as_environment(env)))) |
| error(_("argument is not an environment")); |
| if( env == R_EmptyEnv ) |
| error(_("can not set parent of the empty environment")); |
| if (R_EnvironmentIsLocked(env) && R_IsNamespaceEnv(env)) |
| error(_("can not set the parent environment of a namespace")); |
| if (R_EnvironmentIsLocked(env) && R_IsImportsEnv(env)) |
| error(_("can not set the parent environment of package imports")); |
| parent = CADR(args); |
| if (isNull(parent)) { |
| error(_("use of NULL environment is defunct")); |
| parent = R_BaseEnv; |
| } else |
| if( !isEnvironment(parent) && |
| !isEnvironment((parent = simple_as_environment(parent)))) |
| error(_("'parent' is not an environment")); |
| |
| SET_ENCLOS(env, parent); |
| |
| return( CAR(args) ); |
| } |
| |
| SEXP attribute_hidden do_envirName(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP env = CAR(args), ans=mkString(""), res; |
| |
| checkArity(op, args); |
| PROTECT(ans); |
| if (TYPEOF(env) == ENVSXP || |
| TYPEOF((env = simple_as_environment(env))) == ENVSXP) { |
| if (env == R_GlobalEnv) ans = mkString("R_GlobalEnv"); |
| else if (env == R_BaseEnv) ans = mkString("base"); |
| else if (env == R_EmptyEnv) ans = mkString("R_EmptyEnv"); |
| else if (R_IsPackageEnv(env)) |
| ans = ScalarString(STRING_ELT(R_PackageEnvName(env), 0)); |
| else if (R_IsNamespaceEnv(env)) |
| ans = ScalarString(STRING_ELT(R_NamespaceEnvSpec(env), 0)); |
| else if (!isNull(res = getAttrib(env, R_NameSymbol))) ans = res; |
| } |
| UNPROTECT(1); /* ans */ |
| return ans; |
| } |
| |
| #ifdef Win32 |
| # include "rgui_UTF8.h" |
| #endif |
| /* Uses R_alloc but called by a .Internal. Result may be R_alloc-ed */ |
| static const char *trChar(SEXP x) |
| { |
| size_t n = strlen(CHAR(x)); |
| cetype_t ienc = getCharCE(x); |
| |
| if (ienc == CE_BYTES) { |
| const char *p = CHAR(x), *q; |
| char *pp = R_alloc(4*n+1, 1), *qq = pp, buf[5]; |
| for (q = p; *q; q++) { |
| unsigned char k = (unsigned char) *q; |
| if (k >= 0x20 && k < 0x80) { |
| *qq++ = *q; |
| } else { |
| snprintf(buf, 5, "\\x%02x", k); |
| for(int j = 0; j < 4; j++) *qq++ = buf[j]; |
| } |
| } |
| *qq = '\0'; |
| return pp; |
| } else { |
| #ifdef Win32 |
| static char buf[106]; |
| char *p; |
| /* Long strings will be rare, and few per cat() call so we |
| can afford to be profligate here: translateChar is */ |
| if (n < 100) p = buf; else p = R_alloc(n+7, 1); |
| if (WinUTF8out && ienc == CE_UTF8) { |
| strcpy(p, UTF8in); strcat(p, CHAR(x)); strcat(p, UTF8out); |
| return p; |
| } else |
| #endif |
| return translateChar(x); |
| } |
| } |
| |
| static void cat_newline(SEXP labels, int *width, int lablen, int ntot) |
| { |
| Rprintf("\n"); |
| *width = 0; |
| if (labels != R_NilValue) { |
| Rprintf("%s ", EncodeString(STRING_ELT(labels, ntot % lablen), |
| 1, 0, Rprt_adj_left)); |
| *width += Rstrlen(STRING_ELT(labels, ntot % lablen), 0) + 1; |
| } |
| } |
| |
| static void cat_sepwidth(SEXP sep, int *width, int ntot) |
| { |
| if (sep == R_NilValue || LENGTH(sep) == 0) |
| *width = 0; |
| else |
| *width = Rstrlen(STRING_ELT(sep, ntot % LENGTH(sep)), 0); |
| } |
| |
| static void cat_printsep(SEXP sep, int ntot) |
| { |
| const char *sepchar; |
| if (sep == R_NilValue || LENGTH(sep) == 0) |
| return; |
| |
| sepchar = trChar(STRING_ELT(sep, ntot % LENGTH(sep))); |
| Rprintf("%s", sepchar); |
| return; |
| } |
| |
| typedef struct cat_info { |
| Rboolean wasopen; |
| int changedcon; |
| Rconnection con; |
| #ifdef Win32 |
| Rboolean saveWinUTF8out; |
| #endif |
| } cat_info; |
| |
| static void cat_cleanup(void *data) |
| { |
| cat_info *pci = (cat_info *) data; |
| Rconnection con = pci->con; |
| Rboolean wasopen = pci->wasopen; |
| int changedcon = pci->changedcon; |
| |
| con->fflush(con); |
| if(changedcon) switch_stdout(-1, 0); |
| /* previous line might have closed it */ |
| if(!wasopen && con->isopen) con->close(con); |
| #ifdef Win32 |
| WinUTF8out = pci->saveWinUTF8out; |
| #endif |
| } |
| |
| SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| cat_info ci; |
| RCNTXT cntxt; |
| SEXP objs, file, fill, sepr, labs, s; |
| int ifile; |
| Rconnection con; |
| int append; |
| int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines; |
| char buf[512]; |
| const char *p = ""; |
| |
| checkArity(op, args); |
| |
| /* Use standard printing defaults */ |
| PrintDefaults(); |
| |
| objs = CAR(args); |
| args = CDR(args); |
| |
| file = CAR(args); |
| ifile = asInteger(file); |
| con = getConnection(ifile); |
| if(!con->canwrite) /* if it is not open, we may not know yet */ |
| error(_("cannot write to this connection")); |
| args = CDR(args); |
| |
| sepr = CAR(args); |
| if (!isString(sepr)) |
| error(_("invalid '%s' specification"), "sep"); |
| nlsep = 0; |
| for (i = 0; i < LENGTH(sepr); i++) |
| if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */ |
| args = CDR(args); |
| |
| fill = CAR(args); |
| if ((!isNumeric(fill) && !isLogical(fill)) || (LENGTH(fill) != 1)) |
| error(_("invalid '%s' argument"), "fill"); |
| if (isLogical(fill)) { |
| if (asLogical(fill) == 1) |
| pwidth = R_print.width; |
| else |
| pwidth = INT_MAX; |
| } |
| else pwidth = asInteger(fill); |
| if(pwidth <= 0) { |
| warning(_("non-positive 'fill' argument will be ignored")); |
| pwidth = INT_MAX; |
| } |
| args = CDR(args); |
| |
| labs = CAR(args); |
| if (!isString(labs) && labs != R_NilValue) |
| error(_("invalid '%s' argument"), "labels"); |
| lablen = length(labs); |
| args = CDR(args); |
| |
| append = asLogical(CAR(args)); |
| if (append == NA_LOGICAL) |
| error(_("invalid '%s' specification"), "append"); |
| |
| ci.wasopen = con->isopen; |
| |
| ci.changedcon = switch_stdout(ifile, 0); |
| /* will open new connection if required, and check for writeable */ |
| #ifdef Win32 |
| /* do this after re-sinking output */ |
| ci.saveWinUTF8out = WinUTF8out; |
| WinCheckUTF8(); |
| #endif |
| |
| ci.con = con; |
| |
| /* set up a context which will close the connection if there is an error */ |
| begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, |
| R_NilValue, R_NilValue); |
| cntxt.cend = &cat_cleanup; |
| cntxt.cenddata = &ci; |
| |
| nobjs = length(objs); |
| width = 0; |
| ntot = 0; |
| nlines = 0; |
| for (iobj = 0; iobj < nobjs; iobj++) { |
| s = VECTOR_ELT(objs, iobj); |
| if (iobj != 0 && !isNull(s)) |
| cat_printsep(sepr, ntot++); |
| n = length(s); |
| /* 0-length objects are ignored */ |
| if (n > 0) { |
| if (labs != R_NilValue && (iobj == 0) |
| && (asInteger(fill) > 0)) { |
| Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen))); |
| /* FIXME -- Rstrlen allows for double-width chars */ |
| width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1; |
| nlines++; |
| } |
| if (isString(s)) |
| p = trChar(STRING_ELT(s, 0)); |
| else if (isSymbol(s)) /* length 1 */ |
| p = CHAR(PRINTNAME(s)); |
| else if (isVectorAtomic(s)) { |
| /* Not a string, as that is covered above. |
| Thus the maximum size is about 60. |
| The copy is needed as cat_newline might reuse the buffer. |
| Use strncpy is in case these assumptions change. |
| */ |
| p = EncodeElement0(s, 0, 0, OutDec); |
| strncpy(buf, p, 511); buf[511] = '\0'; |
| p = buf; |
| } |
| #ifdef fixed_cat |
| else if (isVectorList(s)) { |
| /* FIXME: call EncodeElement() for every element of s. |
| |
| Real Problem: `s' can be large; |
| should do line breaking etc.. (buf is of limited size) |
| */ |
| } |
| #endif |
| else |
| error(_("argument %d (type '%s') cannot be handled by 'cat'"), |
| 1+iobj, type2char(TYPEOF(s))); |
| /* FIXME : cat(...) should handle ANYTHING */ |
| size_t w = strlen(p); |
| cat_sepwidth(sepr, &sepw, ntot); |
| if ((iobj > 0) && (width + w + sepw > pwidth)) { |
| cat_newline(labs, &width, lablen, nlines); |
| nlines++; |
| } |
| for (i = 0; i < n; i++, ntot++) { |
| Rprintf("%s", p); |
| width += (int)(w + sepw); |
| if (i < (n - 1)) { |
| cat_printsep(sepr, ntot); |
| if (isString(s)) |
| p = trChar(STRING_ELT(s, i+1)); |
| else { |
| p = EncodeElement0(s, i+1, 0, OutDec); |
| strncpy(buf, p, 511); buf[511] = '\0'; |
| p = buf; |
| } |
| w = (int) strlen(p); |
| cat_sepwidth(sepr, &sepw, ntot); |
| /* This is inconsistent with the version above. |
| As from R 2.3.0, fill <= 0 is ignored. */ |
| if ((width + w + sepw > pwidth) && pwidth) { |
| cat_newline(labs, &width, lablen, nlines); |
| nlines++; |
| } |
| } else ntot--; /* we don't print sep after last, so don't advance */ |
| } |
| } |
| } |
| if ((pwidth != INT_MAX) || nlsep) |
| Rprintf("\n"); |
| |
| /* end the context after anything that could raise an error but before |
| doing the cleanup so the cleanup doesn't get done twice */ |
| endcontext(&cntxt); |
| |
| cat_cleanup(&ci); |
| |
| return R_NilValue; |
| } |
| |
| SEXP attribute_hidden do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int n, havenames; |
| /* compute number of args and check for names */ |
| SEXP next; |
| for (next = args, n = 0, havenames = FALSE; |
| next != R_NilValue; |
| next = CDR(next)) { |
| if (TAG(next) != R_NilValue) |
| havenames = TRUE; |
| n++; |
| } |
| |
| SEXP list = PROTECT(allocVector(VECSXP, n)); |
| SEXP names = PROTECT(havenames ? allocVector(STRSXP, n) : R_NilValue); |
| for (int i = 0; i < n; i++) { |
| if (havenames) { |
| if (TAG(args) != R_NilValue) |
| SET_STRING_ELT(names, i, PRINTNAME(TAG(args))); |
| else |
| SET_STRING_ELT(names, i, R_BlankString); |
| } |
| if (NAMED(CAR(args))) |
| ENSURE_NAMEDMAX(CAR(args)); |
| SET_VECTOR_ELT(list, i, CAR(args)); |
| args = CDR(args); |
| } |
| if (havenames) { |
| setAttrib(list, R_NamesSymbol, names); |
| } |
| UNPROTECT(2); |
| return list; |
| } |
| |
| /* This is a primitive SPECIALSXP */ |
| SEXP attribute_hidden do_expression(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP a, ans, nms; |
| int i, n, named; |
| named = 0; |
| n = length(args); |
| PROTECT(ans = allocVector(EXPRSXP, n)); |
| a = args; |
| for (i = 0; i < n; i++) { |
| if(MAYBE_REFERENCED(CAR(a))) |
| SET_VECTOR_ELT(ans, i, duplicate(CAR(a))); |
| else |
| SET_VECTOR_ELT(ans, i, CAR(a)); |
| if (TAG(a) != R_NilValue) named = 1; |
| a = CDR(a); |
| } |
| if (named) { |
| PROTECT(nms = allocVector(STRSXP, n)); |
| a = args; |
| for (i = 0; i < n; i++) { |
| if (TAG(a) != R_NilValue) |
| SET_STRING_ELT(nms, i, PRINTNAME(TAG(a))); |
| else |
| SET_STRING_ELT(nms, i, R_BlankString); |
| a = CDR(a); |
| } |
| setAttrib(ans, R_NamesSymbol, nms); |
| UNPROTECT(1); |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| /* vector(mode="logical", length=0) */ |
| SEXP attribute_hidden do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| R_xlen_t len; |
| SEXP s; |
| SEXPTYPE mode; |
| checkArity(op, args); |
| if (length(CADR(args)) != 1) error(_("invalid '%s' argument"), "length"); |
| len = asVecSize(CADR(args)); |
| if (len < 0) error(_("invalid '%s' argument"), "length"); |
| s = coerceVector(CAR(args), STRSXP); |
| if (length(s) != 1) error(_("invalid '%s' argument"), "mode"); |
| mode = str2type(CHAR(STRING_ELT(s, 0))); /* ASCII */ |
| if (mode == -1 && streql(CHAR(STRING_ELT(s, 0)), "double")) |
| mode = REALSXP; |
| switch (mode) { |
| case LGLSXP: |
| case INTSXP: |
| case REALSXP: |
| case CPLXSXP: |
| case STRSXP: |
| case EXPRSXP: |
| case VECSXP: |
| case RAWSXP: |
| s = allocVector(mode, len); |
| break; |
| case LISTSXP: |
| if (len > INT_MAX) error("too long for a pairlist"); |
| s = allocList((int) len); |
| break; |
| default: |
| error(_("vector: cannot make a vector of mode '%s'."), |
| translateChar(STRING_ELT(s, 0))); /* should be ASCII */ |
| } |
| if (mode == INTSXP || mode == LGLSXP) |
| Memzero(INTEGER(s), len); |
| else if (mode == REALSXP) |
| Memzero(REAL(s), len); |
| else if (mode == CPLXSXP) |
| Memzero(COMPLEX(s), len); |
| else if (mode == RAWSXP) |
| Memzero(RAW(s), len); |
| /* other cases: list/expression have "NULL", ok */ |
| return s; |
| } |
| |
| |
| /* do_lengthgets: assign a length to a vector or a list */ |
| /* (if it is vectorizable). We could probably be fairly */ |
| /* clever with memory here if we wanted to. */ |
| |
| /* used in connections.c, attrib.c, seq.c, .. */ |
| SEXP xlengthgets(SEXP x, R_xlen_t len) |
| { |
| R_xlen_t lenx, i; |
| SEXP rval, names, xnames, t; |
| if (!isVector(x) && !isList(x)) |
| error(_("cannot set length of non-(vector or list)")); |
| if (len < 0) error(_("invalid value")); // e.g. -999 from asVecSize() |
| if (isNull(x) && len > 0) |
| warning(_("length of NULL cannot be changed")); |
| lenx = xlength(x); |
| if (lenx == len) |
| return (x); |
| PROTECT(rval = allocVector(TYPEOF(x), len)); |
| PROTECT(xnames = getAttrib(x, R_NamesSymbol)); |
| if (xnames != R_NilValue) |
| names = allocVector(STRSXP, len); |
| else names = R_NilValue; /*- just for -Wall --- should we do this ? */ |
| switch (TYPEOF(x)) { |
| case NILSXP: |
| break; |
| case LGLSXP: |
| case INTSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| INTEGER(rval)[i] = INTEGER(x)[i]; |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| else |
| INTEGER(rval)[i] = NA_INTEGER; |
| break; |
| case REALSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| REAL(rval)[i] = REAL(x)[i]; |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| else |
| REAL(rval)[i] = NA_REAL; |
| break; |
| case CPLXSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| COMPLEX(rval)[i] = COMPLEX(x)[i]; |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| else { |
| COMPLEX(rval)[i].r = NA_REAL; |
| COMPLEX(rval)[i].i = NA_REAL; |
| } |
| break; |
| case STRSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| SET_STRING_ELT(rval, i, STRING_ELT(x, i)); |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| else |
| SET_STRING_ELT(rval, i, NA_STRING); |
| break; |
| case LISTSXP: |
| for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) { |
| SETCAR(t, CAR(x)); |
| SET_TAG(t, TAG(x)); |
| } |
| break; |
| case VECSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| SET_VECTOR_ELT(rval, i, VECTOR_ELT(x, i)); |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| break; |
| case RAWSXP: |
| for (i = 0; i < len; i++) |
| if (i < lenx) { |
| RAW(rval)[i] = RAW(x)[i]; |
| if (xnames != R_NilValue) |
| SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); |
| } |
| else |
| RAW(rval)[i] = (Rbyte) 0; |
| break; |
| default: |
| UNIMPLEMENTED_TYPE("length<-", x); |
| } |
| if (isVector(x) && xnames != R_NilValue) |
| setAttrib(rval, R_NamesSymbol, names); |
| // *not* keeping "class": in line with x[1:k] |
| UNPROTECT(2); |
| return rval; |
| } |
| |
| /* older version */ |
| SEXP lengthgets(SEXP x, R_len_t len) |
| { |
| return xlengthgets(x, (R_xlen_t) len); |
| } |
| |
| |
| SEXP attribute_hidden do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP x, ans; |
| |
| checkArity(op, args); |
| check1arg(args, call, "x"); |
| |
| x = CAR(args); |
| |
| if(isObject(x) && DispatchOrEval(call, op, "length<-", args, |
| rho, &ans, 0, 1)) |
| return(ans); |
| // more 'x' checks in xlengthgets() |
| if (length(CADR(args)) != 1) |
| error(_("wrong length for '%s' argument"), "value"); |
| R_xlen_t len = asVecSize(CADR(args)); |
| #ifndef LONG_VECTOR_SUPPORT |
| if (len > R_LEN_T_MAX) { |
| error(_("vector size specified is too large")); |
| return x; /* -Wall */ |
| } |
| #endif |
| return xlengthgets(x, len); |
| } |
| |
| /* Expand dots in args, but do not evaluate */ |
| static SEXP expandDots(SEXP el, SEXP rho) |
| { |
| SEXP ans, tail; |
| |
| PROTECT(el); /* in do_switch, this is already protected */ |
| PROTECT(ans = tail = CONS(R_NilValue, R_NilValue)); |
| |
| while (el != R_NilValue) { |
| if (CAR(el) == R_DotsSymbol) { |
| SEXP h = PROTECT(findVar(CAR(el), rho)); |
| if (TYPEOF(h) == DOTSXP || h == R_NilValue) { |
| while (h != R_NilValue) { |
| SETCDR(tail, CONS(CAR(h), R_NilValue)); |
| tail = CDR(tail); |
| if(TAG(h) != R_NilValue) SET_TAG(tail, TAG(h)); |
| h = CDR(h); |
| } |
| } else if (h != R_MissingArg) |
| error(_("'...' used in an incorrect context")); |
| UNPROTECT(1); /* h */ |
| } else { |
| SETCDR(tail, CONS(CAR(el), R_NilValue)); |
| tail = CDR(tail); |
| if(TAG(el) != R_NilValue) SET_TAG(tail, TAG(el)); |
| } |
| el = CDR(el); |
| } |
| UNPROTECT(2); |
| return CDR(ans); |
| } |
| |
| /* This function is used in do_switch to record the default value and |
| to detect multiple defaults, which are not allowed as of 2.13.x */ |
| |
| static SEXP setDflt(SEXP arg, SEXP dflt) |
| { |
| if (dflt) { |
| SEXP dflt1, dflt2; |
| PROTECT(dflt1 = deparse1line(dflt, TRUE)); |
| PROTECT(dflt2 = deparse1line(CAR(arg), TRUE)); |
| error(_("duplicate 'switch' defaults: '%s' and '%s'"), |
| CHAR(STRING_ELT(dflt1, 0)), CHAR(STRING_ELT(dflt2, 0))); |
| UNPROTECT(2); /* won't get here, but just for good form */ |
| } |
| return(CAR(arg)); |
| } |
| |
| /* For switch, evaluate the first arg, if it is a character then try |
| to match the name with the remaining args, and evaluate the match. If |
| the value is missing then take the next non-missing arg as the value. |
| Then things like switch(as.character(answer), yes=, YES=1, no=, NO=2, |
| 3) will work. But if there is no 'next', return NULL. One arg beyond |
| the first is allowed to be unnamed; it becomes the default value if |
| there is no match. |
| |
| If the value of the first arg is not a character string |
| then coerce it to an integer k and choose the kth argument from those |
| that remain provided 1 < k < nargs. |
| |
| Changed in 2.11.0 to be primitive, so the wrapper does not partially |
| match to EXPR, and to return NULL invisibly if it is an error |
| condition. |
| |
| This is a SPECIALSXP, so arguments need to be evaluated as needed. |
| And (see names.c) X=2, so it defaults to a visible value. |
| */ |
| |
| |
| SEXP attribute_hidden do_switch(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int argval, nargs = length(args); |
| SEXP x, y, z, w, ans, dflt = NULL; |
| |
| if (nargs < 1) errorcall(call, _("'EXPR' is missing")); |
| check1arg(args, call, "EXPR"); |
| PROTECT(x = eval(CAR(args), rho)); |
| if (!isVector(x) || LENGTH(x) != 1) |
| errorcall(call, _("EXPR must be a length 1 vector")); |
| if (isFactor(x)) |
| warningcall(call, |
| _("EXPR is a \"factor\", treated as integer.\n" |
| " Consider using '%s' instead."), |
| "switch(as.character( * ), ...)"); |
| if (nargs > 1) { |
| /* There is a complication: if called from lapply |
| there may be a ... argument */ |
| PROTECT(w = expandDots(CDR(args), rho)); |
| if (isString(x)) { |
| for (y = w; y != R_NilValue; y = CDR(y)) { |
| if (TAG(y) != R_NilValue) { |
| if (pmatch(STRING_ELT(x, 0), TAG(y), 1 /* exact */)) { |
| /* Find the next non-missing argument. |
| (If there is none, return NULL.) */ |
| while (CAR(y) == R_MissingArg) { |
| y = CDR(y); |
| if (y == R_NilValue) break; |
| if (TAG(y) == R_NilValue) dflt = setDflt(y, dflt); |
| } |
| if (y == R_NilValue) { |
| R_Visible = FALSE; |
| UNPROTECT(2); |
| return R_NilValue; |
| } |
| /* Check for multiple defaults following y. This loop |
| is not necessary to determine the value of the |
| switch(), but it should be fast and will detect |
| typos. */ |
| for (z = CDR(y); z != R_NilValue; z = CDR(z)) |
| if (TAG(z) == R_NilValue) dflt = setDflt(z, dflt); |
| |
| ans = eval(CAR(y), rho); |
| UNPROTECT(2); |
| return ans; |
| } |
| } else |
| dflt = setDflt(y, dflt); |
| } |
| if (dflt) { |
| ans = eval(dflt, rho); |
| UNPROTECT(2); |
| return ans; |
| } |
| /* fall through to error */ |
| } else { /* Treat as numeric */ |
| argval = asInteger(x); |
| if (argval != NA_INTEGER && argval >= 1 && argval <= length(w)) { |
| SEXP alt = CAR(nthcdr(w, argval - 1)); |
| if (alt == R_MissingArg) |
| error("empty alternative in numeric switch"); |
| ans = eval(alt, rho); |
| UNPROTECT(2); |
| return ans; |
| } |
| /* fall through to error */ |
| } |
| UNPROTECT(1); /* w */ |
| } else |
| warningcall(call, _("'switch' with no alternatives")); |
| /* an error */ |
| UNPROTECT(1); /* x */ |
| R_Visible = FALSE; |
| return R_NilValue; |
| } |