SEXP attribute_hidden do_relop(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
if (DispatchGroup("Ops", call, op, args, env, &ans))
return ans;
checkArity(op, args);
return do_relop_dflt(call, op, CAR(args), CADR(args));
}
SEXP do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP prompt, onMouseDown, onMouseMove, onMouseUp, onKeybd;
GEDevDesc *dd;
NewDevDesc *nd;
checkArity(op, args);
dd = GEcurrentDevice();
nd = dd->dev;
if (!nd->newDevStruct || !nd->getEvent)
errorcall(call, _("graphics device does not support graphics events"));
prompt = CAR(args);
if (!isString(prompt)) errorcall(call, _("invalid prompt"));
args = CDR(args);
onMouseDown = CAR(args);
if (TYPEOF(onMouseDown) == NILSXP) onMouseDown = NULL;
else if (!nd->canGenMouseDown)
errorcall(call, _("'onMouseDown' not supported"));
else if (TYPEOF(onMouseDown) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseDown' callback"));
args = CDR(args);
onMouseMove = CAR(args);
if (TYPEOF(onMouseMove) == NILSXP) onMouseMove = NULL;
else if (!nd->canGenMouseMove)
errorcall(call, _("'onMouseMove' not supported"));
else if (TYPEOF(onMouseMove) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseMove' callback"));
args = CDR(args);
onMouseUp = CAR(args);
if (TYPEOF(onMouseUp) == NILSXP) onMouseUp = NULL;
else if (!nd->canGenMouseUp)
errorcall(call, _("'onMouseUp' not supported"));
else if (TYPEOF(onMouseUp) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onMouseUp' callback"));
args = CDR(args);
onKeybd = CAR(args);
if (TYPEOF(onKeybd) == NILSXP) onKeybd = NULL;
else if (!nd->canGenKeybd)
errorcall(call, _("'onKeybd' not supported"));
else if (TYPEOF(onKeybd) != CLOSXP ||
TYPEOF(onMouseDown) != RCC_CLOSXP)
errorcall(call, _("invalid 'onKeybd' callback"));
/* NB: cleanup of event handlers must be done by driver in onExit handler */
return(nd->getEvent(env, CHAR(STRING_ELT(prompt,0))));
}
/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret, n;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
/* if x has names, drop them, since they won't be ordered
if (!isNull(getAttrib(sx, R_NamesSymbol)))
setAttrib(sx, R_NamesSymbol, R_NilValue); */
indx_ret = asLogical(CADR(args));
n = LENGTH(x);
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
int i, *ix;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
PROTECT(indx = allocVector(INTSXP, n));
ix = INTEGER(indx);
for(i = 0; i < n; i++)
ix[i] = i+1;
if(x_int)
R_qsort_int_I(ivx, ix, 1, n);
else
R_qsort_I(vx, ix, 1, n);
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
}
else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
SEXP attribute_hidden
do_getNumRtoCConverters(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans;
checkArity(op, args);
ans = allocVector(INTSXP, 1);
INTEGER(ans)[0] = Rf_getNumRtoCConverters();
return(ans);
}
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 do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, t, ans;
int i;
checkArity(op, args);
if (DispatchGroup("Math", call, op, args, env, &ans))
return ans;
if (isComplex(CAR(args))) {
t = CAR(args);
s = allocVector(CPLXSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for (i = 0 ; i < length(t) ; i++) {
COMPLEX(s)[i].r = NA_REAL;
COMPLEX(s)[i].i = NA_REAL;
}
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return ccumsum(t, s);
break;
case 2: /* cumprod */
return ccumprod(t, s);
break;
case 3: /* cummax */
case 4: /* cummin */
errorcall(call, _("min/max not defined for complex numbers"));
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
else { /* Non-Complex: here, (sh|c)ould differentiate real / int */
PROTECT(t = coerceVector(CAR(args), REALSXP));
s = allocVector(REALSXP, LENGTH(t));
setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
for(i = 0 ; i < length(t) ; i++)
REAL(s)[i] = NA_REAL;
UNPROTECT(1);
switch (PRIMVAL(op) ) {
case 1: /* cumsum */
return cumsum(t,s);
break;
case 2: /* cumprod */
return cumprod(t,s);
break;
case 3: /* cummax */
return cummax(t,s);
break;
case 4: /* cummin */
return cummin(t,s);
break;
default:
errorcall(call, _("unknown cumxxx function"));
}
}
return R_NilValue; /* for -Wall */
}
/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP in = CAR(args), out = CADR(args);
SET_ATTRIB(out, ATTRIB(in));
IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
SET_OBJECT(out, OBJECT(in));
return out;
}
SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if (isFactor(CAR(args)) && isFactor(CADR(args))) {
if (length(CAR(args)) != length(CADR(args)))
errorcall(call, _("unequal factor lengths"));
return(cross(CAR(args), CADR(args)));
}
return seq(call, CAR(args), CADR(args));
}
/* This is a special .Internal, so has unevaluated arguments. It is
called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names, X, XX, FUN;
R_xlen_t i, n;
PROTECT_INDEX px;
checkArity(op, args);
PROTECT_WITH_INDEX(X = CAR(args), &px);
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(XX, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
tmp = eval(R_fcall, rho);
if (NAMED(tmp))
tmp = duplicate(tmp);
SET_VECTOR_ELT(ans, i, tmp);
}
UNPROTECT(3);
}
UNPROTECT(3); /* X, XX, ans */
return ans;
}
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP s = CAR(args), ncopy = CADR(args);
R_xlen_t nc;
SEXP a;
if (!isVector(ncopy))
error(_("incorrect type for second argument"));
if (!isVector(s) && s != R_NilValue)
error(_("attempt to replicate an object of type '%s'"),
type2char(TYPEOF(s)));
nc = xlength(ncopy); // might be 0
if (nc == xlength(s))
PROTECT(a = rep2(s, ncopy));
else {
if (nc != 1) error(_("invalid '%s' value"), "times");
#ifdef LONG_VECTOR_SUPPORT
double snc = asReal(ncopy);
if (!R_FINITE(snc) || snc < 0)
error(_("invalid '%s' value"), "times");
nc = (R_xlen_t) snc;
#else
if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
error(_("invalid '%s' value"), "times");
#endif
R_xlen_t ns = xlength(s);
PROTECT(a = rep3(s, ns, nc * ns));
}
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
setAttrib(a, R_ClassSymbol, getClassAttrib(s));
SET_S4_OBJECT(a);
}
#endif
if (inheritsCharSXP(s, R_FactorCharSXP)) {
SEXP tmp;
if(inheritsCharSXP(s, R_OrderedCharSXP)) {
PROTECT(tmp = allocVector(STRSXP, 2));
SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
} else PROTECT(tmp = mkString("factor"));
setAttrib(a, R_ClassSymbol, tmp);
UNPROTECT(1);
setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
}
UNPROTECT(1);
return a;
}
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP file;
checkArity(op, args);
file = CAR(args);
if (!isString(file) || length(file) != 1)
errorcall(call, _("invalid '%s' argument"), "file");
internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
return R_NilValue;
}
SEXP attribute_hidden do_curlDownload(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if(!initialized) internet_Init();
if(initialized > 0)
return (*ptr->curlDownload)(call, op, args, rho);
else {
error(_("internet routines cannot be loaded"));
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_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 do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho)
{
switch (length(args)) {
case 0:
return R_NilValue;
case 1:
return CAR(args);
default:
checkArity(op, args);
return call;/* never used, just for -Wall */
}
}
SEXP attribute_hidden do_dynunload(SEXP call, SEXP op, SEXP args, SEXP env)
{
char buf[2 * PATH_MAX];
checkArity(op,args);
if (!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("character argument expected"));
GetFullDLLPath(call, buf, translateChar(STRING_ELT(CAR(args), 0)));
if(!DeleteDLL(buf))
error(_("shared object '%s\' was not loaded"), buf);
return R_NilValue;
}
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) );
}
SEXP attribute_hidden do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, el;
R_xlen_t i, len;
int start, stop, k, l;
size_t slen;
cetype_t ienc;
const char *ss;
char *buf;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("extracting substrings from a non-character object"));
len = XLENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
for (i = 0; i < len; i++) {
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
el = STRING_ELT(x,i);
if (el == NA_STRING || start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss); /* FIXME -- should handle embedded nuls */
buf = R_AllocStringBuffer(slen+1, &cbuff);
if (start < 1) start = 1;
if (start > stop || start > slen) {
buf[0] = '\0';
} else {
if (stop > slen) stop = (int) slen;
substr(buf, ss, ienc, start, stop);
}
SET_STRING_ELT(s, i, mkCharCE(buf, ienc));
}
R_FreeStringBufferL(&cbuff);
}
DUPLICATE_ATTRIB(s, x);
/* This copied the class, if any */
UNPROTECT(1);
return s;
}
SEXP attribute_hidden do_mvfft(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP z, d;
int i, inv, maxf, maxp, n, p;
double *work;
int *iwork;
checkArity(op, args);
z = CAR(args);
d = getAttrib(z, R_DimSymbol);
if (d == R_NilValue || length(d) > 2)
error(_("vector-valued (multivariate) series required"));
n = INTEGER(d)[0];
p = INTEGER(d)[1];
switch(TYPEOF(z)) {
case INTSXP:
case LGLSXP:
case REALSXP:
z = coerceVector(z, CPLXSXP);
break;
case CPLXSXP:
if (NAMED(z)) z = duplicate(z);
break;
default:
error(_("non-numeric argument"));
}
PROTECT(z);
/* -2 for forward transform, complex values */
/* +2 for backward transform, complex values */
inv = asLogical(CADR(args));
if (inv == NA_INTEGER || inv == 0) inv = -2;
else inv = 2;
if (n > 1) {
fft_factor(n, &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
work = (double*)R_alloc(4 * maxf, sizeof(double));
iwork = (int*)R_alloc(maxp, sizeof(int));
for (i = 0; i < p; i++) {
fft_factor(n, &maxf, &maxp);
fft_work(&(COMPLEX(z)[i*n].r), &(COMPLEX(z)[i*n].i),
1, n, 1, inv, work, iwork);
}
}
UNPROTECT(1);
return z;
}
/* oldClass, primitive */
SEXP attribute_hidden do_class(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
SEXP x = CAR(args), s3class;
if(IS_S4_OBJECT(x)) {
if((s3class = S3Class(x)) != R_NilValue) {
return s3class;
}
} /* else */
return getAttrib(x, R_ClassSymbol);
}
static VALUE
rbffi_InvokeVrL(int argc, VALUE* argv, void* function, FunctionType* fnInfo)
{
L (*fn)(void) = (L (*)(void)) function;
L result;
checkArity(argc, 0);
result = (*fn)();
return returnL(fnInfo, &result);
}
SEXP do_hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, h, s, v, gm, a;
double hh, ss, vv, gg, aa, r, g, b;
int i, max, nh, ns, nv, ng, na;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(s = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(v = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(gm = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
nh = LENGTH(h);
ns = LENGTH(s);
nv = LENGTH(v);
ng = LENGTH(gm);
na = LENGTH(a);
if (nh <= 0 || ns <= 0 || nv <= 0 || ng <= 0 || na <= 0) {
UNPROTECT(5);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < ns) max = ns;
if (max < nv) max = nv;
if (max < ng) max = ng;
if (max < na) max = na;
PROTECT(c = allocVector(STRSXP, max));
if(max == 0) return(c);
for (i = 0; i < max; i++) {
hh = REAL(h)[i % nh];
ss = REAL(s)[i % ns];
vv = REAL(v)[i % nv];
gg = REAL(gm)[i % ng];
aa = REAL(a)[i % na];
if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
aa < 0 || aa > 1)
errorcall(call, _("invalid HSV color"));
hsv2rgb(hh, ss, vv, &r, &g, &b);
r = pow(r, gg);
g = pow(g, gg);
b = pow(b, gg);
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r),
ScaleColor(g),
ScaleColor(b),
ScaleAlpha(aa))));
}
UNPROTECT(6);
return c;
}
SEXP attribute_hidden do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho)
{
switch (length(args)) {
case 0:
return R_NilValue;
case 1:
check1arg(args, call, "x");
return CAR(args);
default:
checkArity(op, args); /* must fail */
return call;/* never used, just for -Wall */
}
}
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
if(IS_S4_OBJECT(CAR(args)))
UNSET_S4_OBJECT(CAR(args));
setAttrib(CAR(args), R_ClassSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
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 do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
int read=0, i, j;
SEXP tlist = R_NilValue, tchar, rval;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
errorcall(call, _("non-empty character argument expected"));
if (isLogical(CADR(args)))
read = INTEGER(CADR(args))[0];
if (read) {
#ifdef HAVE_POPEN
PROTECT(tlist);
fp = R_popen(CHAR(STRING_ELT(CAR(args), 0)), x);
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
read = strlen(buf);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
pclose(fp);
rval = allocVector(STRSXP, i);;
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
UNPROTECT(1);
return (rval);
#else /* not HAVE_POPEN */
errorcall(call, _("intern=TRUE is not implemented on this platform"));
return R_NilValue;
#endif /* not HAVE_POPEN */
}
else {
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = allocVector(INTSXP, 1);
fflush(stdout);
INTEGER(tlist)[0] = R_system(CHAR(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
R_Visible = 0;
return tlist;
}
}
SEXP attribute_hidden do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ansnames;
struct utsname name;
char *login;
checkArity(op, args);
PROTECT(ans = allocVector(STRSXP, 8));
if(uname(&name) == -1) {
UNPROTECT(1);
return R_NilValue;
}
SET_STRING_ELT(ans, 0, mkChar(name.sysname));
SET_STRING_ELT(ans, 1, mkChar(name.release));
SET_STRING_ELT(ans, 2, mkChar(name.version));
SET_STRING_ELT(ans, 3, mkChar(name.nodename));
SET_STRING_ELT(ans, 4, mkChar(name.machine));
login = getlogin();
SET_STRING_ELT(ans, 5, login ? mkChar(login) : mkChar("unknown"));
#if defined(HAVE_PWD_H) && defined(HAVE_GETPWUID) && defined(HAVE_GETUID)
{
struct passwd *stpwd;
stpwd = getpwuid(getuid());
SET_STRING_ELT(ans, 6, stpwd ? mkChar(stpwd->pw_name) : mkChar("unknown"));
}
#else
SET_STRING_ELT(ans, 6, mkChar("unknown"));
#endif
#if defined(HAVE_PWD_H) && defined(HAVE_GETPWUID) && defined(HAVE_GETEUID)
{
struct passwd *stpwd;
stpwd = getpwuid(geteuid());
SET_STRING_ELT(ans, 7, stpwd ? mkChar(stpwd->pw_name) : mkChar("unknown"));
}
#else
SET_STRING_ELT(ans, 7, mkChar("unknown"));
#endif
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;
}
static bool
checkArgs(int argc, VALUE* argv, FunctionType* fnInfo)
{
int i;
checkArity(argc, fnInfo->parameterCount);
for (i = 0; i < fnInfo->parameterCount; ++i) {
if (unlikely(!isLongValue(argv[i]))) {
return false;
}
}
return true;
}
SEXP attribute_hidden do_seq_along(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_xlen_t len;
static SEXP length_op = NULL;
/* Store the .Primitive for 'length' for DispatchOrEval to use. */
if (length_op == NULL) {
SEXP R_lengthSymbol = install("length");
length_op = eval(R_lengthSymbol, R_BaseEnv);
if (TYPEOF(length_op) != BUILTINSXP) {
length_op = NULL;
error("'length' is not a BUILTIN");
}
R_PreserveObject(length_op);
}
checkArity(op, args);
check1argSymbol(args, call, R_AlongWithSymbol);
/* Try to dispatch to S3 or S4 methods for 'length'. For cases
where no methods are defined this is more efficient than an
unconditional callback to R */
if (isObject(CAR(args)) &&
DispatchOrEval(call, length_op, R_LengthCharSXP, args, rho, &ans, 0, 1)) {
len = asInteger(ans);
}
else
len = xlength(CAR(args));
#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 do_hcl(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP h, c, l, a, ans;
double H, C, L, A, r, g, b;
int nh, nc, nl, na, max, i;
int ir, ig, ib;
int fixup;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(c = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(l = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
fixup = asLogical(CAR(args));
nh = LENGTH(h);
nc = LENGTH(c);
nl = LENGTH(l);
na = LENGTH(a);
if (nh <= 0 || nc <= 0 || nl <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < nc) max = nc;
if (max < nl) max = nl;
if (max < na) max = na;
PROTECT(ans = allocVector(STRSXP, max));
for (i = 0; i < max; i++) {
H = REAL(h)[i % nh];
C = REAL(c)[i % nc];
L = REAL(l)[i % nl];
A = REAL(a)[i % na];
if (!finite(A)) A = 1;
if (L < 0 || L > WHITE_Y || C < 0 || A < 0 || A > 1)
errorcall(call, _("invalid hcl color"));
hcl2rgb(H, C, L, &r, &g, &b);
ir = 255 * r + .5;
ig = 255 * g + .5;
ib = 255 * b + .5;
if (FixupColor(&ir, &ig, &ib) && !fixup)
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkChar(RGBA2rgb(ir, ig, ib,
ScaleAlpha(A))));
}
UNPROTECT(5);
return ans;
}
SEXP attribute_hidden do_traceOnOff(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
SEXP onOff = CAR(args);
Rboolean prev = GET_TRACE_STATE;
if(length(onOff) > 0) {
Rboolean _new = asLogical(onOff);
if(_new == TRUE || _new == FALSE)
SET_TRACE_STATE(_new);
else
error("Value for tracingState must be TRUE or FALSE");
}
return ScalarLogical(prev);
}
