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 rpy_findFun(SEXP symbol, SEXP rho)
{
SEXP vl;
while (rho != R_EmptyEnv) {
/* This is not really right. Any variable can mask a function */
vl = findVarInFrame3(rho, symbol, TRUE);
if (vl != R_UnboundValue) {
if (TYPEOF(vl) == PROMSXP) {
PROTECT(vl);
vl = eval(vl, rho);
UNPROTECT(1);
}
if (TYPEOF(vl) == CLOSXP || TYPEOF(vl) == BUILTINSXP ||
TYPEOF(vl) == SPECIALSXP)
return (vl);
if (vl == R_MissingArg) {
printf("R_MissingArg in rpy_FindFun.\n");
return R_UnboundValue;
}
}
rho = ENCLOS(rho);
}
return R_UnboundValue;
}
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
right, max, useS4)) */
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, naprint;
int tryS4;
Rboolean callShow = FALSE;
checkArity(op, args);
PrintDefaults();
x = CAR(args); args = CDR(args);
if(!isNull(CAR(args))) {
R_print.digits = asInteger(CAR(args));
if (R_print.digits == NA_INTEGER ||
R_print.digits < R_MIN_DIGITS_OPT ||
R_print.digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
}
args = CDR(args);
R_print.quote = asLogical(CAR(args));
if(R_print.quote == NA_LOGICAL)
error(_("invalid '%s' argument"), "quote");
args = CDR(args);
naprint = CAR(args);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
error(_("invalid 'na.print' specification"));
R_print.na_string = R_print.na_string_noquote = STRING_ELT(naprint, 0);
R_print.na_width = R_print.na_width_noquote =
(int) strlen(CHAR(R_print.na_string));
}
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.gap = asInteger(CAR(args));
if (R_print.gap == NA_INTEGER || R_print.gap < 0)
error(_("'gap' must be non-negative integer"));
}
args = CDR(args);
R_print.right = (Rprt_adj) asLogical(CAR(args)); /* Should this be asInteger()? */
if(R_print.right == NA_LOGICAL)
error(_("invalid '%s' argument"), "right");
args = CDR(args);
if(!isNull(CAR(args))) {
R_print.max = asInteger(CAR(args));
if(R_print.max == NA_INTEGER || R_print.max < 0)
error(_("invalid '%s' argument"), "max");
else if(R_print.max == INT_MAX) R_print.max--; // so we can add
}
args = CDR(args);
R_print.useSource = asLogical(CAR(args));
if(R_print.useSource == NA_LOGICAL)
error(_("invalid '%s' argument"), "useSource");
if(R_print.useSource) R_print.useSource = USESOURCE;
args = CDR(args);
tryS4 = asLogical(CAR(args));
if(tryS4 == NA_LOGICAL)
error(_("invalid 'tryS4' internal argument"));
if(tryS4 && IS_S4_OBJECT(x) && isMethodsDispatchOn())
callShow = TRUE;
if(callShow) {
/* we need to get show from the methods namespace if it is
not visible on the search path. */
SEXP call, showS;
showS = findVar(install("show"), rho);
if(showS == R_UnboundValue) {
SEXP methodsNS = R_FindNamespace(mkString("methods"));
if(methodsNS == R_UnboundValue)
error("missing methods namespace: this should not happen");
PROTECT(methodsNS);
showS = findVarInFrame3(methodsNS, install("show"), TRUE);
UNPROTECT(1);
if(showS == R_UnboundValue)
error("missing show() in methods namespace: this should not happen");
}
PROTECT(call = lang2(showS, x));
eval(call, rho);
UNPROTECT(1);
} else {
CustomPrintValue(x, rho);
}
PrintDefaults(); /* reset, as na.print etc may have been set */
return x;
}/* do_printdefault */
