src/main/print.c

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2000-2019	The R Core Team.
 *  Copyright (C) 1995-1998	Robert Gentleman and Ross Ihaka.
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 *
 *
 *  print.default()  ->	 do_printdefault (with call tree below)
 *
 *  auto-printing   ->  PrintValueEnv
 *                      -> PrintValueRec
 *                      -> call print() for objects
 *  Note that auto-printing does not call print.default.
 *  PrintValue, R_PV are similar to auto-printing.
 *
 *  do_printdefault
 *	    -> PrintObject (if S4 dispatch needed)
 *	    -> PrintValueRec
 *		-> PrintGenericVector	-> PrintDispatch & PrintValueRec
 *		-> printList		-> PrintDispatch & PrintValueRec
 *		-> printAttributes	-> PrintValueRec  (recursion)
 *		-> PrintSpecial
 *		-> PrintExpression
 *		-> PrintClosure         -> PrintLanguage
 *		-> printVector		>>>>> ./printvector.c
 *		-> printNamedVector	>>>>> ./printvector.c
 *		-> printMatrix		>>>>> ./printarray.c
 *		-> printArray		>>>>> ./printarray.c
 *
 * PrintDispatch
 *	-> PrintObject
 *      -> PrintValueRec
 *
 *  do_prmatrix
 *	-> PrintDefaults
 *	-> printMatrix			>>>>> ./printarray.c
 *
 *
 *  See ./printutils.c	 for general remarks on Printing
 *			 and the EncodeString() and all Encode*() utils,
 *
 *  Also ./printvector.c,  ./printarray.c
 *
 *  do_sink moved to connections.c as of 1.3.0
 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#define R_USE_SIGNALS 1
#include "Defn.h"
#include <Internal.h>
#include "Print.h"
#include "Fileio.h"
#include "Rconnections.h"
#include <R_ext/RS.h>

/* Global print parameter struct: */
R_PrintData R_print;

static void printAttributes(SEXP, R_PrintData *, Rboolean);
static void PrintObject(SEXP, R_PrintData *);


#define TAGBUFLEN 256
#define TAGBUFLEN0 TAGBUFLEN + 6
static char tagbuf[TAGBUFLEN0 * 2]; /* over-allocate to allow overflow check */

void PrintInit(R_PrintData *data, SEXP env)
{
    data->na_string = NA_STRING;
    data->na_string_noquote = mkChar("<NA>");
    data->na_width = (int) strlen(CHAR(data->na_string));
    data->na_width_noquote = (int) strlen(CHAR(data->na_string_noquote));
    data->quote = 1;
    data->right = Rprt_adj_left;
    data->digits = GetOptionDigits();
    data->scipen = asInteger(GetOption1(install("scipen")));
    if (data->scipen == NA_INTEGER) data->scipen = 0;
    data->max = asInteger(GetOption1(install("max.print")));
    if (data->max == NA_INTEGER || data->max < 0) data->max = 99999;
    else if(data->max == INT_MAX) data->max--; // so we can add
    data->gap = 1;
    data->width = GetOptionWidth();
    data->useSource = USESOURCE;
    data->cutoff = GetOptionCutoff();
    data->env = env;
    data->callArgs = R_NilValue;
}

/* Used in X11 module for dataentry */
/* NB this is called by R.app even though it is in no public header, so
   alter there if you alter this */
void PrintDefaults(void)
{
    PrintInit(&R_print, R_GlobalEnv);
}

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

/* This is *only* called via outdated R_level prmatrix() : */
SEXP attribute_hidden do_prmatrix(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int quote;
    SEXP a, x, rowlab, collab, naprint;
    char *rowname = NULL, *colname = NULL;

    checkArity(op,args);
    PrintDefaults();
    a = args;
    x = CAR(a); a = CDR(a);
    rowlab = CAR(a); a = CDR(a);
    collab = CAR(a); a = CDR(a);

    quote = asInteger(CAR(a)); a = CDR(a);
    R_print.right = (Rprt_adj) asInteger(CAR(a)); a = CDR(a);
    naprint = CAR(a);
    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));
    }

    if (length(rowlab) == 0) rowlab = R_NilValue;
    if (length(collab) == 0) collab = R_NilValue;
    if (!isNull(rowlab) && !isString(rowlab))
	error(_("invalid row labels"));
    if (!isNull(collab) && !isString(collab))
	error(_("invalid column labels"));

    printMatrix(x, 0, getAttrib(x, R_DimSymbol), quote, R_print.right,
		rowlab, collab, rowname, colname);
    PrintDefaults(); /* reset, as na.print.etc may have been set */
    return x;
}/* do_prmatrix */

static void PrintLanguage(SEXP s, R_PrintData *data)
{
    int i;
    SEXP t = getAttrib(s, R_SrcrefSymbol);
    Rboolean useSrc = data->useSource && isInteger(t);
    if (useSrc) {
	PROTECT(t = lang2(R_AsCharacterSymbol, t));
	t = eval(t, R_BaseEnv);
	UNPROTECT(1);
    } else {
	t = deparse1w(s, 0, data->useSource | DEFAULTDEPARSE);
	R_print = *data; /* Deparsing calls PrintDefaults() */
    }
    PROTECT(t);
    for (i = 0; i < LENGTH(t); i++) {
 	Rprintf("%s\n", translateChar(STRING_ELT(t, i))); // translate: for srcref part (PR#16732)
    }
    UNPROTECT(1);
}

static void PrintClosure(SEXP s, R_PrintData *data)
{
    PrintLanguage(s, data);

    if (isByteCode(BODY(s)))
	Rprintf("<bytecode: %p>\n", BODY(s));
    SEXP t = CLOENV(s);
    if (t != R_GlobalEnv)
	Rprintf("%s\n", EncodeEnvironment(t));
}

/* This advances `args` and `prev`. If an argument should not be
   forwarded because it was not explicitly supplied by the user,
   `prev` skips one element. If an argument is found to be
   non-missing, we set `allMissing` to false so we know we cannot use
   show() on S4 objects. */
static void advancePrintArgs(SEXP* args, SEXP* prev,
			     int** missingArg, int* allMissing) {
    *args = CDR(*args);

    if (**missingArg) {
	SETCDR(*prev, *args);
    } else {
	*allMissing = 0;
	*prev = CDR(*prev);
    }

    ++(*missingArg);
}

/* .Internal(print.default(x, args, missings)) */
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);

    SEXP x = CAR(args); args = CDR(args);

    R_PrintData data;
    PrintInit(&data, rho);

    /* These indicate whether an argument should be forwarded */
    int* missingArg = LOGICAL(CADR(args));
    int allMissing = 1;

    /* The remaining arguments are wrapped in another pairlist that
       will be forwarded on recursion */
    args = CAR(args);

    /* Wrap in a parent node to facilitate rechaining */
    SEXP orig = PROTECT(CONS(R_NilValue, args));
    SEXP prev = orig;

    if(!isNull(CAR(args))) {
	data.digits = asInteger(CAR(args));
	if (data.digits == NA_INTEGER ||
	    data.digits < R_MIN_DIGITS_OPT ||
	    data.digits > R_MAX_DIGITS_OPT)
	    error(_("invalid '%s' argument"), "digits");
    }
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    data.quote = asLogical(CAR(args));
    if(data.quote == NA_LOGICAL)
	error(_("invalid '%s' argument"), "quote");
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    SEXP naprint = CAR(args);
    if(!isNull(naprint))  {
	if(!isString(naprint) || LENGTH(naprint) < 1)
	    error(_("invalid 'na.print' specification"));
	data.na_string = data.na_string_noquote = STRING_ELT(naprint, 0);
	data.na_width = data.na_width_noquote =
	    (int) strlen(CHAR(data.na_string));
    }
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    SEXP gap = CAR(args);
    if(!isNull(gap)) {
	data.gap = asInteger(gap);
	if (data.gap == NA_INTEGER || data.gap < 0)
	    error(_("'gap' must be non-negative integer"));
    }
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    data.right = (Rprt_adj) asLogical(CAR(args)); /* Should this be asInteger()? */
    if(data.right == NA_LOGICAL)
	error(_("invalid '%s' argument"), "right");
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    SEXP max = CAR(args);
    if(!isNull(max)) {
	data.max = asInteger(max);
	if(data.max == NA_INTEGER || data.max < 0)
	    error(_("invalid '%s' argument"), "max");
	else if(data.max == INT_MAX) data.max--; // so we can add
    }
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    data.useSource = asLogical(CAR(args));
    if(data.useSource == NA_LOGICAL)
	error(_("invalid '%s' argument"), "useSource");
    if(data.useSource) data.useSource = USESOURCE;
    advancePrintArgs(&args, &prev, &missingArg, &allMissing);

    /* The next arguments are those forwarded in `...`. If all named
       arguments were missing and there are no arguments in `...`, the
       user has not supplied any parameter and we can use show() on S4
       objects */
    int noParams = allMissing && args == R_NilValue;

    data.callArgs = CDR(orig);

    /* Initialise the global R_init as other routines still depend on it */
    R_print = data;

    tagbuf[0] = '\0';
    if (noParams && IS_S4_OBJECT(x) && isMethodsDispatchOn())
	PrintObject(x, &data);
    else
	PrintValueRec(x, &data);

    PrintDefaults(); /* reset, as na.print etc may have been set */

    UNPROTECT(1);
    return x;
}/* do_printdefault */

/*
  NOTE: The S3/S4 versions do not save and restore state like
	PrintObject() does.
*/
static void PrintObjectS4(SEXP s, R_PrintData *data)
{
    /*
      Note that can assume there is a loaded "methods"
      namespace.  It is tempting to cache the value of show in
      the namespace, but the latter could be unloaded and
      reloaded in a session.
    */
    SEXP methodsNS = PROTECT(R_FindNamespace(mkString("methods")));
    if (methodsNS == R_UnboundValue)
	error("missing methods namespace: this should not happen");

    SEXP fun = findVarInFrame3(methodsNS, install("show"), TRUE);
    if (TYPEOF(fun) == PROMSXP) {
	PROTECT(fun);
	fun = eval(fun, R_BaseEnv);
	UNPROTECT(1);
    }
    if (fun == R_UnboundValue)
	error("missing show() in methods namespace: this should not happen");

    SEXP call = PROTECT(lang2(fun, s));

    eval(call, data->env);
    UNPROTECT(2);
}

static void PrintObjectS3(SEXP s, R_PrintData *data)
{
    /*
      Bind value to a variable in a local environment, similar to
      a local({ x <- <value>; print(x) }) call. This avoids
      problems in previous approaches with value duplication and
      evaluating the value, which might be a call object.
    */
    SEXP xsym = install("x");
    SEXP mask = PROTECT(NewEnvironment(R_NilValue, R_NilValue, data->env));
    defineVar(xsym, s, mask);

    /* Forward user-supplied arguments to print() */
    SEXP fun = PROTECT(findFun(install("print"), R_BaseNamespace));
    SEXP args = PROTECT(cons(xsym, data->callArgs));
    SEXP call = PROTECT(lcons(fun, args));

    eval(call, mask);

    defineVar(xsym, R_NilValue, mask); /* To eliminate reference to s */
    UNPROTECT(4); /* mask, fun, args, call */
}

static void PrintObject(SEXP s, R_PrintData *data)
{
    /* Save the tagbuffer to restore indexing tags after evaluation
       because calling into base::print() resets the buffer */
    char save[TAGBUFLEN0];
    strcpy(save, tagbuf);

    if (isMethodsDispatchOn() && IS_S4_OBJECT(s))
	PrintObjectS4(s, data);
    else
	PrintObjectS3(s, data);

    R_print = *data;
    strcpy(tagbuf, save);
}

static void PrintDispatch(SEXP s, R_PrintData *data) {
    if (isObject(s))
	PrintObject(s, data);
    else
	PrintValueRec(s, data);
}

static void PrintGenericVector(SEXP s, R_PrintData *data)
{
    int i, taglen, ns, w, d, e, wr, dr, er, wi, di, ei;
    SEXP dims, t, names, tmp;
    char pbuf[115], *ptag;

    ns = length(s);
    if((dims = getAttrib(s, R_DimSymbol)) != R_NilValue && length(dims) > 1) {
	// special case: array-like list
	PROTECT(dims);
	PROTECT(t = allocArray(STRSXP, dims));
	/* FIXME: check (ns <= data->max +1) ? ns : data->max; */
	for (i = 0; i < ns; i++) {
	    switch(TYPEOF(PROTECT(tmp = VECTOR_ELT(s, i)))) {
	    case NILSXP:
		snprintf(pbuf, 115, "NULL");
		break;
	    case LGLSXP:
		if (LENGTH(tmp) == 1) {
		    const int *x = LOGICAL_RO(tmp);
		    formatLogical(x, 1, &w);
		    snprintf(pbuf, 115, "%s",
			     EncodeLogical(x[0], w));
		} else
		    snprintf(pbuf, 115, "Logical,%d", LENGTH(tmp));
		break;
	    case INTSXP:
		/* factors are stored as integers */
		if (inherits(tmp, "factor")) {
		    snprintf(pbuf, 115, "factor,%d", LENGTH(tmp));
		} else {
		    if (LENGTH(tmp) == 1) {
			const int *x = INTEGER_RO(tmp);
			formatInteger(x, 1, &w);
			snprintf(pbuf, 115, "%s",
				 EncodeInteger(x[0], w));
		    } else
			snprintf(pbuf, 115, "Integer,%d", LENGTH(tmp));
		}
		break;
	    case REALSXP:
		if (LENGTH(tmp) == 1) {
		    const double *x = REAL_RO(tmp);
		    formatReal(x, 1, &w, &d, &e, 0);
		    snprintf(pbuf, 115, "%s",
			     EncodeReal0(x[0], w, d, e, OutDec));
		} else
		    snprintf(pbuf, 115, "Numeric,%d", LENGTH(tmp));
		break;
	    case CPLXSXP:
		if (LENGTH(tmp) == 1) {
		    const Rcomplex *x = COMPLEX_RO(tmp);
		    if (ISNA(x[0].r) || ISNA(x[0].i))
			/* formatReal(NA) --> w=data->na_width, d=0, e=0 */
			snprintf(pbuf, 115, "%s",
				 EncodeReal0(NA_REAL, data->na_width, 0, 0, OutDec));
		    else {
			formatComplex(x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
			snprintf(pbuf, 115, "%s",
				 EncodeComplex(x[0],
					       wr, dr, er, wi, di, ei, OutDec));
		    }
		} else
		snprintf(pbuf, 115, "Complex,%d", LENGTH(tmp));
		break;
	    case STRSXP:
		if (LENGTH(tmp) == 1) {
		    const void *vmax = vmaxget();
		    /* This can potentially overflow */
		    const char *ctmp = translateChar(STRING_ELT(tmp, 0));
		    int len = (int) strlen(ctmp);
		    if(len < 100)
			snprintf(pbuf, 115, "\"%s\"", ctmp);
		    else {
			snprintf(pbuf, 101, "\"%s\"", ctmp);
			pbuf[100] = '"'; pbuf[101] = '\0';
			strcat(pbuf, " [truncated]");
		    }
		    vmaxset(vmax);
		} else
		snprintf(pbuf, 115, "Character,%d", LENGTH(tmp));
		break;
	    case RAWSXP:
		snprintf(pbuf, 115, "Raw,%d", LENGTH(tmp));
		break;
	    case LISTSXP:
	    case VECSXP:
		snprintf(pbuf, 115, "List,%d", length(tmp));
		break;
	    case LANGSXP:
		snprintf(pbuf, 115, "Expression");
		break;
	    default:
		snprintf(pbuf, 115, "?");
		break;
	    }
	    UNPROTECT(1); /* tmp */
	    pbuf[114] = '\0';
	    SET_STRING_ELT(t, i, mkChar(pbuf));
	}
	if (LENGTH(dims) == 2) {
	    SEXP rl, cl;
	    const char *rn, *cn;
	    GetMatrixDimnames(s, &rl, &cl, &rn, &cn);
	    /* as from 1.5.0: don't quote here as didn't in array case */
	    printMatrix(t, 0, dims, 0, data->right, rl, cl,
			rn, cn);
	}
	else {
	    PROTECT(names = GetArrayDimnames(s));
	    printArray(t, dims, 0, Rprt_adj_left, names);
	    UNPROTECT(1);
	}
	UNPROTECT(1);
    }
    else { // no dim()
	PROTECT(names = getAttrib(s, R_NamesSymbol));
	taglen = (int) strlen(tagbuf);
	ptag = tagbuf + taglen;

	if(ns > 0) {
	    int n_pr = (ns <= data->max +1) ? ns : data->max;
	    /* '...max +1'  ==> will omit at least 2 ==> plural in msg below */
	    for (i = 0; i < n_pr; i++) {
		if (i > 0) Rprintf("\n");
		if (names != R_NilValue &&
		    STRING_ELT(names, i) != R_NilValue &&
		    *CHAR(STRING_ELT(names, i)) != '\0') {
		    const void *vmax = vmaxget();
		    /* Bug for L <- list(`a\\b` = 1, `a\\c` = 2)  :
		       const char *ss = translateChar(STRING_ELT(names, i));
		    */
		    const char *ss = EncodeChar(STRING_ELT(names, i));
#ifdef Win32
		    /* FIXME: double translation to native encoding, in
		         EncodeChar and translateChar; it is however necessary
			 to call isValidName() on a string without Rgui
			 escapes, because Rgui escapes cause a name to be
			 regarded invalid;
			 note also differences with printList
		    */
		    const char *st = ss;
		    if (WinUTF8out)
			st = translateChar(STRING_ELT(names, i));
#endif
		    if (taglen + strlen(ss) > TAGBUFLEN) {
			if (taglen <= TAGBUFLEN)
			    sprintf(ptag, "$...");
		    } else {
			/* we need to distinguish character NA from "NA", which
			   is a valid (if non-syntactic) name */
			if (STRING_ELT(names, i) == NA_STRING)
			    sprintf(ptag, "$<NA>");
#ifdef Win32
			else if( isValidName(st) )
#else
			else if( isValidName(ss) )
#endif
			    sprintf(ptag, "$%s", ss);
			else
			    sprintf(ptag, "$`%s`", ss);
		    }
		    vmaxset(vmax);
		}
		else {
		    if (taglen + IndexWidth(i) > TAGBUFLEN) {
			if (taglen <= TAGBUFLEN)
			    sprintf(ptag, "$...");
		    } else
			sprintf(ptag, "[[%d]]", i+1);
		}
                Rprintf("%s\n", tagbuf);
		PrintDispatch(VECTOR_ELT(s, i), data);
                *ptag = '\0';
	    }
	    Rprintf("\n");
	    if(n_pr < ns)
		Rprintf(" [ reached getOption(\"max.print\") -- omitted %d entries ]\n",
			ns - n_pr);
	}
	else { /* ns = length(s) == 0 */
	    const void *vmax = vmaxget();
	    /* Formal classes are represented as empty lists */
	    const char *className = NULL;
	    SEXP klass;
	    if(isObject(s) && isMethodsDispatchOn()) {
		klass = getAttrib(s, R_ClassSymbol);
		if(length(klass) == 1) {
		    /* internal version of isClass() */
		    char str[201];
		    const char *ss = translateChar(STRING_ELT(klass, 0));
		    snprintf(str, 200, ".__C__%s", ss);
		    if(findVar(install(str), data->env) != R_UnboundValue)
			className = ss;
		}
	    }
	    if(className) {
		Rprintf("An object of class \"%s\"\n", className);
		UNPROTECT(1); /* names */
		printAttributes(s, data, TRUE);
		vmaxset(vmax);
		return;
	    }
	    else {
		if(names != R_NilValue) Rprintf("named ");
		Rprintf("list()\n");
	    }
	    vmaxset(vmax);
	}
	UNPROTECT(1); /* names */
    }
    printAttributes(s, data, FALSE);
} // PrintGenericVector


// For pairlist()s only --- the predecessor of PrintGenericVector() above,
// and hence very similar  (and no longer compatible!)
static void printList(SEXP s, R_PrintData *data)
{
    int i, taglen;
    SEXP dims, dimnames, t;
    char pbuf[101], *ptag;
    const char *rn, *cn;

    if ((dims = getAttrib(s, R_DimSymbol)) != R_NilValue && length(dims) > 1) {
	// special case: array-like list
	PROTECT(dims);
	PROTECT(t = allocArray(STRSXP, dims));
	i = 0;
	while(s != R_NilValue) {
	    switch(TYPEOF(CAR(s))) {

	    case NILSXP:
		snprintf(pbuf, 100, "NULL");
		break;

	    case LGLSXP:
		snprintf(pbuf, 100, "Logical,%d", LENGTH(CAR(s)));
		break;

	    case INTSXP:
	    case REALSXP:
		snprintf(pbuf, 100, "Numeric,%d", LENGTH(CAR(s)));
		break;

	    case CPLXSXP:
		snprintf(pbuf, 100, "Complex,%d", LENGTH(CAR(s)));
		break;

	    case STRSXP:
		snprintf(pbuf, 100, "Character,%d", LENGTH(CAR(s)));
		break;

	    case RAWSXP:
		snprintf(pbuf, 100, "Raw,%d", LENGTH(CAR(s)));
		break;

	    case LISTSXP:
		snprintf(pbuf, 100, "List,%d", length(CAR(s)));
		break;

	    case LANGSXP:
		snprintf(pbuf, 100, "Expression");
		break;

	    default:
		snprintf(pbuf, 100, "?");
		break;
	    }
	    pbuf[100] ='\0';
	    SET_STRING_ELT(t, i++, mkChar(pbuf));
	    s = CDR(s);
	}
	if (LENGTH(dims) == 2) {
	    SEXP rl, cl;
	    GetMatrixDimnames(s, &rl, &cl, &rn, &cn);
	    printMatrix(t, 0, dims, data->quote, data->right, rl, cl,
			rn, cn);
	}
	else {
	    PROTECT(dimnames = getAttrib(s, R_DimNamesSymbol));
	    printArray(t, dims, 0, Rprt_adj_left, dimnames);
	    UNPROTECT(1);
	}
	UNPROTECT(2);
    }
    else { // no dim()
	i = 1;
	taglen = (int) strlen(tagbuf);
	ptag = tagbuf + taglen;
	while (TYPEOF(s) == LISTSXP) {
	    if (i > 1) Rprintf("\n");
	    if (TAG(s) != R_NilValue && isSymbol(TAG(s))) {
		if (taglen + strlen(CHAR(PRINTNAME(TAG(s)))) > TAGBUFLEN) {
		    if (taglen <= TAGBUFLEN)
			sprintf(ptag, "$...");
		} else {
		    /* we need to distinguish character NA from "NA", which
		       is a valid (if non-syntactic) name */
		    if (PRINTNAME(TAG(s)) == NA_STRING)
			sprintf(ptag, "$<NA>");
		    else if( isValidName(CHAR(PRINTNAME(TAG(s)))) )
			sprintf(ptag, "$%s", CHAR(PRINTNAME(TAG(s))));
		    else
			sprintf(ptag, "$`%s`", EncodeChar(PRINTNAME(TAG(s))));
		}
	    }
	    else {
		if (taglen + IndexWidth(i) > TAGBUFLEN) {
		    if (taglen <= TAGBUFLEN)
			sprintf(ptag, "$...");
		} else
		    sprintf(ptag, "[[%d]]", i);
	    }

            Rprintf("%s\n", tagbuf);
	    PrintDispatch(CAR(s), data);
            *ptag = '\0';

	    s = CDR(s);
	    i++;
	}
	if (s != R_NilValue) {
	    Rprintf("\n. \n\n");
	    PrintValueRec(s, data);
	}
	Rprintf("\n");
    }
    printAttributes(s, data, FALSE);
}

static void PrintExpression(SEXP s, R_PrintData *data)
{
    SEXP u;
    int i, n;

    u = PROTECT(deparse1w(s, 0, data->useSource | DEFAULTDEPARSE));
    R_print = *data; /* Deparsing calls PrintDefaults() */

    n = LENGTH(u);
    for (i = 0; i < n; i++)
	Rprintf("%s\n", CHAR(STRING_ELT(u, i))); /*translated */
    UNPROTECT(1); /* u */
}

static void PrintSpecial(SEXP s, R_PrintData *data)
{
    /* This is OK as .Internals are not visible to be printed */
    char *nm = PRIMNAME(s);
    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);
    s2 = findVarInFrame3(env, install(nm), TRUE);
    if(s2 == R_UnboundValue) {
	REPROTECT(env = findVarInFrame3(R_BaseEnv,
					install(".GenericArgsEnv"), TRUE),
		  xp);
	if (TYPEOF(env) == PROMSXP)
	    REPROTECT(env = eval(env, R_BaseEnv), xp);
	s2 = findVarInFrame3(env, install(nm), TRUE);
    }
    if(s2 != R_UnboundValue) {
	SEXP t;
	PROTECT(s2);
	t = deparse1m(s2, 0, DEFAULTDEPARSE); // or deparse1() ?
	R_print = *data; /* Deparsing calls PrintDefaults() */

	Rprintf("%s ", CHAR(STRING_ELT(t, 0))); /* translated */
	Rprintf(".Primitive(\"%s\")\n", PRIMNAME(s));
	UNPROTECT(1);
    } else /* missing definition, e.g. 'if' */
	Rprintf(".Primitive(\"%s\")\n", PRIMNAME(s));
    UNPROTECT(1);
}

#ifdef Win32
static void print_cleanup(void *data)
{
    WinUTF8out = *(Rboolean *)data;
}
#endif

/* PrintValueRec -- recursively print an SEXP

 * This is the "dispatching" function for  print.default()
 */
void attribute_hidden PrintValueRec(SEXP s, R_PrintData *data)
{
    SEXP t;

#ifdef Win32
    RCNTXT cntxt;
    Rboolean havecontext = FALSE;
    Rboolean saveWinUTF8out = WinUTF8out;

    WinCheckUTF8();
    if (WinUTF8out != saveWinUTF8out) {
	begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
	             R_NilValue, R_NilValue);
	cntxt.cend = &print_cleanup;
	cntxt.cenddata = &saveWinUTF8out;
	havecontext = TRUE;
    }
#endif
    if(!isMethodsDispatchOn() && (IS_S4_OBJECT(s) || TYPEOF(s) == S4SXP) ) {
	SEXP cl = getAttrib(s, R_ClassSymbol);
	if(isNull(cl)) {
	    /* This might be a mistaken S4 bit set */
	    if(TYPEOF(s) == S4SXP)
		Rprintf("<S4 object without a class>\n");
	    else
		Rprintf("<Object of type '%s' with S4 bit but without a class>\n",
			type2char(TYPEOF(s)));
	} else {
	    SEXP pkg = getAttrib(s, R_PackageSymbol);
	    if(isNull(pkg)) {
		Rprintf("<S4 object of class \"%s\">\n",
			CHAR(STRING_ELT(cl, 0)));
	    } else {
		Rprintf("<S4 object of class \"%s\" from package '%s'>\n",
			CHAR(STRING_ELT(cl, 0)), CHAR(STRING_ELT(pkg, 0)));
	    }
	}
	goto done;
    }
    switch (TYPEOF(s)) {
    case NILSXP:
	Rprintf("NULL\n");
	break;
    case SYMSXP:
	/* Use deparse here to handle backtick quotification of "weird names". */
	t = deparse1(s, 0, SIMPLEDEPARSE); // TODO ? rather deparse1m()
	R_print = *data; /* Deparsing calls PrintDefaults() */
	Rprintf("%s\n", CHAR(STRING_ELT(t, 0))); /* translated */
	break;
    case SPECIALSXP:
    case BUILTINSXP:
	PrintSpecial(s, data);
	break;
    case CHARSXP:
	Rprintf("<CHARSXP: ");
	Rprintf("%s", EncodeString(s, 0, '"', Rprt_adj_left));
	Rprintf(">\n");
	goto done; /* skip attribute printing for CHARSXP; they are used */
		   /* in managing the CHARSXP cache. */
    case EXPRSXP:
	PrintExpression(s, data);
	break;
    case LANGSXP:
	PrintLanguage(s, data);
	break;
    case CLOSXP:
	PrintClosure(s, data);
	break;
    case ENVSXP:
	Rprintf("%s\n", EncodeEnvironment(s));
	break;
    case PROMSXP:
	Rprintf("<promise: %p>\n", s);
	break;
    case DOTSXP:
	Rprintf("<...>\n");
	break;
    case VECSXP:
	PrintGenericVector(s, data); /* handles attributes/slots */
	goto done;
    case LISTSXP:
	printList(s, data);
	break;
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case STRSXP:
    case CPLXSXP:
    case RAWSXP:
	PROTECT(t = getAttrib(s, R_DimSymbol));
	if (TYPEOF(t) == INTSXP) {
	    if (LENGTH(t) == 1) {
		const void *vmax = vmaxget();
		PROTECT(t = getAttrib(s, R_DimNamesSymbol));
		if (t != R_NilValue && VECTOR_ELT(t, 0) != R_NilValue) {
		    SEXP nn = getAttrib(t, R_NamesSymbol);
		    const char *title = NULL;

		    if (!isNull(nn))
			title = translateChar(STRING_ELT(nn, 0));

		    printNamedVector(s, VECTOR_ELT(t, 0), data->quote, title);
		}
		else
		    printVector(s, 1, data->quote);
		UNPROTECT(1);
		vmaxset(vmax);
	    }
	    else if (LENGTH(t) == 2) {
		SEXP rl, cl;
		const char *rn, *cn;
		GetMatrixDimnames(s, &rl, &cl, &rn, &cn);
		printMatrix(s, 0, t, data->quote, data->right, rl, cl,
			    rn, cn);
	    }
	    else {
		SEXP dimnames;
		PROTECT(dimnames = GetArrayDimnames(s));
		printArray(s, t, data->quote, data->right, dimnames);
		UNPROTECT(1);
	    }
	}
	else {
	    UNPROTECT(1);
	    PROTECT(t = getAttrib(s, R_NamesSymbol));
	    if (t != R_NilValue)
		printNamedVector(s, t, data->quote, NULL);
	    else
		printVector(s, 1, data->quote);
	}
	UNPROTECT(1);
	break;
    case EXTPTRSXP:
	Rprintf("<pointer: %p>\n", R_ExternalPtrAddr(s));
	break;
    case BCODESXP:
	Rprintf("<bytecode: %p>\n", s);
	break;
    case WEAKREFSXP:
	Rprintf("<weak reference>\n");
	break;
    case S4SXP:
	/*  we got here because no show method, usually no class.
	    Print the "slots" as attributes, since we don't know the class.
	*/
	Rprintf("<S4 Type Object>\n");
	break;
    default:
	UNIMPLEMENTED_TYPE("PrintValueRec", s);
    }
    printAttributes(s, data, FALSE);

done:

#ifdef Win32
    if (havecontext)
	endcontext(&cntxt);
    print_cleanup(&saveWinUTF8out);
#endif
    return; /* needed when Win32 is not defined */
}

/* 2000-12-30 PR#715: remove list tags from tagbuf here
   to avoid $a$battr("foo").  Need to save and restore, since
   attributes might be lists with attributes or just have attributes ...
 */
static void printAttributes(SEXP s, R_PrintData *data, Rboolean useSlots)
{
    SEXP a;
    char *ptag;
    char save[TAGBUFLEN0] = "\0";

    a = ATTRIB(s);
    if (a != R_NilValue) {
	/* guard against cycles through attributes on environments */
	if (strlen(tagbuf) > TAGBUFLEN0)
	    error(_("print buffer overflow"));
	strcpy(save, tagbuf);
	/* remove the tag if it looks like a list not an attribute */
	if (strlen(tagbuf) > 0 &&
	    *(tagbuf + strlen(tagbuf) - 1) != ')')
	    tagbuf[0] = '\0';
	ptag = tagbuf + strlen(tagbuf);
	while (a != R_NilValue) {
	    if(useSlots && TAG(a) == R_ClassSymbol)
		    goto nextattr;
	    if(isArray(s) || isList(s)) {
		if(TAG(a) == R_DimSymbol ||
		   TAG(a) == R_DimNamesSymbol)
		    goto nextattr;
	    }
	    if(inherits(s, "factor")) {
		if(TAG(a) == R_LevelsSymbol)
		    goto nextattr;
		if(TAG(a) == R_ClassSymbol)
		    goto nextattr;
	    }
	    if(isFrame(s)) {
		if(TAG(a) == R_RowNamesSymbol)
		    goto nextattr;
	    }
	    if(!isArray(s)) {
		if (TAG(a) == R_NamesSymbol)
		    goto nextattr;
	    }
	    if(TAG(a) == R_CommentSymbol || TAG(a) == R_SrcrefSymbol
	       || TAG(a) == R_WholeSrcrefSymbol || TAG(a) == R_SrcfileSymbol)
		goto nextattr;
	    if(useSlots)
		sprintf(ptag, "Slot \"%s\":", EncodeChar(PRINTNAME(TAG(a))));
	    else
		sprintf(ptag, "attr(,\"%s\")", EncodeChar(PRINTNAME(TAG(a))));
	    Rprintf("%s", tagbuf); Rprintf("\n");
	    if (TAG(a) == R_RowNamesSymbol) {
		/* need special handling AND protection */
		SEXP val;
		PROTECT(val = getAttrib(s, R_RowNamesSymbol));
		PrintValueRec(val, data);
		UNPROTECT(1);
		goto nextattr;
	    }
	    PrintDispatch(CAR(a), data);
	nextattr:
	    *ptag = '\0';
	    a = CDR(a);
	}
	strcpy(tagbuf, save);
    }
}/* printAttributes */


/* Print an S-expression using (possibly) local options.
   This is used for auto-printing from main.c */

void attribute_hidden PrintValueEnv(SEXP s, SEXP env)
{
    PrintDefaults();
    tagbuf[0] = '\0';
    PROTECT(s);

    R_PrintData data;
    PrintInit(&data, env);
    if (isFunction(s))
	/* printed via print() -> print.function() in order to allow user-defined
	   print.function() methods to also work in auto-printing: */
        PrintObject(s, &data);
    else
        PrintDispatch(s, &data);

    UNPROTECT(1);
}


/* Print an S-expression using global options */

void PrintValue(SEXP s)
{
    PrintValueEnv(s, R_GlobalEnv);
}


/* Ditto, but only for objects, for use in debugging */

void R_PV(SEXP s)
{
    if(isObject(s)) PrintValueEnv(s, R_GlobalEnv);
}


void attribute_hidden CustomPrintValue(SEXP s, SEXP env)
{
    tagbuf[0] = '\0';

    R_PrintData data;
    PrintInit(&data, env);
    PrintValueRec(s, &data);
}


/* xxxpr are mostly for S compatibility (as mentioned in V&R).
   The Fortran interfaces are in xxxpr.f and call these.
    They are always called with *nchar >= 0.
 */

#ifdef FC_LEN_T
# include <stddef.h>
#endif

attribute_hidden
#ifdef FC_LEN_T
void F77_NAME(dblep0) (const char *label, int *nchar, double *data, int *ndata,
		       const FC_LEN_T label_len)
#else
void F77_NAME(dblep0) (const char *label, int *nchar, double *data, int *ndata)
#endif
{
    int nc = *nchar;
    if(nc > 255) {
	warning(_("invalid character length in 'dblepr'"));
	nc = 0;
    } else if(nc > 0) {
	for (int k = 0; k < nc; k++)
	    Rprintf("%c", label[k]);
	Rprintf("\n");
    }
    if(*ndata > 0) printRealVector(data, *ndata, 1);
}

attribute_hidden
#ifdef FC_LEN_T
void F77_NAME(intpr0) (const char *label, int *nchar, int *data, int *ndata,
		       const FC_LEN_T label_len)
#else
void F77_NAME(intpr0) (const char *label, int *nchar, int *data, int *ndata)
#endif
{
    int nc = *nchar;

    if(nc > 255) {
	warning(_("invalid character length in 'intpr'"));
	nc = 0;
    } else if(nc > 0) {
	for (int k = 0; k < nc; k++)
	    Rprintf("%c", label[k]);
	Rprintf("\n");
    }
    if(*ndata > 0) printIntegerVector(data, *ndata, 1);
}

attribute_hidden
#ifdef FC_LEN_T
void F77_NAME(realp0) (const char *label, int *nchar, float *data, int *ndata,
		      const FC_LEN_T label_len)
#else
void F77_NAME(realp0) (const char *label, int *nchar, float *data, int *ndata)
#endif
{
    int nc = *nchar, nd = *ndata;
    double *ddata;

    if(nc > 255) {
	warning(_("invalid character length in 'realpr'"));
	nc = 0;
    }
    else if(nc > 0) {
	for (int k = 0; k < nc; k++)
	    Rprintf("%c", label[k]);
	Rprintf("\n");
    }
    if(nd > 0) {
	ddata = (double *) malloc(nd*sizeof(double));
	if(!ddata) error(_("memory allocation error in 'realpr'"));
	for (int k = 0; k < nd; k++) ddata[k] = (double) data[k];
	printRealVector(ddata, nd, 1);
	free(ddata);
    }
}

/* Fortran-callable error routine for lapack */

#ifdef FC_LEN_T
void NORET F77_NAME(xerbla)(const char *srname, int *info, 
			    const FC_LEN_T srname_len)
#else
void NORET F77_NAME(xerbla)(const char *srname, int *info)
#endif
{
   /* srname is not null-terminated.  It will be 6 characters for
      mainstream BLAS/LAPACK routines (for those with < 6 the name
      is right space-padded), and > 6 for recentish additions from
      LAPACK, 7 for a few used with R ). */
#ifdef FC_LEN_T
    char buf[21];
    // Precaution for incorrectly passed length type
    int len = (srname_len > 20) ? (int)srname_len : 20;
    strncpy(buf, srname, len);
    buf[len] = '\0';
#else
    // This version will truncate to 6 chars and left space-pads
    // for fewer than 6 (at least with gfortran and Solaris).
    char buf[7];
    strncpy(buf, srname, 6);
    buf[6] = '\0';
#endif
    error(_("BLAS/LAPACK routine '%6s' gave error code %d"), buf, -(*info));
}