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