The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2015  The R Core Team
 *
 *  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/
 *
 *
 *  See ./printutils.c   for general remarks on Printing
 *                       and the Encode.. utils.
 *
 *  See ./format.c   for the  format_Foo_  functions.
 */

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

#include "Defn.h"
#include <Internal.h>

#define imax2(x, y) ((x < y) ? y : x)

#include "Print.h"
#include "RBufferUtils.h"
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};

/*
  .Internal(paste (args, sep, collapse))
  .Internal(paste0(args, collapse))

 * do_paste uses two passes to paste the arguments (in CAR(args)) together.
 * The first pass calculates the width of the paste buffer,
 * then it is alloc-ed and the second pass stuffs the information in.
 */

/* Note that NA_STRING is not handled separately here.  This is
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
*/
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, collapse, sepArg, x;
    int sepw, u_sepw, ienc;
    R_xlen_t i, j, k, maxlen, nx, pwidth;
    const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
    char *buf;
    Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
    sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
    use_sep = (PRIMVAL(op) == 0);
    const void *vmax;

    checkArity(op, args);

    /* We use formatting and so we must initialize printing. */

    PrintDefaults();

    /* Check the arguments */

    x = CAR(args);
    if (!isVectorList(x))
    error(_("invalid first argument"));
    nx = xlength(x);

    R_string_elt_ptr_t sep_elt;
    if(use_sep) { /* paste(..., sep, .) */
    sepArg = CADR(args);
    if (!isString(sepArg) || LENGTH(sepArg) <= 0 ||
        SE_IS_NA(SE_STRING_ELT_PTR(sepArg, 0)))
        error(_("invalid separator"));
    sep_elt = SE_STRING_ELT_PTR(sepArg, 0);
    csep = SE_translateChar(sep_elt);
    u_sepw = sepw = (int) strlen(csep); // will be short
    sepASCII = strIsASCII(csep);
    sepKnown = SE_ENC_KNOWN(sep_elt) > 0;
    sepUTF8 = SE_IS_UTF8(sep_elt);
    sepBytes = SE_IS_BYTES(sep_elt);
    collapse = CADDR(args);
    } else { /* paste0(..., .) */
    u_sepw = sepw = 0; sep_elt = NULL;/* -Wall */
    collapse = CADR(args);
    }
    if (!isNull(collapse))
    if(!isString(collapse) || LENGTH(collapse) <= 0 ||
       SE_IS_NA(SE_STRING_ELT_PTR(collapse, 0)))
        error(_("invalid '%s' argument"), "collapse");
    if(nx == 0)
    return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);


    /* Maximum argument length, coerce if needed */

    maxlen = 0;
    for (j = 0; j < nx; j++) {
    if (!isString(VECTOR_ELT(x, j))) {
        /* formerly in R code: moved to C for speed */
        SEXP call, xj = VECTOR_ELT(x, j);
        if(OBJECT(xj)) { /* method dispatch */
        PROTECT(call = lang2(install("as.character"), xj));
        SET_VECTOR_ELT(x, j, eval(call, env));
        UNPROTECT(1);
        } else if (isSymbol(xj))
        SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
        else
        SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));

        if (!isString(VECTOR_ELT(x, j)))
        error(_("non-string argument to internal 'paste'"));
    }
    if(XLENGTH(VECTOR_ELT(x, j)) > maxlen)
        maxlen = XLENGTH(VECTOR_ELT(x, j));
    }
    if(maxlen == 0)
    return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);

    PROTECT(ans = allocVector(STRSXP, maxlen));

    for (i = 0; i < maxlen; i++) {
    /* Strategy for marking the encoding: if all inputs (including
     * the separator) are ASCII, so is the output and we don't
     * need to mark.  Otherwise if all non-ASCII inputs are of
     * declared encoding, we should mark.
     * Need to be careful only to include separator if it is used.
     */
    anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
    if(nx > 1) {
        allKnown = sepKnown || sepASCII;
        anyKnown = sepKnown;
        use_UTF8 = sepUTF8;
        use_Bytes = sepBytes;
    }

    pwidth = 0;
    for (j = 0; j < nx; j++) {
        k = XLENGTH(VECTOR_ELT(x, j));
        if (k > 0) {
        R_string_elt_ptr_t cs = SE_STRING_ELT_PTR(VECTOR_ELT(x, j),
                              i % k);
        if(SE_IS_UTF8(cs)) use_UTF8 = TRUE;
        if(SE_IS_BYTES(cs)) use_Bytes = TRUE;
        }
    }
    if (use_Bytes) use_UTF8 = FALSE;
    vmax = vmaxget();
    for (j = 0; j < nx; j++) {
        k = XLENGTH(VECTOR_ELT(x, j));
        if (k > 0) {
        R_string_elt_ptr_t s = SE_STRING_ELT_PTR(VECTOR_ELT(x, j),
                             i % k);
        if(use_Bytes)
            pwidth += strlen(SE_CHAR(s));
        else if(use_UTF8)
            pwidth += strlen(SE_translateCharUTF8(s));
        else
            pwidth += strlen(SE_translateChar(s));
        vmaxset(vmax);
        }
    }
    if(use_sep) {
        if (use_UTF8 && !u_csep) {
        u_csep = SE_translateCharUTF8(sep_elt);
        u_sepw = (int) strlen(u_csep); // will be short
        }
        pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
    }
    if (pwidth > INT_MAX)
        error(_("result would exceed 2^31-1 bytes"));
    cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
    vmax = vmaxget();
    for (j = 0; j < nx; j++) {
        k = XLENGTH(VECTOR_ELT(x, j));
        if (k > 0) {
        R_string_elt_ptr_t cs = SE_STRING_ELT_PTR(VECTOR_ELT(x, j),
                              i % k);
        if (use_UTF8) {
            s = SE_translateCharUTF8(cs);
            strcpy(buf, s);
            buf += strlen(s);
        } else {
            s = use_Bytes ? SE_CHAR(cs) : SE_translateChar(cs);
            strcpy(buf, s);
            buf += strlen(s);
            allKnown = allKnown && (strIsASCII(s) || (SE_ENC_KNOWN(cs)> 0));
            anyKnown = anyKnown || (SE_ENC_KNOWN(cs)> 0);
        }
        }
        if (sepw != 0 && j != nx - 1) {
        if (use_UTF8) {
            strcpy(buf, u_csep);
            buf += u_sepw;
        } else {
            strcpy(buf, csep);
            buf += sepw;
        }
        }
        vmax = vmaxget();
    }
    ienc = 0;
    if(use_UTF8) ienc = CE_UTF8;
    else if(use_Bytes) ienc = CE_BYTES;
    else if(anyKnown && allKnown) {
        if(known_to_be_latin1) ienc = CE_LATIN1;
        if(known_to_be_utf8) ienc = CE_UTF8;
    }
    SET_STRING_ELT_FROM_CSTR_CE(ans, i, cbuf, ienc);
    }

    /* Now collapse, if required. */

    if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
    sep_elt = SE_STRING_ELT_PTR(collapse, 0);
    use_UTF8 = SE_IS_UTF8(sep_elt);
    use_Bytes = SE_IS_BYTES(sep_elt);
    for (i = 0; i < nx; i++) {
        if(SE_IS_UTF8(SE_STRING_ELT_PTR(ans, i))) use_UTF8 = TRUE;
        if(SE_IS_BYTES(SE_STRING_ELT_PTR(ans, i))) use_Bytes = TRUE;
    }
    if(use_Bytes) {
        csep = SE_CHAR(sep_elt);
        use_UTF8 = FALSE;
    } else if(use_UTF8)
        csep = SE_translateCharUTF8(sep_elt);
    else
        csep = SE_translateChar(sep_elt);
    sepw = (int) strlen(csep);
    anyKnown = SE_ENC_KNOWN(sep_elt) > 0;
    allKnown = anyKnown || strIsASCII(csep);
    pwidth = 0;
    vmax = vmaxget();
    for (i = 0; i < nx; i++)
        if(use_UTF8) {
        pwidth += strlen(SE_translateCharUTF8(SE_STRING_ELT_PTR(ans, i)));
        vmaxset(vmax);
        } else /* already translated */
        pwidth += strlen(SE_CHAR(SE_STRING_ELT_PTR(ans, i)));
    pwidth += (nx - 1) * sepw;
    if (pwidth > INT_MAX)
        error(_("result would exceed 2^31-1 bytes"));
    cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
    vmax = vmaxget();
    for (i = 0; i < nx; i++) {
        if(i > 0) {
        strcpy(buf, csep);
        buf += sepw;
        }
        R_string_elt_ptr_t ai = SE_STRING_ELT_PTR(ans, i);
        if(use_UTF8)
        s = SE_translateCharUTF8(ai);
        else /* already translated */
        s = SE_CHAR(ai);
        strcpy(buf, s);
        while (*buf)
        buf++;
        allKnown = allKnown &&
        (strIsASCII(s) || (SE_ENC_KNOWN(ai) > 0));
        anyKnown = anyKnown || (SE_ENC_KNOWN(ai) > 0);
        if(use_UTF8) vmaxset(vmax);
    }
    UNPROTECT(1);
    ienc = CE_NATIVE;
    if(use_UTF8) ienc = CE_UTF8;
    else if(use_Bytes) ienc = CE_BYTES;
    else if(anyKnown && allKnown) {
        if(known_to_be_latin1) ienc = CE_LATIN1;
        if(known_to_be_utf8) ienc = CE_UTF8;
    }
    PROTECT(ans = allocVector(STRSXP, 1));
    SET_STRING_ELT_FROM_CSTR_CE(ans, 0, cbuf, ienc);
    }
    R_FreeStringBufferL(&cbuff);
    UNPROTECT(1);
    return ans;
}

SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, sepArg, x;
    int i, j, k, ln, maxlen, nx, nzero, pwidth, sepw;
    const char *s, *csep, *cbuf;
    char *buf;

    checkArity(op, args);

    /* Check the arguments */

    x = CAR(args);
    if (!isVectorList(x))
    error(_("invalid first argument"));
    nx = length(x);
    if(nx == 0) return allocVector(STRSXP, 0);


    sepArg = CADR(args);
    if (!isString(sepArg) || LENGTH(sepArg) <= 0 ||
    SE_IS_NA(SE_STRING_ELT_PTR(sepArg, 0)))
    error(_("invalid separator"));
    R_string_elt_ptr_t sep_elt = SE_STRING_ELT_PTR(sepArg, 0);
    csep = SE_CHAR(sep_elt);
    sepw = (int) strlen(csep); /* hopefully 1 */

    /* Any zero-length argument gives zero-length result */
    maxlen = 0; nzero = 0;
    for (j = 0; j < nx; j++) {
    if (!isString(VECTOR_ELT(x, j))) {
        /* formerly in R code: moved to C for speed */
        SEXP call, xj = VECTOR_ELT(x, j);
        if(OBJECT(xj)) { /* method dispatch */
        PROTECT(call = lang2(install("as.character"), xj));
        SET_VECTOR_ELT(x, j, eval(call, env));
        UNPROTECT(1);
        } else if (isSymbol(xj))
        SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
        else
        SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));

        if (!isString(VECTOR_ELT(x, j)))
        error(_("non-string argument to Internal paste"));
    }
    ln = LENGTH(VECTOR_ELT(x, j));
    if(ln > maxlen) maxlen = ln;
    if(ln == 0) {nzero++; break;}
    }
    if(nzero || maxlen == 0) return allocVector(STRSXP, 0);

    PROTECT(ans = allocVector(STRSXP, maxlen));

    for (i = 0; i < maxlen; i++) {
    pwidth = 0;
    for (j = 0; j < nx; j++) {
        k = LENGTH(VECTOR_ELT(x, j));
        pwidth += (int) strlen(SE_translateChar(SE_STRING_ELT_PTR(VECTOR_ELT(x, j), i % k)));
    }
    pwidth += (nx - 1) * sepw;
    cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
    for (j = 0; j < nx; j++) {
        k = LENGTH(VECTOR_ELT(x, j));
        if (k > 0) {
        s = SE_translateChar(SE_STRING_ELT_PTR(VECTOR_ELT(x, j), i % k));
        strcpy(buf, s);
        buf += strlen(s);
        }
        if (j != nx - 1 && sepw != 0) {
        strcpy(buf, csep);
        buf += sepw;
        }
    }
#ifdef Win32
    // Trailing seps are invalid for file paths except for / and d:/
    if(streql(csep, "/") || streql(csep, "\\")) {
        if(buf > cbuf) {
        buf--;
        if(*buf == csep[0] && buf > cbuf &&
           (buf != cbuf+2 || cbuf[1] != ':')) *buf = '\0';
        }
    }
#endif
    SET_STRING_ELT_FROM_CSTR(ans, i, cbuf);
    }
    R_FreeStringBufferL(&cbuff);
    UNPROTECT(1);
    return ans;
}

/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
          scientific, decimal.mark) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP l, x, y, swd;
    int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
    int w, d, e;
    int wi, di, ei, scikeep;
    const char *strp;
    R_xlen_t i, n;

    checkArity(op, args);
    PrintDefaults();
    scikeep = R_print.scipen;

    if (isEnvironment(x = CAR(args))) {
    return mkString(EncodeEnvironment(x));
    }
    else if (!isVector(x))
    error(_("first argument must be atomic"));
    args = CDR(args);

    trim = asLogical(CAR(args));
    if (trim == NA_INTEGER)
    error(_("invalid '%s' argument"), "trim");
    args = CDR(args);

    if (!isNull(CAR(args))) {
    digits = asInteger(CAR(args));
    if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
        || digits > R_MAX_DIGITS_OPT)
        error(_("invalid '%s' argument"), "digits");
    R_print.digits = digits;
    }
    args = CDR(args);

    nsmall = asInteger(CAR(args));
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
    error(_("invalid '%s' argument"), "nsmall");
    args = CDR(args);

    if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
    if(wd == NA_INTEGER)
    error(_("invalid '%s' argument"), "width");
    args = CDR(args);

    adj = asInteger(CAR(args));
    if(adj == NA_INTEGER || adj < 0 || adj > 3)
    error(_("invalid '%s' argument"), "justify");
    args = CDR(args);

    na = asLogical(CAR(args));
    if(na == NA_LOGICAL)
    error(_("invalid '%s' argument"), "na.encode");
    args = CDR(args);
    if(LENGTH(CAR(args)) != 1)
    error(_("invalid '%s' argument"), "scientific");
    if(isLogical(CAR(args))) {
    int tmp = LOGICAL(CAR(args))[0];
    if(tmp == NA_LOGICAL) sci = NA_INTEGER;
    else sci = tmp > 0 ?-100 : 100;
    } else if (isNumeric(CAR(args))) {
    sci = asInteger(CAR(args));
    } else
    error(_("invalid '%s' argument"), "scientific");
    if(sci != NA_INTEGER) R_print.scipen = sci;
    args = CDR(args);
    // copy/paste from "OutDec" part of ./options.c
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
    error(_("invalid '%s' argument"), "decimal.mark");
    char *my_OutDec;
    if(SE_IS_NA(SE_STRING_ELT_PTR(CAR(args), 0)))
    my_OutDec = OutDec; // default
    else {
    static char sdec[11];
// not warning here by default for now
#ifdef _WARN_decimal_mark_non_1
    if(R_nchar(STRING_ELT(CAR(args), 0), Chars,
           /* allowNA = */ FALSE, /* keepNA = */ FALSE,
           "decimal.mark") != 1) // will become an error
        warning(_("'decimal.mark' must be a string of one character"));
#endif
    strncpy(sdec, SE_CHAR(SE_STRING_ELT_PTR(CAR(args), 0)), 10);
    sdec[10] = '\0';
    my_OutDec = sdec;
    }

    if ((n = XLENGTH(x)) <= 0) {
    PROTECT(y = allocVector(STRSXP, 0));
    } else {
    switch (TYPEOF(x)) {

    case LGLSXP:
        PROTECT(y = allocVector(STRSXP, n));
        if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
        w = imax2(w, wd);
        for (i = 0; i < n; i++) {
        strp = EncodeLogical(LOGICAL(x)[i], w);
        SET_STRING_ELT_FROM_CSTR(y, i, strp);
        }
        break;

    case INTSXP:
        PROTECT(y = allocVector(STRSXP, n));
        if (trim) w = 0;
        else formatInteger(INTEGER(x), n, &w);
        w = imax2(w, wd);
        for (i = 0; i < n; i++) {
        strp = EncodeInteger(INTEGER(x)[i], w);
        SET_STRING_ELT_FROM_CSTR(y, i, strp);
        }
        break;

    case REALSXP:
        formatReal(REAL(x), n, &w, &d, &e, nsmall);
        if (trim) w = 0;
        w = imax2(w, wd);
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
        strp = EncodeReal0(REAL(x)[i], w, d, e, my_OutDec);
        SET_STRING_ELT_FROM_CSTR(y, i, strp);
        }
        break;

    case CPLXSXP:
        formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
        if (trim) wi = w = 0;
        w = imax2(w, wd); wi = imax2(wi, wd);
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
        strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, my_OutDec);
        SET_STRING_ELT_FROM_CSTR(y, i, strp);
        }
        break;

    case STRSXP:
    {
        /* this has to be different from formatString/EncodeString as
           we don't actually want to encode here */
        const char *s;
        char *q;
        int b, b0, cnt = 0, j;
        SEXP s0, xx;

        /* This is clumsy, but it saves rewriting and re-testing
           this complex code */
        PROTECT(xx = duplicate(x));
        for (i = 0; i < n; i++) {
        R_string_elt_ptr_t tmp = SE_STRING_ELT_PTR(xx, i);
        if(SE_IS_BYTES(tmp)) {
            const char *p = SE_CHAR(tmp), *q;
            char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
            for (q = p; *q; q++) {
            unsigned char k = (unsigned char) *q;
            if (k >= 0x20 && k < 0x80) {
                *qq++ = *q;
            } else {
                snprintf(buf, 5, "\\x%02x", k);
                for(int j = 0; j < 4; j++) *qq++ = buf[j];
            }
            }
            *qq = '\0';
            s = pp;
        } else s = SE_translateChar(tmp);
        if(s != SE_CHAR(tmp)) SET_STRING_ELT_FROM_CSTR(xx, i, s);
        }

        w = wd;
        if (adj != Rprt_adj_none) {
        for (i = 0; i < n; i++)
            if (STRING_ELT(xx, i) != NA_STRING)
            w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
            else if (na) w = imax2(w, R_print.na_width);
        } else w = 0;
        /* now calculate the buffer size needed, in bytes */
        for (i = 0; i < n; i++)
        if (STRING_ELT(xx, i) != NA_STRING) {
            il = Rstrlen(STRING_ELT(xx, i), 0);
            cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
        } else if (na)
            cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
        R_CheckStack2(cnt+1);
        char buff[cnt+1];
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
        if(!na && STRING_ELT(xx, i) == NA_STRING) {
            SET_STRING_ELT_TO_NA_STRING(y, i);
        } else {
            q = buff;
            if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
            else s0 = STRING_ELT(xx, i) ;
            s = CHAR(s0);
            il = Rstrlen(s0, 0);
            b = w - il;
            if(b > 0 && adj != Rprt_adj_left) {
            b0 = (adj == Rprt_adj_centre) ? b/2 : b;
            for(j = 0 ; j < b0 ; j++) *q++ = ' ';
            b -= b0;
            }
            for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
            if(b > 0 && adj != Rprt_adj_right)
            for(j = 0 ; j < b ; j++) *q++ = ' ';
            *q = '\0';
            SET_STRING_ELT_FROM_CSTR(y, i, buff);
        }
        }
    }
    UNPROTECT(2); /* xx , y */
    PROTECT(y);
    break;
    default:
        error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
    }
    }
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
    setAttrib(y, R_DimSymbol, l);
    if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
        setAttrib(y, R_DimNamesSymbol, l);
    } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
    setAttrib(y, R_NamesSymbol, l);

    /* In case something else forgets to set PrintDefaults(), PR#14477 */
    R_print.scipen = scikeep;

    UNPROTECT(1); /* y */
    return y;
}

/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
 *          w = total width (#{chars}) per item
 *          d = #{digits} to RIGHT of "."
 *          e = {0:2}.   0: Fixpoint;
 *                 1,2: exponential with 2/3 digit expon.
 *
 * for complex : 2 x 3 integers for (Re, Im)
 */

SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x;
    int digits, nsmall, no = 1, w, d, e, wi, di, ei;

    checkArity(op, args);
    x = CAR(args);
    R_xlen_t n = XLENGTH(x);
    PrintDefaults();

    digits = asInteger(CADR(args));
    if (!isNull(CADR(args))) {
    digits = asInteger(CADR(args));
    if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
        || digits > R_MAX_DIGITS_OPT)
        error(_("invalid '%s' argument"), "digits");
    R_print.digits = digits;
    }
    nsmall = asInteger(CADDR(args));
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
    error(_("invalid '%s' argument"), "nsmall");

    w = 0;
    d = 0;
    e = 0;
    switch (TYPEOF(x)) {

    case RAWSXP:
    formatRaw(RAW(x), n, &w);
    break;

    case LGLSXP:
    formatLogical(LOGICAL(x), n, &w);
    break;

    case INTSXP:
    formatInteger(INTEGER(x), n, &w);
    break;

    case REALSXP:
    no = 3;
    formatReal(REAL(x), n, &w, &d, &e, nsmall);
    break;

    case CPLXSXP:
    no = 6;
    wi = di = ei = 0;
    formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
    break;

    case STRSXP:
    for (R_xlen_t i = 0; i < n; i++)
        if (STRING_ELT(x, i) != NA_STRING) {
        int il = Rstrlen(STRING_ELT(x, i), 0);
        if (il > w) w = il;
        }
    break;

    default:
    error(_("atomic vector arguments only"));
    }
    x = allocVector(INTSXP, no);
    INTEGER(x)[0] = w;
    if(no > 1) {
    INTEGER(x)[1] = d;
    INTEGER(x)[2] = e;
    }
    if(no > 3) {
    INTEGER(x)[3] = wi;
    INTEGER(x)[4] = di;
    INTEGER(x)[5] = ei;
    }
    return x;
}