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 */