/* .Internal(print.default(x, digits, quote, na.print, print.gap,
right, useS4)) */
SEXP do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, naprint;
int tryS4;
Rboolean callShow = FALSE;
checkArity(op, args);
PrintDefaults(rho);
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)
errorcall(call, _("invalid 'digits' argument"));
}
args = CDR(args);
R_print.quote = asLogical(CAR(args));
if(R_print.quote == NA_LOGICAL)
errorcall(call, _("invalid 'quote' argument"));
args = CDR(args);
naprint = CAR(args);
if(!isNull(naprint)) {
if(!isString(naprint) || LENGTH(naprint) < 1)
errorcall(call, _("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 =
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)
errorcall(call, _("'gap' must be non-negative integer"));
}
args = CDR(args);
R_print.right = asLogical(CAR(args));
if(R_print.right == NA_LOGICAL)
errorcall(call, _("invalid 'right' argument"));
args = CDR(args);
tryS4 = asLogical(CAR(args));
if(tryS4 == NA_LOGICAL)
errorcall(call, _("invalid 'tryS4' internal argument"));
if(tryS4 && isObject(x) && isMethodsDispatchOn()) {
SEXP class = getAttrib(x, R_ClassSymbol);
if(length(class) == 1) {
/* internal version of isClass() */
char str[201];
snprintf(str, 200, ".__C__%s", CHAR(STRING_ELT(class, 0)));
if(findVar(install(str), rho) != R_UnboundValue)
callShow = TRUE;
}
}
/* .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 */