SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object;
char buffer[21];
checkArity(op, args);
check1arg(args, call, "x");
object = CAR(args);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
if(object == R_NilValue)
errorcall(call, _("cannot trace NULL"));
if(TYPEOF(object) == ENVSXP || TYPEOF(object) == PROMSXP)
errorcall(call,
_("'tracemem' is not useful for promise and environment objects"));
if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP)
errorcall(call,
_("'tracemem' is not useful for weak reference or external pointer objects"));
SET_RTRACE(object, 1);
snprintf(buffer, 21, "<%p>", (void *) object);
return mkString(buffer);
#else
errorcall(call, _("R was not compiled with support for memory profiling"));
return R_NilValue;
#endif
}
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;
}
/* 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);
}
/* 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_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 */
}
}
SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP object;
checkArity(op, args);
check1arg(args, call, "x");
object=CAR(args);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
if (RTRACE(object))
SET_RTRACE(object, 0);
return R_NilValue;
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
int i, len;
checkArity(op, args);
check1arg(args, call, "x");
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
len = LENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object;
checkArity(op, args);
check1arg(args, call, "x");
object=CAR(args);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
if (RTRACE(object))
SET_RTRACE(object, 0);
#else
errorcall(call, _("R was not compiled with support for memory profiling"));
#endif
return R_NilValue;
}
/* primitives .primTrace and .primUntrace */
SEXP attribute_hidden do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
check1arg(args, call, "x");
find_char_fun
if (TYPEOF(CAR(args)) != CLOSXP &&
TYPEOF(CAR(args)) != BUILTINSXP &&
TYPEOF(CAR(args)) != SPECIALSXP)
errorcall(call, _("argument must be a function"));
switch(PRIMVAL(op)) {
case 0:
SET_RTRACE(CAR(args), 1);
break;
case 1:
SET_RTRACE(CAR(args), 0);
break;
}
return R_NilValue;
}
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 (PRIMVAL(op)) { /* xlength<- */
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
return xlengthgets(x, len);
}
if(isObject(x) && DispatchOrEval(call, op, "length<-", args,
rho, &ans, 0, 1))
return(ans);
if (!isVector(x) && !isVectorizable(x))
error(_("invalid argument"));
if (length(CADR(args)) != 1)
error(_("invalid value"));
R_xlen_t len = asVecSize(CADR(args));
if (len < 0) error(_("invalid value"));
if (len > R_LEN_T_MAX) {
#ifdef LONG_VECTOR_SUPPORT
return xlengthgets(x, len);
#else
error(_("vector size specified is too large"));
return x; /* -Wall */
#endif
}
return lengthgets(x, (R_len_t) len);
}
/* primitive */
SEXP attribute_hidden do_nzchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, ans;
int nargs = length(args);
// checkArity(op, args); .Primitive() & may have 1 or 2 args now
if (nargs < 1 || nargs > 2)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 1, 2);
check1arg(args, call, "x");
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nzchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nzchar()");
int keepNA = FALSE; // the default
if(nargs > 1) {
keepNA = asLogical(CADR(args));
if (keepNA == NA_LOGICAL) keepNA = FALSE;
}
R_xlen_t i, len = XLENGTH(x);
PROTECT(ans = allocVector(LGLSXP, len));
if (keepNA)
for (i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
LOGICAL(ans)[i] = (sxi == NA_STRING) ? NA_LOGICAL : LENGTH(sxi) > 0;
}
else
for (i = 0; i < len; i++)
LOGICAL(ans)[i] = LENGTH(STRING_ELT(x, i)) > 0;
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_length(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
check1arg(args, call, "x");
SEXP x = CAR(args), ans;
if (isObject(x) &&
DispatchOrEval(call, op, "length", args, rho, &ans, 0, 1)) {
if (length(ans) == 1 && TYPEOF(ans) == REALSXP) {
double d = REAL(ans)[0];
if (R_FINITE(d) && d >= 0. && d <= INT_MAX && floor(d) == d)
return coerceVector(ans, INTSXP);
}
return(ans);
}
#ifdef LONG_VECTOR_SUPPORT
// or use IS_LONG_VEC
R_xlen_t len = xlength(x);
if (len > INT_MAX) return ScalarReal((double) len);
#endif
return ScalarInteger(length(x));
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
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;
}
SEXP attribute_hidden NORET do_untracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
check1arg(args, call, "x");
errorcall(call, _("R was not compiled with support for memory profiling"));
}
