SEXP attribute_hidden do_colon(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP s1, s2;
double n1, n2;
checkArity(op, args);
if (inheritsCharSXP(CAR(args), R_FactorCharSXP) && inheritsCharSXP(CADR(args), R_FactorCharSXP))
return(cross_colon(call, CAR(args), CADR(args)));
s1 = CAR(args);
s2 = CADR(args);
n1 = length(s1);
n2 = length(s2);
if (n1 == 0 || n2 == 0)
errorcall(call, _("argument of length 0"));
if (n1 > 1)
warningcall(call,
ngettext("numerical expression has %d element: only the first used",
"numerical expression has %d elements: only the first used",
(int) n1), (int) n1);
if (n2 > 1)
warningcall(call,
ngettext("numerical expression has %d element: only the first used",
"numerical expression has %d elements: only the first used",
(int) n2), (int) n2);
n1 = asReal(s1);
n2 = asReal(s2);
if (ISNAN(n1) || ISNAN(n2))
errorcall(call, _("NA/NaN argument"));
return seq_colon(n1, n2, call);
}
static void Putenv(char *a, char *b)
{
char *buf, *value, *p, *q, quote='\0';
int inquote = 0;
#ifdef HAVE_SETENV
buf = (char *) malloc((strlen(b) + 1) * sizeof(char));
if(!buf) R_Suicide("allocation failure in reading Renviron");
value = buf;
#else
buf = (char *) malloc((strlen(a) + strlen(b) + 2) * sizeof(char));
if(!buf) R_Suicide("allocation failure in reading Renviron");
strcpy(buf, a); strcat(buf, "=");
value = buf+strlen(buf);
#endif
/* now process the value */
for(p = b, q = value; *p; p++) {
/* remove quotes around sections, preserve \ inside quotes */
if(!inquote && (*p == '"' || *p == '\'')) {
inquote = 1;
quote = *p;
continue;
}
if(inquote && *p == quote && *(p-1) != '\\') {
inquote = 0;
continue;
}
if(!inquote && *p == '\\') {
if(*(p+1) == '\n') p++;
else if(*(p+1) == '\\') *q++ = *p;
continue;
}
if(inquote && *p == '\\' && *(p+1) == quote) continue;
*q++ = *p;
}
*q = '\0';
#ifdef HAVE_SETENV
if(setenv(a, buf, 1))
warningcall(R_NilValue,
_("problem in setting variable '%s' in Renviron"), a);
free(buf);
#elif defined(HAVE_PUTENV)
if(putenv(buf))
warningcall(R_NilValue,
_("problem in setting variable '%s' in Renviron"), a);
/* no free here: storage remains in use */
#else
/* pretty pointless, and was not tested prior to 2.3.0 */
free(buf);
#endif
}
/*
* nfile = number of files
* file = array of filenames
* editor = editor to be used.
*/
int R_EditFiles(int nfile, const char **file, const char **title,
const char *editor)
{
char buf[1024];
if (ptr_R_EditFiles) return(ptr_R_EditFiles(nfile, file, title, editor));
if (nfile > 0) {
if (nfile > 1)
R_ShowMessage(_("WARNING: Only editing the first in the list of files"));
if (ptr_R_EditFile) ptr_R_EditFile((char *) file[0]);
else {
/* Quote path if necessary */
if (editor[0] != '"' && Rf_strchr(editor, ' '))
snprintf(buf, 1024, "\"%s\" \"%s\"", editor, file[0]);
else
snprintf(buf, 1024, "%s \"%s\"", editor, file[0]);
if (R_system(buf) == 127)
warningcall(R_NilValue, _("error in running command"));
}
return 0;
}
return 1;
}
SEXP attribute_hidden do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue;
checkArity(op,args);
#define find_char_fun \
if (isValidString(CAR(args))) { \
SEXP s; \
PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0))); \
SETCAR(args, findFun(s, rho)); \
UNPROTECT(1); \
}
find_char_fun
if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP
&& TYPEOF(CAR(args)) != BUILTINSXP )
errorcall(call, _("argument must be a closure"));
switch(PRIMVAL(op)) {
case 0:
SET_RDEBUG(CAR(args), 1);
break;
case 1:
if( RDEBUG(CAR(args)) != 1 )
warningcall(call, "argument is not being debugged");
SET_RDEBUG(CAR(args), 0);
break;
case 2:
ans = ScalarLogical(RDEBUG(CAR(args)));
break;
case 3:
SET_RSTEP(CAR(args), 1);
break;
}
return ans;
}
static SEXP
seq(SEXP call, SEXP s1, SEXP s2)
{
int i, n, in1;
double n1, n2, r;
SEXP ans;
Rboolean useInt;
n1 = length(s1);
if( n1 > 1 )
warningcall(call,
_("numerical expression has %d elements: only the first used"), (int) n1);
n2 = length(s2);
if( n2 > 1 )
warningcall(call, _("numerical expression has %d elements: only the first used"), (int) n2);
n1 = asReal(s1);
n2 = asReal(s2);
if (ISNAN(n1) || ISNAN(n2))
errorcall(call, _("NA/NaN argument"));
in1 = (int)(n1);
useInt = (n1 == in1);
if (n1 <= INT_MIN || n2 <= INT_MIN || n1 > INT_MAX || n2 > INT_MAX)
useInt = FALSE;
r = fabs(n2 - n1);
if(r >= INT_MAX) errorcall(call, _("result would be too long a vector"));
n = r + 1 + FLT_EPSILON;
if (useInt) {
ans = allocVector(INTSXP, n);
if (n1 <= n2)
for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 + i;
else
for (i = 0; i < n; i++) INTEGER(ans)[i] = in1 - i;
} else {
ans = allocVector(REALSXP, n);
if (n1 <= n2)
for (i = 0; i < n; i++) REAL(ans)[i] = n1 + i;
else
for (i = 0; i < n; i++) REAL(ans)[i] = n1 - i;
}
return ans;
}
SEXP attribute_hidden complex_math2(SEXP call, SEXP op, SEXP args, SEXP env)
{
R_xlen_t i, n, na, nb;
Rcomplex ai, bi, *a, *b, *y;
SEXP sa, sb, sy;
Rboolean naflag = FALSE;
cm2_fun f;
switch (PRIMVAL(op)) {
case 0: /* atan2 */
f = z_atan2; break;
case 10001: /* round */
f = z_rround; break;
case 2: /* passed from do_log1arg */
case 10:
case 10003: /* passed from do_log */
f = z_logbase; break;
case 10004: /* signif */
f = z_prec; break;
default:
errorcall_return(call, _("unimplemented complex function"));
}
PROTECT(sa = coerceVector(CAR(args), CPLXSXP));
PROTECT(sb = coerceVector(CADR(args), CPLXSXP));
na = XLENGTH(sa); nb = XLENGTH(sb);
if ((na == 0) || (nb == 0)) {
UNPROTECT(2);
return(allocVector(CPLXSXP, 0));
}
n = (na < nb) ? nb : na;
PROTECT(sy = allocVector(CPLXSXP, n));
a = COMPLEX(sa); b = COMPLEX(sb); y = COMPLEX(sy);
for (i = 0; i < n; i++) {
ai = a[i % na]; bi = b[i % nb];
if(ISNA(ai.r) && ISNA(ai.i) &&
ISNA(bi.r) && ISNA(bi.i)) {
y[i].r = NA_REAL; y[i].i = NA_REAL;
} else {
f(&y[i], &ai, &bi);
if ( (ISNAN(y[i].r) || ISNAN(y[i].i)) &&
!(ISNAN(ai.r) || ISNAN(ai.i) || ISNAN(bi.r) || ISNAN(bi.i)) )
naflag = TRUE;
}
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
if(n == na) {
DUPLICATE_ATTRIB(sy, sa);
} else if(n == nb) {
DUPLICATE_ATTRIB(sy, sb);
}
UNPROTECT(3);
return sy;
}
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, s, t, call2;
int narm, has_na = 0;
/* initialize for behavior on empty vector
all(logical(0)) -> TRUE
any(logical(0)) -> FALSE
*/
Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2);
return(ans);
}
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
for (s = args; s != R_NilValue; s = CDR(s)) {
t = CAR(s);
/* Avoid memory waste from coercing empty inputs, and also
avoid warnings with empty lists coming from sapply */
if(xlength(t) == 0) continue;
/* coerceVector protects its argument so this actually works
just fine */
if (TYPEOF(t) != LGLSXP) {
/* Coercion of integers seems reasonably safe, but for
other types it is more often than not an error.
One exception is perhaps the result of lapply, but
then sapply was often what was intended. */
if(TYPEOF(t) != INTSXP)
warningcall(call,
_("coercing argument of type '%s' to logical"),
type2char(TYPEOF(t)));
t = coerceVector(t, LGLSXP);
}
val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
if (val != NA_LOGICAL) {
if ((PRIMVAL(op) == _OP_ANY && val)
|| (PRIMVAL(op) == _OP_ALL && !val)) {
has_na = 0;
break;
}
} else has_na = 1;
}
UNPROTECT(2);
return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
SEXP attribute_hidden do_readEnviron(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP x = CAR(args);
if (!isString(x) || LENGTH(x) != 1)
errorcall(call, _("argument '%s' must be a character string"), "x");
const char *fn = R_ExpandFileName(translateChar(STRING_ELT(x, 0)));
int res = process_Renviron(fn);
if (!res)
warningcall(call, _("file '%s' cannot be opened for reading"), fn);
return ScalarLogical(res != 0);
}
SEXP attribute_hidden do_seq_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_xlen_t len;
checkArity(op, args);
check1argSymbol(args, call, R_LengthOutSymbol);
if(length(CAR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
#ifdef LONG_VECTOR_SUPPORT
double dlen = asReal(CAR(args));
if(!R_FINITE(dlen) || dlen < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
len = (R_xlen_t) dlen;
#else
len = asInteger(CAR(args));
if(len == NA_INTEGER || len < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
#endif
#ifdef LONG_VECTOR_SUPPORT
if (len > INT_MAX) {
ans = allocVector(REALSXP, len);
double *p = REAL(ans);
for(R_xlen_t i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = (double) (i+1);
}
} else
#endif
{
ans = allocVector(INTSXP, len);
int *p = INTEGER(ans);
for(int i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = i+1;
}
}
return ans;
}
SEXP R_parse(SEXP x, SEXP bigint_as_char) {
/* get data from R */
const char* json = translateCharUTF8(asChar(x));
const int bigint = asLogical(bigint_as_char);
/* ignore BOM as suggested by RFC */
if(json[0] == '\xEF' && json[1] == '\xBB' && json[2] == '\xBF'){
warningcall(R_NilValue, "JSON string contains (illegal) UTF8 byte-order-mark!");
json = json + 3;
}
/* parse json */
char errbuf[1024];
yajl_val node = yajl_tree_parse(json, errbuf, sizeof(errbuf));
/* parser error */
if (!node) {
Rf_errorcall(R_NilValue, errbuf);
}
SEXP out = ParseValue(node, bigint);
yajl_tree_free(node);
return(out);
}
SEXP attribute_hidden complex_math1(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y;
R_xlen_t n;
Rboolean naflag = FALSE;
PROTECT(x = CAR(args));
n = xlength(x);
PROTECT(y = allocVector(CPLXSXP, n));
switch (PRIMVAL(op)) {
case 10003: naflag = cmath1(clog, COMPLEX(x), COMPLEX(y), n); break;
case 3: naflag = cmath1(csqrt, COMPLEX(x), COMPLEX(y), n); break;
case 10: naflag = cmath1(cexp, COMPLEX(x), COMPLEX(y), n); break;
case 20: naflag = cmath1(ccos, COMPLEX(x), COMPLEX(y), n); break;
case 21: naflag = cmath1(csin, COMPLEX(x), COMPLEX(y), n); break;
case 22: naflag = cmath1(z_tan, COMPLEX(x), COMPLEX(y), n); break;
case 23: naflag = cmath1(z_acos, COMPLEX(x), COMPLEX(y), n); break;
case 24: naflag = cmath1(z_asin, COMPLEX(x), COMPLEX(y), n); break;
case 25: naflag = cmath1(z_atan, COMPLEX(x), COMPLEX(y), n); break;
case 30: naflag = cmath1(ccosh, COMPLEX(x), COMPLEX(y), n); break;
case 31: naflag = cmath1(csinh, COMPLEX(x), COMPLEX(y), n); break;
case 32: naflag = cmath1(ctanh, COMPLEX(x), COMPLEX(y), n); break;
case 33: naflag = cmath1(z_acosh, COMPLEX(x), COMPLEX(y), n); break;
case 34: naflag = cmath1(z_asinh, COMPLEX(x), COMPLEX(y), n); break;
case 35: naflag = cmath1(z_atanh, COMPLEX(x), COMPLEX(y), n); break;
default:
/* such as sign, gamma */
errorcall(call, _("unimplemented complex function"));
}
if (naflag)
warningcall(call, "NaNs produced in function \"%s\"", PRIMNAME(op));
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
return y;
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
rpipe *fp;
char buf[INTERN_BUFSIZE];
const char *fout = "", *ferr = "";
int vis = 0, flag = 2, i = 0, j, ll = 0;
SEXP cmd, fin, Stdout, Stderr, tlist = R_NilValue, tchar, rval;
int timeout = 0, timedout = 0;
checkArity(op, args);
cmd = CAR(args);
if (!isString(cmd) || LENGTH(cmd) != 1)
errorcall(call, _("character string expected as first argument"));
args = CDR(args);
flag = asInteger(CAR(args)); args = CDR(args);
if (flag >= 20) {vis = -1; flag -= 20;}
else if (flag >= 10) {vis = 0; flag -= 10;}
else vis = 1;
fin = CAR(args);
if (!isString(fin))
errorcall(call, _("character string expected as third argument"));
args = CDR(args);
Stdout = CAR(args);
args = CDR(args);
Stderr = CAR(args);
args = CDR(args);
timeout = asInteger(CAR(args));
if (timeout == NA_INTEGER || timeout < 0 || timeout > 2000000)
/* the limit could be increased, but not much as in milliseconds it
has to fit into a 32-bit unsigned integer */
errorcall(call, _("invalid '%s' argument"), "timeout");
if (timeout && !flag)
errorcall(call, "Timeout with background running processes is not supported.");
if (CharacterMode == RGui) {
/* This is a rather conservative approach: if
Rgui is launched from a console window it does have
standard handles -- but users might well not expect that.
*/
SetStdHandle(STD_INPUT_HANDLE, INVALID_HANDLE_VALUE);
SetStdHandle(STD_OUTPUT_HANDLE, INVALID_HANDLE_VALUE);
SetStdHandle(STD_ERROR_HANDLE, INVALID_HANDLE_VALUE);
if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
} else {
if (flag == 2) flag = 1; /* ignore std.output.on.console */
if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
else if (asLogical(Stdout) == 0) fout = NULL;
if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
else if (asLogical(Stderr) == 0) ferr = NULL;
}
if (flag < 2) { /* Neither intern = TRUE nor
show.output.on.console for Rgui */
ll = runcmd_timeout(CHAR(STRING_ELT(cmd, 0)),
getCharCE(STRING_ELT(cmd, 0)),
flag, vis, CHAR(STRING_ELT(fin, 0)), fout, ferr,
timeout, &timedout);
} else {
/* read stdout +/- stderr from pipe */
int m = 0;
if(flag == 2 /* show on console */ || CharacterMode == RGui) m = 3;
if(TYPEOF(Stderr) == LGLSXP)
m = asLogical(Stderr) ? 2 : 0;
if(m && TYPEOF(Stdout) == LGLSXP && asLogical(Stdout)) m = 3;
fp = rpipeOpen(CHAR(STRING_ELT(cmd, 0)), getCharCE(STRING_ELT(cmd, 0)),
vis, CHAR(STRING_ELT(fin, 0)), m, fout, ferr, timeout);
if (!fp) {
/* If intern = TRUE generate an error */
if (flag == 3) error(runerror());
ll = NOLAUNCH;
} else {
/* FIXME: use REPROTECT */
if (flag == 3) {
PROTECT(tlist);
/* honour intern = FALSE, ignore.stdout = TRUE */
if (m > 0 ||
(!(TYPEOF(Stdout) == LGLSXP && !asLogical(Stdout))))
for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++) {
ll = strlen(buf) - 1;
if ((ll >= 0) && (buf[ll] == '\n')) buf[ll] = '\0';
tchar = mkChar(buf);
UNPROTECT(1); /* tlist */
PROTECT(tlist = CONS(tchar, tlist));
}
} else {
for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++)
R_WriteConsole(buf, strlen(buf));
}
ll = rpipeClose(fp, &timedout);
}
}
if (timedout) {
ll = 124;
warningcall(R_NilValue, _("command '%s' timed out"),
CHAR(STRING_ELT(cmd, 0)));
} else if (flag == 3 && ll) {
warningcall(R_NilValue,
_("running command '%s' had status %d"),
CHAR(STRING_ELT(cmd, 0)), ll);
}
if (flag == 3) { /* intern = TRUE: convert pairlist to list */
PROTECT(rval = allocVector(STRSXP, i));
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
if(ll) {
SEXP lsym = install("status");
setAttrib(rval, lsym, ScalarInteger(ll));
}
UNPROTECT(2);
return rval;
} else {
rval = ScalarInteger(ll);
R_Visible = 0;
return rval;
}
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ti, ed, t;
char *filename, *editcmd, *vmaxsave, *cmd;
FILE *fp;
#ifdef Win32
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
strcpy(filename, CHAR(STRING_ELT(fn, 0)));
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(t); i++)
fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
fclose(fp);
}
ti = CAR(args); args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = CHAR(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, 1, 1, "");
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "%s %s", cmd, filename);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
R_ParseCnt = 0;
x = PROTECT(R_ParseFile(fp, -1, &status));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(2);
vmaxset(vmaxsave);
return (x);
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
SEXP y, nlist;
size_t slen;
PROTECT(input);
PROTECT(x);
/* Optimisation to prevent repeated recalculation */
slen = strlen(translateChar(input));
/* The mechanism to allow a class extending "environment" */
if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, "$ operator not defined for this S4 class");
}
UNPROTECT(1); /* x */
PROTECT(x);
/* If this is not a list object we return NULL. */
if (isPairList(x)) {
SEXP xmatch = R_NilValue;
int havematch;
UNPROTECT(2); /* input, x */
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = TAG(xmatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = CAR(xmatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
R_xlen_t i, n, imatch = -1;
int havematch;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2); /* input, x */
n = xlength(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
if (havematch == 1) {
/* partial matches can cause aliasing in eval.c:evalseq
This is overkill, but alternative ways to prevent
the aliasing appear to be even worse */
y = VECTOR_ELT(x,i);
SET_NAMED(y,2);
SET_VECTOR_ELT(x,i,y);
}
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = STRING_ELT(nlist, imatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, installTrChar(input));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1); /* y */
}
UNPROTECT(2); /* input, x */
if( y != R_UnboundValue ) {
if (NAMED(y))
SET_NAMED(y, 2);
else if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
else if( isVectorAtomic(x) ){
errorcall(call, "$ operator is invalid for atomic vectors");
}
else /* e.g. a function */
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
UNPROTECT(2); /* input, x */
return R_NilValue;
}
SEXP attribute_hidden do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP tlist = R_NilValue;
int intern = 0;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
error(_("non-empty character argument expected"));
intern = asLogical(CADR(args));
if (intern == NA_INTEGER)
error(_("'intern' must be logical and not NA"));
if (intern) { /* intern = TRUE */
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
const char *cmd;
int i, j, res;
SEXP tchar, rval;
PROTECT(tlist);
cmd = translateChar(STRING_ELT(CAR(args), 0));
errno = 0; /* precaution */
if(!(fp = R_popen(cmd, x)))
error(_("cannot popen '%s', probable reason '%s'"),
cmd, strerror(errno));
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
size_t read = strlen(buf);
if(read >= INTERN_BUFSIZE - 1)
warning(_("line %d may be truncated in call to system(, intern = TRUE)"), i + 1);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
res = pclose(fp);
#ifdef HAVE_SYS_WAIT_H
if (WIFEXITED(res)) res = WEXITSTATUS(res);
else res = 0;
#else
/* assume that this is shifted if a multiple of 256 */
if ((res % 256) == 0) res = res/256;
#endif
if ((res & 0xff) == 127) {/* 127, aka -1 */
if (errno)
error(_("error in running command: '%s'"), strerror(errno));
else
error(_("error in running command"));
} else if (res) {
if (errno)
warningcall(R_NilValue,
_("running command '%s' had status %d and error message '%s'"),
cmd, res,
strerror(errno));
else
warningcall(R_NilValue,
_("running command '%s' had status %d"),
cmd, res);
}
rval = PROTECT(allocVector(STRSXP, i));
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
if(res) {
SEXP lsym = install("status");
setAttrib(rval, lsym, ScalarInteger(res));
if(errno) {
lsym = install("errmsg");
setAttrib(rval, lsym, mkString(strerror(errno)));
}
}
UNPROTECT(2);
return rval;
}
else { /* intern = FALSE */
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = PROTECT(allocVector(INTSXP, 1));
fflush(stdout);
INTEGER(tlist)[0] = R_system(translateChar(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
UNPROTECT(1);
R_Visible = 0;
return tlist;
}
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP
x = CAR(args),
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if ( !(isNull(x) || isNumber(x)) ||
!(isNull(y) || isNumber(y)) )
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
R_xlen_t
nx = xlength(x),
ny = xlength(y);
Rboolean
xarray = isArray(x),
yarray = isArray(y),
xts = isTs(x),
yts = isTs(y);
SEXP dims, xnames, ynames;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray && (ny != 0 || nx == 0)) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (yarray && (nx != 0 || ny == 0)) {
PROTECT(dims = getAttrib(y, R_DimSymbol));
} else
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
SEXP klass = NULL, tsp = NULL; // -Wall
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (nx < ny)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (ny < nx)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (nx > 0 && ny > 0) {
if(((nx > ny) ? nx % ny : ny % nx) != 0) // mismatch
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
x = binaryLogic2(PRIMVAL(op), x, y);
}
else {
if(isNull(x))
x = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(x)
x = SETCAR(args, coerceVector(x, LGLSXP));
if(isNull(y))
y = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(y)
y = SETCADR(args, coerceVector(y, LGLSXP));
x = binaryLogic(PRIMVAL(op), x, y);
}
} else { // nx == 0 || ny == 0
x = allocVector(LGLSXP, 0);
}
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(xnames != R_NilValue && XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(ynames != R_NilValue && XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
void tcltk_init(int *TkUp)
{
int code;
*TkUp = 0;
/* Absence of the following line is said to be an error with
* tcl >= 8.4 on all platforms, and is known to cause crashes under
* Windows */
Tcl_FindExecutable(NULL);
RTcl_interp = Tcl_CreateInterp();
code = Tcl_Init(RTcl_interp);
if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));
/* HAVE_AQUA is not really right here.
On Mac OS X we might be using Aqua Tcl/Tk or X11 Tcl/Tk, and that
is in principle independent of whether we want quartz() built.
*/
#if !defined(Win32) && !defined(HAVE_AQUA)
char *p= getenv("DISPLAY");
if(p && p[0]) /* exclude DISPLAY = "" */
#endif
{
code = Tk_Init(RTcl_interp); /* Load Tk into interpreter */
if (code != TCL_OK) {
warning(Tcl_GetStringResult(RTcl_interp));
} else {
Tcl_StaticPackage(RTcl_interp, "Tk", Tk_Init, Tk_SafeInit);
code = Tcl_Eval(RTcl_interp, "wm withdraw ."); /* Hide window */
if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));
*TkUp = 1;
}
}
#if !defined(Win32) && !defined(HAVE_AQUA)
else
warningcall(R_NilValue, _("no DISPLAY variable so Tk is not available"));
#endif
Tcl_CreateCommand(RTcl_interp,
"R_eval",
R_eval,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(RTcl_interp,
"R_call",
R_call,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(RTcl_interp,
"R_call_lang",
R_call_lang,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
#ifndef Win32
Tcl_unix_setup();
#endif
Tcl_SetServiceMode(TCL_SERVICE_ALL);
/*** We may want to revive this at some point ***/
#if 0
code = Tcl_EvalFile(RTcl_interp, "init.tcl");
if (code != TCL_OK)
error("%s\n", Tcl_GetStringResult(RTcl_interp));
#endif
}
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP x, y, dims, tsp, klass, xnames, ynames;
R_xlen_t mismatch, nx, ny;
int xarray, yarray, xts, yts;
mismatch = 0;
x = CAR(args);
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
tsp = R_NilValue; /* -Wall */
klass = R_NilValue; /* -Wall */
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
error(_("binary operation on non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
nx = XLENGTH(x);
ny = XLENGTH(y);
if(nx > 0 && ny > 0) {
if(nx > ny) mismatch = nx % ny;
else mismatch = ny % nx;
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (XLENGTH(x) < XLENGTH(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (XLENGTH(y) < XLENGTH(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if(mismatch)
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
PROTECT(x = binaryLogic2(PRIMVAL(op), x, y));
} else {
if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
x = SETCAR(args, coerceVector(x, LGLSXP));
y = SETCADR(args, coerceVector(y, LGLSXP));
PROTECT(x = binaryLogic(PRIMVAL(op), x, y));
}
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
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 */
}
/* an error */
UNPROTECT(1); /* x */
R_Visible = FALSE;
return R_NilValue;
}
/* used here and in subset.c and subassign.c */
R_xlen_t attribute_hidden
get1index(SEXP s, SEXP names, R_xlen_t len, int pok, int pos, SEXP call)
{
/* Get a single index for the [[ and [[<- operators.
Checks that only one index is being selected.
Returns -1 for no match.
s is the subscript
len is the length of the object or dimension, with names its (dim)names.
pos is len-1 or -1 for [[, -1 for [[<-
-1 means use the only element of length-1 s.
pok : is "partial ok" ?
if pok is -1, warn if partial matching occurs, but allow.
*/
int warn_pok = 0;
const char *ss, *cur_name;
R_xlen_t indx;
const void *vmax;
if (pok == -1) {
pok = 1;
warn_pok = 1;
}
if (pos < 0 && length(s) != 1) {
if (length(s) > 1) {
ECALL(call, _("attempt to select more than one element"));
} else {
ECALL(call, _("attempt to select less than one element"));
}
} else
if(pos >= length(s)) {
ECALL(call, _("internal error in use of recursive indexing"));
}
if(pos < 0) pos = 0;
indx = -1;
switch (TYPEOF(s)) {
case LGLSXP:
case INTSXP:
{
int i = INTEGER(s)[pos];
if (i != NA_INTEGER)
indx = integerOneIndex(i, len, call);
break;
}
case REALSXP:
{
double dblind = REAL(s)[pos];
if(!ISNAN(dblind)) {
/* see comment above integerOneIndex */
if (dblind > 0) indx = (R_xlen_t)(dblind - 1);
else if (dblind == 0 || len < 2) {
ECALL(call, _("attempt to select less than one element"));
} else if (len == 2 && dblind > -3)
indx = (R_xlen_t)(2 + dblind);
else {
ECALL(call, _("attempt to select more than one element"));
}
}
break;
}
case STRSXP:
/* NA matches nothing */
if(STRING_ELT(s, pos) == NA_STRING) break;
/* "" matches nothing: see names.Rd */
if(!CHAR(STRING_ELT(s, pos))[0]) break;
/* Try for exact match */
vmax = vmaxget();
ss = translateChar(STRING_ELT(s, pos));
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING) {
if (streql(translateChar(STRING_ELT(names, i)), ss)) {
indx = i;
break;
}
}
/* Try for partial match */
if (pok && indx < 0) {
size_t len = strlen(ss);
for(R_xlen_t i = 0; i < xlength(names); i++) {
if (STRING_ELT(names, i) != NA_STRING) {
cur_name = translateChar(STRING_ELT(names, i));
if(!strncmp(cur_name, ss, len)) {
if(indx == -1) {/* first one */
indx = i;
if (warn_pok) {
if (call == R_NilValue)
warning(_("partial match of '%s' to '%s'"),
ss, cur_name);
else
warningcall(call,
_("partial match of '%s' to '%s'"),
ss, cur_name);
}
}
else {
indx = -2;/* more than one partial match */
if (warn_pok) /* already given context */
warningcall(R_NilValue,
_("further partial match of '%s' to '%s'"),
ss, cur_name);
break;
}
}
}
}
}
vmaxset(vmax);
break;
case SYMSXP:
vmax = vmaxget();
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING &&
streql(translateChar(STRING_ELT(names, i)),
CHAR(PRINTNAME(s)))) {
indx = i;
vmaxset(vmax);
break;
}
default:
if (call == R_NilValue)
error(_("invalid subscript type '%s'"), type2char(TYPEOF(s)));
else
errorcall(call, _("invalid subscript type '%s'"),
type2char(TYPEOF(s)));
}
return indx;
}
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
int nargs = length(args), lf;
Rboolean One = nargs == 1;
R_xlen_t i, lout = NA_INTEGER;
static SEXP do_seq_formals = NULL;
if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
return(ans);
/* This is a primitive and we manage argument matching ourselves.
We pretend this is
seq(from, to, by, length.out, along.with, ...)
*/
if (do_seq_formals == NULL) {
do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
R_PreserveObject(do_seq_formals);
tmp = do_seq_formals;
SET_TAG(tmp, install("from")); tmp = CDR(tmp);
SET_TAG(tmp, install("to")); tmp = CDR(tmp);
SET_TAG(tmp, install("by")); tmp = CDR(tmp);
SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_DotsSymbol);
}
PROTECT(args = matchArgs(do_seq_formals, args, call));
from = CAR(args); args = CDR(args);
to = CAR(args); args = CDR(args);
by = CAR(args); args = CDR(args);
len = CAR(args); args = CDR(args);
along = CAR(args);
if(One && from != R_MissingArg) {
lf = length(from);
if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
double rfrom = asReal(from);
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
ans = seq_colon(1.0, rfrom, call);
}
else if (lf)
ans = seq_colon(1.0, (double)lf, call);
else
ans = allocVector(INTSXP, 0);
goto done;
}
if(along != R_MissingArg) {
lout = XLENGTH(along);
if(One) {
ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
goto done;
}
} else if(len != R_MissingArg && len != R_NilValue) {
double rout = asReal(len);
if(ISNAN(rout) || rout <= -0.5)
errorcall(call, _("'length.out' must be a non-negative number"));
if(length(len) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
lout = (R_xlen_t) ceil(rout);
}
if(lout == NA_INTEGER) {
double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
if(from == R_MissingArg) rfrom = 1.0;
else if(length(from) != 1) error("'from' must be of length 1");
if(to == R_MissingArg) rto = 1.0;
else if(length(to) != 1) error("'to' must be of length 1");
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
if (!R_FINITE(rto))
errorcall(call, "'to' cannot be NA, NaN or infinite");
if(by == R_MissingArg)
ans = seq_colon(rfrom, rto, call);
else {
if(length(by) != 1) error("'by' must be of length 1");
double del = rto - rfrom, n, dd;
R_xlen_t nn;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(del == 0.0 && rto == 0.0) {
ans = to;
goto done;
}
/* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
n = del/rby;
if(!R_FINITE(n)) {
if(del == 0.0 && rby == 0.0) {
ans = from;
goto done;
} else
errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
}
dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
if(dd < 100 * DBL_EPSILON) {
ans = from;
goto done;
}
#ifdef LONG_VECTOR_SUPPORT
if(n > 100 * (double) INT_MAX)
#else
if(n > (double) INT_MAX)
#endif
errorcall(call, _("'by' argument is much too small"));
if(n < - FEPS)
errorcall(call, _("wrong sign in 'by' argument"));
if(TYPEOF(from) == INTSXP &&
TYPEOF(to) == INTSXP &&
TYPEOF(by) == INTSXP) {
int *ia, ifrom = asInteger(from), iby = asInteger(by);
/* With the current limits on integers and FEPS
reduced below 1/INT_MAX this is the same as the
next, so this is future-proofing against longer integers.
*/
/* seq.default gives integer result from
from + (0:n)*by
*/
nn = (R_xlen_t) n;
ans = allocVector(INTSXP, nn+1);
ia = INTEGER(ans);
for(i = 0; i <= nn; i++)
ia[i] = (int)(ifrom + i * iby);
} else {
nn = (int)(n + FEPS);
ans = allocVector(REALSXP, nn+1);
ra = REAL(ans);
for(i = 0; i <= nn; i++)
ra[i] = rfrom + (double)i * rby;
/* Added in 2.9.0 */
if (nn > 0)
if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
ra[nn] = rto;
}
}
} else if (lout == 0) {
ans = allocVector(INTSXP, 0);
} else if (One) {
ans = seq_colon(1.0, (double)lout, call);
} else if (by == R_MissingArg) {
double rfrom = asReal(from), rto = asReal(to), rby;
if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
ans = allocVector(REALSXP, lout);
if(lout > 0) REAL(ans)[0] = rfrom;
if(lout > 1) REAL(ans)[lout - 1] = rto;
if(lout > 2) {
rby = (rto - rfrom)/(double)(lout - 1);
for(i = 1; i < lout-1; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (to == R_MissingArg) {
double rfrom = asReal(from), rby = asReal(by), rto;
if(from == R_MissingArg) rfrom = 1.0;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
rto = rfrom + (double)(lout-1)*rby;
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (from == R_MissingArg) {
double rto = asReal(to), rby = asReal(by),
rfrom = rto - (double)(lout-1)*rby;
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
}
}
} else
errorcall(call, _("too many arguments"));
done:
UNPROTECT(1);
return ans;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
/* GetNativeSystemInfo is XP or later */
pGNSI = (PGNSI)
GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
"GetNativeSystemInfo");
if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
strcat(ver, " x64");
}
SET_STRING_ELT(ans, 1, mkChar(ver));
if((int)osvi.dwMajorVersion >= 5) {
if(osvi.wServicePackMajor > 0)
snprintf(ver, 256, "build %d, Service Pack %d",
LOWORD(osvi.dwBuildNumber),
(int) osvi.wServicePackMajor);
else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
} else
snprintf(ver, 256, "build %d, %s",
LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
SET_STRING_ELT(ans, 2, mkChar(ver));
GetComputerNameW(name, &namelen);
wcstoutf8(buf, name, 1000);
SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef WIN64
SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
GetUserNameW(user, &userlen);
wcstoutf8(buf, user, 1000);
SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
PROTECT(ansnames = allocVector(STRSXP, 8));
SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
SET_STRING_ELT(ansnames, 1, mkChar("release"));
SET_STRING_ELT(ansnames, 2, mkChar("version"));
SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
SET_STRING_ELT(ansnames, 4, mkChar("machine"));
SET_STRING_ELT(ansnames, 5, mkChar("login"));
SET_STRING_ELT(ansnames, 6, mkChar("user"));
SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(2);
return ans;
}
SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
DWORD mtime;
int ntime;
double time;
checkArity(op, args);
time = asReal(CAR(args));
if (ISNAN(time) || time < 0)
errorcall(call, _("invalid '%s' value"), "time");
ntime = 1000*(time) + 0.5;
while (ntime > 0) {
mtime = min(500, ntime);
ntime -= mtime;
Sleep(mtime);
R_ProcessEvents();
}
return R_NilValue;
}
#ifdef LEA_MALLOC
#define MALLINFO_FIELD_TYPE size_t
struct mallinfo {
MALLINFO_FIELD_TYPE arena; /* non-mmapped space allocated from system */
MALLINFO_FIELD_TYPE ordblks; /* number of free chunks */
MALLINFO_FIELD_TYPE smblks; /* number of fastbin blocks */
MALLINFO_FIELD_TYPE hblks; /* number of mmapped regions */
MALLINFO_FIELD_TYPE hblkhd; /* space in mmapped regions */
MALLINFO_FIELD_TYPE usmblks; /* maximum total allocated space */
MALLINFO_FIELD_TYPE fsmblks; /* space available in freed fastbin blocks */
MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
MALLINFO_FIELD_TYPE fordblks; /* total free space */
MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
};
extern R_size_t R_max_memory;
struct mallinfo mallinfo(void);
#endif
SEXP in_memsize(SEXP ssize)
{
SEXP ans;
int maxmem = NA_LOGICAL;
if(isLogical(ssize))
maxmem = asLogical(ssize);
else if(isReal(ssize)) {
R_size_t newmax;
double mem = asReal(ssize);
if (!R_FINITE(mem))
error(_("incorrect argument"));
#ifdef LEA_MALLOC
#ifndef WIN64
if(mem >= 4096)
error(_("don't be silly!: your machine has a 4Gb address limit"));
#endif
newmax = mem * 1048576.0;
if (newmax < R_max_memory)
warning(_("cannot decrease memory limit: ignored"));
else
R_max_memory = newmax;
#endif
} else
error(_("incorrect argument"));
PROTECT(ans = allocVector(REALSXP, 1));
#ifdef LEA_MALLOC
if(maxmem == NA_LOGICAL)
REAL(ans)[0] = R_max_memory;
else if(maxmem)
REAL(ans)[0] = mallinfo().usmblks;
else
REAL(ans)[0] = mallinfo().uordblks;
REAL(ans)[0] /= 1048576.0;
#else
REAL(ans)[0] = NA_REAL;
#endif
UNPROTECT(1);
return ans;
}
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP path = R_NilValue, ans;
const wchar_t *dll;
DWORD dwVerInfoSize;
DWORD dwVerHnd;
checkArity(op, args);
path = CAR(args);
if(!isString(path) || LENGTH(path) != 1)
errorcall(call, _("invalid '%s' argument"), "path");
dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
PROTECT(ans = allocVector(STRSXP, 2));
SET_STRING_ELT(ans, 0, mkChar(""));
SET_STRING_ELT(ans, 1, mkChar(""));
if (dwVerInfoSize) {
BOOL fRet;
LPSTR lpstrVffInfo;
LPSTR lszVer = NULL;
UINT cchVer = 0;
lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
else {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
}
} else ans = R_NilValue;
free(lpstrVffInfo);
} else ans = R_NilValue;
UNPROTECT(1);
return ans;
}
int Rwin_rename(const char *from, const char *to)
{
return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
{
return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
const char *formatError(DWORD res)
{
static char buf[1000], *p;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, res,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
buf, 1000, NULL);
p = buf+strlen(buf) -1;
if(*p == '\n') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '\r') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '.') *p = '\0';
return buf;
}
void R_UTF8fixslash(char *s); /* from main/util.c */
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, paths = CAR(args), el, slash;
int i, n = LENGTH(paths), res;
char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2;
wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
int mustWork, fslash = 0;
checkArity(op, args);
if(!isString(paths))
errorcall(call, _("'path' must be a character vector"));
slash = CADR(args);
if(!isString(slash) || LENGTH(slash) != 1)
errorcall(call, "'winslash' must be a character string");
const char *sl = CHAR(STRING_ELT(slash, 0));
if (strcmp(sl, "/") && strcmp(sl, "\\"))
errorcall(call, "'winslash' must be '/' or '\\\\'");
if (strcmp(sl, "/") == 0) fslash = 1;
mustWork = asLogical(CADDR(args));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
int warn = 0;
SEXP result;
el = STRING_ELT(paths, i);
result = el;
if(getCharCE(el) == CE_UTF8) {
if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768,
wtmp, &wtmp2)) && res <= 32768) {
if ((res = GetLongPathNameW(wtmp, wlongpath, 32768))
&& res <= 32768) {
wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1);
if(fslash) R_UTF8fixslash(longpath);
result = mkCharCE(longpath, CE_UTF8);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
if(fslash) R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateCharUTF8(el));
R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%ls\": %s", i+1,
filenameToWchar(el,FALSE),
formatError(GetLastError()));
} else {
if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2))
&& res <= MAX_PATH) {
if ((res = GetLongPathName(tmp, longpath, MAX_PATH))
&& res <= MAX_PATH) {
if(fslash) R_fixslash(longpath);
result = mkChar(longpath);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if(fslash) R_fixslash(tmp);
result = mkChar(tmp);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateChar(el));
R_fixslash(tmp);
result = mkChar(tmp);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
}
SET_STRING_ELT(ans, i, result);
}
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call)
{
int i, seendots, arg_i = 0;
SEXP f, a, b, dots, actuals;
actuals = R_NilValue;
for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) {
/* CONS_NR is used since argument lists created here are only
used internally and so should not increment reference
counts */
actuals = CONS_NR(R_MissingArg, actuals);
SET_MISSING(actuals, 1);
}
/* We use fargused instead of ARGUSED/SET_ARGUSED on elements of
formals to avoid modification of the formals SEXPs. A gc can
cause matchArgs to be called from finalizer code, resulting in
another matchArgs call with the same formals. In R-2.10.x, this
corrupted the ARGUSED data of the formals and resulted in an
incorrect "formal argument 'foo' matched by multiple actual
arguments" error.
*/
int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour
memset(fargused, 0, sizeof(fargused));
for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0);
PROTECT(actuals);
/* First pass: exact matches by tag */
/* Grab matched arguments and check */
/* for multiple exact matches. */
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (TAG(f) != R_DotsSymbol) {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) {
if (fargused[arg_i] == 2)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (ARGUSED(b) == 2)
error(_("argument %d matches multiple formal arguments"), i);
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 2);
fargused[arg_i] = 2;
}
i++;
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Second pass: partial matches based on tags */
/* An exact match is required after first ... */
/* The location of the first ... is saved in "dots" */
dots = R_NilValue;
seendots = 0;
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (fargused[arg_i] == 0) {
if (TAG(f) == R_DotsSymbol && !seendots) {
/* Record where ... value goes */
dots = a;
seendots = 1;
} else {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (ARGUSED(b) != 2 && TAG(b) != R_NilValue &&
pmatch(TAG(f), TAG(b), seendots)) {
if (ARGUSED(b))
error(_("argument %d matches multiple formal arguments"), i);
if (fargused[arg_i] == 1)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (R_warn_partial_match_args) {
warningcall(call,
_("partial argument match of '%s' to '%s'"),
CHAR(PRINTNAME(TAG(b))),
CHAR(PRINTNAME(TAG(f))) );
}
SETCAR(a, CAR(b));
if (CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
fargused[arg_i] = 1;
}
i++;
}
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Third pass: matches based on order */
/* All args specified in tag=value form */
/* have now been matched. If we find ... */
/* we gobble up all the remaining args. */
/* Otherwise we bind untagged values in */
/* order to any unmatched formals. */
f = formals;
a = actuals;
b = supplied;
seendots = 0;
while (f != R_NilValue && b != R_NilValue && !seendots) {
if (TAG(f) == R_DotsSymbol) {
/* Skip ... matching until all tags done */
seendots = 1;
f = CDR(f);
a = CDR(a);
} else if (CAR(a) != R_MissingArg) {
/* Already matched by tag */
/* skip to next formal */
f = CDR(f);
a = CDR(a);
} else if (ARGUSED(b) || TAG(b) != R_NilValue) {
/* This value used or tagged , skip to next value */
/* The second test above is needed because we */
/* shouldn't consider tagged values for positional */
/* matches. */
/* The formal being considered remains the same */
b = CDR(b);
} else {
/* We have a positional match */
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
b = CDR(b);
f = CDR(f);
a = CDR(a);
}
}
if (dots != R_NilValue) {
/* Gobble up all unused actuals */
SET_MISSING(dots, 0);
i = 0;
for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++;
if (i) {
a = allocList(i);
SET_TYPEOF(a, DOTSXP);
f = a;
for(b = supplied; b != R_NilValue; b = CDR(b))
if(!ARGUSED(b)) {
SETCAR(f, CAR(b));
SET_TAG(f, TAG(b));
f = CDR(f);
}
SETCAR(dots, a);
}
} else {
/* Check that all arguments are used */
SEXP unused = R_NilValue, last = R_NilValue;
for (b = supplied; b != R_NilValue; b = CDR(b))
if (!ARGUSED(b)) {
if(last == R_NilValue) {
PROTECT(unused = CONS(CAR(b), R_NilValue));
SET_TAG(unused, TAG(b));
last = unused;
} else {
SETCDR(last, CONS(CAR(b), R_NilValue));
last = CDR(last);
SET_TAG(last, TAG(b));
}
}
if(last != R_NilValue) {
/* show bad arguments in call without evaluating them */
SEXP unusedForError = R_NilValue, last = R_NilValue;
for(b = unused ; b != R_NilValue ; b = CDR(b)) {
SEXP tagB = TAG(b), carB = CAR(b) ;
if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ;
if (last == R_NilValue) {
PROTECT(last = CONS(carB, R_NilValue));
SET_TAG(last, tagB);
unusedForError = last;
} else {
SETCDR(last, CONS(carB, R_NilValue));
last = CDR(last);
SET_TAG(last, tagB);
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
}
}
UNPROTECT(1);
return(actuals);
}
