/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 1997--2026  The R Core Team

 *  Copyright (C) 1995, 1996  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/

 *

 *

 *  IMPLEMENTATION NOTES:

 *

 *  Deparsing has 3 layers.

 *  - The user interfaces, do_deparse(), do_dput(), and do_dump() should

 *    not be called from an internal function.

 *  - unless nlines > 0, the actual deparsing via deparse2() needs

 *    to be done twice, once to count things up and a second time to put

 *    them into the string vector for return.

 *  - Printing this to a file is handled by the calling routine.

 *

 *  Current call paths:

 *

 *    do_deparse() ------------> deparse1WithCutoff()

 *    do_dput() -> deparse1() -> deparse1WithCutoff()

 *    do_dump() -> deparse1() -> deparse1WithCutoff()

 *  ---------

 *  Workhorse: deparse1WithCutoff() -> deparse2() -> deparse2buff() --> {<itself>, ...}

 *  ---------  ~~~~~~~~~~~~~~~~~~  implicit arg R_BrowseLines == getOption("deparse.max.lines")

 *

 *  ./errors.c: PrintWarnings() | warningcall_dflt() ... -> deparse1s() -> deparse1WithCutoff()

 *  ./print.c : Print[Language|Closure|Expression]()    --> deparse1w() -> deparse1WithCutoff()

 *  bind.c,match.c,..: c|rbind(), match(), switch()...-> deparse1line() -> deparse1WithCutoff()

 *

 *  INDENTATION:

 *

 *  Indentation is carried out in the routine printtab2buff at the

 *  bottom of this file.  It seems like this should be settable via

 *  options.

 *

 *

 *  LocalParseData VARIABLES  (historically GLOBALs):

 *

 *  linenumber:  counts the number of lines that have been written,

 *     this is used to setup storage for deparsing.

 *

 *  len:   counts the length of the current line, it will be

 *     used to determine when to break lines.

 *

 *  incurly:   keeps track of whether we are inside a curly or not,

 *     this affects the printing of if-then-else.

 *

 *  inlist:  keeps track of whether we are inside a list or not,

 *     this affects the printing of if-then-else.

 *

 *  startline:   indicator TRUE=start of a line (so we can tab out to

 *     the correct place).

 *

 *  indent:  how many tabs should be written at the start of

 *     a line.

 *

 *  buff:  contains the current string, we attempt to break

 *     lines at cutoff, but can unlimited length.

 *

 *  lbreak:  often used to indicate whether a line has been

 *     broken, this makes sure that that indenting behaves

 *     itself.

 */

/* DTL ('duncan'):

* The code here used to use static variables to share values

* across the different routines. These have now been collected

* into a struct named  LocalParseData and this is explicitly

* passed between the different routines. This avoids the needs

* for the global variables and allows multiple evaluators, potentially

* in different threads, to work on their own independent copies

* that are local to their call stacks. This avoids any issues

* with interrupts, etc. not restoring values.

* The previous issue with the global "cutoff" variable is now implemented

* by creating a deparse1WithCutoff() routine which takes the cutoff from

* the caller and passes this to the different routines as a member of the

* LocalParseData struct. Access to the deparse1() routine remains unaltered.

* This is exactly as Ross had suggested ...

*

* One possible fix is to restructure the code with another function which

* takes a cutoff value as a parameter.   Then "do_deparse" and "deparse1"

* could each call this deeper function with the appropriate argument.

* I wonder why I didn't just do this? -- it would have been quicker than

* writing this note.  I guess it needs a bit more thought ...

*/

#ifdef HAVE_CONFIG_H

#include <config.h>

#endif

#define R_USE_SIGNALS 1

#include <Defn.h>

#include <Internal.h>

#include <float.h> /* for DBL_DIG */

#include <Print.h>

#include <Fileio.h>

#ifdef Win32

#include <trioremap.h>

#endif

#define BUFSIZE 512

#define MIN_Cutoff 20

#define DEFAULT_Cutoff 60

#define MAX_Cutoff (BUFSIZE - 12)

/* ----- MAX_Cutoff  <  BUFSIZE !! */

#include "RBufferUtils.h"

typedef R_StringBuffer DeparseBuffer;

typedef struct {

    int linenumber;

    int len; // FIXME: size_t

    int incurly;

    int inlist;

    bool startline; /* = true; */

    int indent;

    SEXP strvec;

    int left;

    DeparseBuffer buffer;

    int cutoff;

    int backtick;

    int opts;

    int sourceable;

#ifdef longstring_WARN

    int longstring;

#endif

    int maxlines;

    bool active;

    int isS4;

    bool fnarg; /* fn argument, so parenthesize = as assignment */

} LocalParseData;

static SEXP deparse1WithCutoff(SEXP call, bool abbrev, int cutoff,

             bool backtick, int opts, int nlines);

static void args2buff(SEXP, int, int, LocalParseData *);

static void deparse2buff(SEXP, LocalParseData *);

static void print2buff(const char *, LocalParseData *);

static void printtab2buff(int, LocalParseData *);

static void writeline(LocalParseData *);

static void vec2buff   (SEXP, LocalParseData *, bool do_names);

static void vector2buff(SEXP, LocalParseData *);

static void src2buff1(SEXP, LocalParseData *);

static bool src2buff(SEXP, int, LocalParseData *);

static void linebreak(bool *lbreak, LocalParseData *);

static void deparse2(SEXP, SEXP, LocalParseData *);

// .Internal(deparse(expr, width.cutoff, backtick, .deparseOpts(control), nlines))

attribute_hidden SEXP do_deparse(SEXP call, SEXP op, SEXP args, SEXP rho)

{

    checkArity(op, args);

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

    int cut0 = DEFAULT_Cutoff;

    if(!isNull(CAR(args))) {

  cut0 = asInteger(CAR(args));

  if(cut0 == NA_INTEGER|| cut0 < MIN_Cutoff || cut0 > MAX_Cutoff) {

      warning(_("invalid 'cutoff' value for 'deparse', using default"));

      cut0 = DEFAULT_Cutoff;

  }

    }

    args = CDR(args);

    bool backtick = isNull(CAR(args)) ? 0 : asRbool(CAR(args), call);

    args = CDR(args);

    int opts = isNull(CAR(args)) ? SHOWATTRIBUTES : asInteger(CAR(args));

    args = CDR(args);

    int nlines = asInteger(CAR(args));

    if (nlines == NA_INTEGER) nlines = -1;

    return deparse1WithCutoff(expr, false, cut0, backtick, opts, nlines);

}

// deparse1() version *looking* at getOption("deparse.max.lines")

attribute_hidden /* would need to be in an installed header if not hidden */

SEXP deparse1m(SEXP call, bool abbrev, int opts)

{

    bool backtick = true;

    int old_bl = R_BrowseLines,

        blines = asInteger(GetOption1(install("deparse.max.lines")));

    if (blines != NA_INTEGER && blines > 0)

        R_BrowseLines = blines;

    SEXP result = deparse1WithCutoff(call, abbrev, DEFAULT_Cutoff, backtick,

             opts, 0);

    R_BrowseLines = old_bl;

    return result;

}

// deparse1() version with R_BrowseLines := 0

SEXP deparse1(SEXP call, bool abbrev, int opts)

{

    bool backtick = true;

    int old_bl = R_BrowseLines;

    R_BrowseLines = 0;

    SEXP result = deparse1WithCutoff(call, abbrev, DEFAULT_Cutoff, backtick,

             opts, 0);

    R_BrowseLines = old_bl;

    return result;

}

/* used for language objects in print(), in print.c */

attribute_hidden

SEXP deparse1w(SEXP call, bool abbrev, int opts)

{

    bool backtick = true;

    return deparse1WithCutoff(call, abbrev, R_print.cutoff, backtick, opts, -1);

}

static void deparse_cleanup(void *data)

{

    LocalParseData *l = (LocalParseData *) data;

    R_FreeStringBuffer(&(l->buffer));

}

static SEXP deparse1WithCutoff(SEXP call, bool abbrev, int cutoff,

             bool backtick, int opts, int nlines)

{

/* Arg. abbrev:

  If abbrev is TRUE, then the returned value

  is a STRSXP of length 1 with at most 13 characters.

  This is used for plot labelling etc.

*/

    SEXP svec;

    int savedigits;

    bool need_ellipses = false;

    LocalParseData localData = {

  .linenumber = 0,

  .len = 0,

  .incurly = 0,

  .inlist = 0,

  .startline = true,

  .indent = 0,

  .strvec = NULL,

  .left = 0,

  .buffer = { NULL, 0, BUFSIZE },

  .cutoff = DEFAULT_Cutoff,

  .backtick = false,

  .opts = 0,

  .sourceable = true,

#ifdef longstring_WARN

  .longstring = false,

#endif

  .maxlines = INT_MAX,

  .active = true,

  .isS4 = 0,

  .fnarg = false

    };

    localData.cutoff = cutoff;

    localData.backtick = backtick;

    localData.opts = opts;

    localData.strvec = R_NilValue;

    /* Set up a context to free the heap-allocated buffer when an error

       signalled during deparsing unwinds past this frame */

    RCNTXT cntxt;

    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,

     R_NilValue, R_NilValue);

    cntxt.cend = &deparse_cleanup;

    cntxt.cenddata = &localData;

    PrintDefaults(); /* from global options() */

    savedigits = R_print.digits;

    R_print.digits = DBL_DIG;/* MAX precision */

    print2buff("", &localData); /* ensure allocation of buffer.data, PR#17876 */

    svec = R_NilValue;

    if (nlines > 0) {

  localData.linenumber = localData.maxlines = nlines;

    } else { // default: nlines = -1 (from R), or = 0 (from other C fn's)

  if(R_BrowseLines > 0)// not by default; e.g. from getOption("deparse.max.lines")

      localData.maxlines = R_BrowseLines + 1; // enough to determine linenumber

  deparse2(call, svec, &localData);

  localData.active = true;

  if(R_BrowseLines > 0 && localData.linenumber > R_BrowseLines) {

      localData.linenumber = R_BrowseLines + 1;

      need_ellipses = true;

  }

    }

    PROTECT(svec = allocVector(STRSXP, localData.linenumber));

    deparse2(call, svec, &localData);

    if (abbrev) {

  char data[14];

  strncpy(data, CHAR(STRING_ELT(svec, 0)), 10);

  data[10] = '\0';

  if (strlen(CHAR(STRING_ELT(svec, 0))) > 10) strcat(data, "...");

  svec = mkString(data);

    } else if(need_ellipses) {

  SET_STRING_ELT(svec, R_BrowseLines, mkChar("  ..."));

    }

    if(nlines > 0 && localData.linenumber < nlines) {

  UNPROTECT(1); /* old svec value */

  PROTECT(svec);

  svec = lengthgets(svec, localData.linenumber);

    }

    UNPROTECT(1);

    PROTECT(svec); /* protect from warning() allocating, PR#14356 */

    R_print.digits = savedigits;

    /*: Don't warn anymore, we do deal with most (-> 'S4SXP' below)

    if ((opts & WARNINCOMPLETE) && localData.isS4)

  warning(_("deparse of an S4 object may not always be source()able"));

  else */

    if ((opts & WARNINCOMPLETE) && !localData.sourceable)

  warning(_("deparse may be incomplete"));

#ifdef longstring_WARN

    if ((opts & WARNINCOMPLETE) && localData.longstring)

  warning(_("deparse may be not be source()able in R < 2.7.0"));

#endif

    /* somewhere lower down might have allocated ... */

    endcontext(&cntxt);

    R_FreeStringBuffer(&(localData.buffer));

    UNPROTECT(1);

    return svec;

}

/* deparse1line(), e.g. for non-trivial list entries in as.character(<list>).

 * --------------

 * Concatenates all lines into one long one.

 * This is needed in terms.formula, where we must be able

 * to deparse a term label into a single line of text so

 * that it can be reparsed correctly */

// Used in coerce.c and relop.c

attribute_hidden

SEXP deparse1line_ex(SEXP call, bool abbrev, int opts)

{

    bool backtick=true;

    int lines;

    SEXP temp = PROTECT(

      deparse1WithCutoff(call, abbrev, MAX_Cutoff, backtick, opts, -1));

    if ((lines = length(temp)) > 1) {

  char *buf;

  int i;

  size_t len;

  const void *vmax;

  cetype_t enc = CE_NATIVE;

  for (len = 0, i = 0; i < length(temp); i++) {

      SEXP s = STRING_ELT(temp, i);

      cetype_t thisenc = getCharCE(s);

      len += strlen(CHAR(s));  // FIXME: check for overflow?

      if (thisenc != CE_NATIVE)

    enc = thisenc; /* assume only one non-native encoding */

  }

  vmax = vmaxget();

  buf = R_alloc((size_t) len+lines, sizeof(char));

  *buf = '\0';

  for (i = 0; i < length(temp); i++) {

      if (i % 1000 == 999) R_CheckUserInterrupt();

      strcat(buf, CHAR(STRING_ELT(temp, i)));

      if (i < lines - 1)

    strcat(buf, "\n");

  }

  temp = ScalarString(mkCharCE(buf, enc));

  vmaxset(vmax);

    }

    UNPROTECT(1);

    return(temp);

}

// used in bind.c builtin.c coerce.c match.c relop.c

SEXP deparse1line(SEXP call, bool abbrev)

{

    return deparse1line_ex(call, abbrev, SIMPLEDEPARSE);

}

// called only from ./errors.c  for calls in warnings and errors :

attribute_hidden SEXP deparse1s(SEXP call)

{

   bool backtick=true;

   return

       deparse1WithCutoff(call, false, DEFAULT_Cutoff, backtick,

        DEFAULTDEPARSE, /* nlines = */ 1);

}

#include "Rconnections.h"

static void con_cleanup(void *data)

{

    Rconnection con = data;

    if(con->isopen) con->close(con);

}

// .Internal(dput(x, file, .deparseOpts(control)))

attribute_hidden SEXP do_dput(SEXP call, SEXP op, SEXP args, SEXP rho)

{

    checkArity(op, args);

    SEXP tval = CAR(args);

    int opts = isNull(CADDR(args)) ? SHOWATTRIBUTES : asInteger(CADDR(args));

    if (TYPEOF(tval) == CLOSXP) {

  SEXP clo = PROTECT(duplicate(tval));

  SET_CLOENV(clo, R_GlobalEnv);

  tval = deparse1(clo, 0, opts);

  UNPROTECT(1);

    } else

  tval = deparse1(tval, 0, opts);

    PROTECT(tval); /* against Rconn_printf */

    if(!inherits(CADR(args), "connection"))

  error(_("'file' must be a character string or connection"));

    int ifile = asInteger(CADR(args));

    if (ifile != 1) {

  Rconnection con = getConnection(ifile);

  RCNTXT cntxt;

  bool wasopen = con->isopen;

  if(!wasopen) {

      char mode[5];

      strcpy(mode, con->mode);

      strcpy(con->mode, "w");

      if(!con->open(con)) error(_("cannot open the connection"));

      strcpy(con->mode, mode);

      /* Set up a context which will close the connection on error */

      begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,

       R_NilValue, R_NilValue);

      cntxt.cend = &con_cleanup;

      cntxt.cenddata = con;

  }

  if(!con->canwrite) error(_("cannot write to this connection"));

  bool havewarned = false;

  for (int i = 0; i < LENGTH(tval); i++) {

      int res = Rconn_printf(con, "%s\n", CHAR(STRING_ELT(tval, i)));

      if(!havewarned &&

         res < strlen(CHAR(STRING_ELT(tval, i))) + 1) {

    warning(_("wrote too few characters"));

    havewarned = true;

      }

  }

  if(!wasopen) {endcontext(&cntxt); con->close(con);}

    }

    else { // ifile == 1 : "Stdout"

  for (int i = 0; i < LENGTH(tval); i++)

      Rprintf("%s\n", CHAR(STRING_ELT(tval, i)));

    }

    UNPROTECT(1); /* tval */

    return (CAR(args));

}

// .Internal(dump(list, file, envir, opts, evaluate))

attribute_hidden SEXP do_dump(SEXP call, SEXP op, SEXP args, SEXP rho)

{

    checkArity(op, args);

    SEXP names = CAR(args),

   file = CADR(args);

    if(!inherits(file, "connection"))

  error(_("'file' must be a character string or connection"));

    if(!isString(names))

  error( _("character arguments expected"));

    int nobjs = length(names);

    if(nobjs < 1 || length(file) < 1)

  error(_("zero-length argument"));

    SEXP source = CADDR(args);

    if (source != R_NilValue && TYPEOF(source) != ENVSXP)

  error(_("invalid '%s' argument"), "envir");

    int opts = asInteger(CADDDR(args));

    /* <NOTE>: change this if extra options are added */

    if(opts == NA_INTEGER || opts < 0 || opts > 2048)

  error(_("'opts' should be small non-negative integer"));

    // evaluate :

    if (!asLogical(CAD4R(args))) opts |= DELAYPROMISES;

    SEXP objs, o = PROTECT(objs = allocList(nobjs));

    int nout = 0;

    for (int i = 0; i < nobjs; i++, o = CDR(o)) {

  SET_TAG(o, installTrChar(STRING_ELT(names, i)));

  SETCAR(o, R_findVar(TAG(o), source));

  if (CAR(o) == R_UnboundValue)

      warning(_("object '%s' not found"), EncodeChar(PRINTNAME(TAG(o))));

  else nout++;

    }

    o = objs;

    SEXP outnames = PROTECT(allocVector(STRSXP, nout)); // -> result

    if(nout > 0) {

  if(INTEGER(file)[0] == 1) {

      for (int i = 0, nout = 0; i < nobjs; i++) {

    if (CAR(o) == R_UnboundValue) continue;

    const char *obj_name = translateChar(STRING_ELT(names, i));

    SET_STRING_ELT(outnames, nout++, STRING_ELT(names, i));

    if(isValidName(obj_name)) Rprintf("%s <-\n", obj_name);

    else if(opts & S_COMPAT) Rprintf("\"%s\" <-\n", obj_name);

    else Rprintf("`%s` <-\n", obj_name);

    SEXP tval = PROTECT(deparse1(CAR(o), 0, opts));

    for (int j = 0; j < LENGTH(tval); j++)

        Rprintf("%s\n", CHAR(STRING_ELT(tval, j)));/* translated */

    UNPROTECT(1); /* tval */

    o = CDR(o);

      }

  }

  else {

      Rconnection con = getConnection(INTEGER(file)[0]);

      bool wasopen = con->isopen;

      RCNTXT cntxt;

      if(!wasopen) {

    char mode[5];

    strcpy(mode, con->mode);

    strcpy(con->mode, "w");

    if(!con->open(con)) error(_("cannot open the connection"));

    strcpy(con->mode, mode);

    /* Set up a context which will close the connection on error */

    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,

           R_NilValue, R_NilValue);

    cntxt.cend = &con_cleanup;

    cntxt.cenddata = con;

      }

      if(!con->canwrite) error(_("cannot write to this connection"));

      bool havewarned = false;

      for (int i = 0, nout = 0; i < nobjs; i++) {

    if (CAR(o) == R_UnboundValue) continue;

    SET_STRING_ELT(outnames, nout++, STRING_ELT(names, i));

    int res;

    const char *s = translateChar(STRING_ELT(names, i));

    unsigned int extra = 6;

    if(isValidName(s)) {

        extra = 4;

        res = Rconn_printf(con, "%s <-\n", s);

    } else if(opts & S_COMPAT)

        res = Rconn_printf(con, "\"%s\" <-\n", s);

    else

        res = Rconn_printf(con, "`%s` <-\n", s);

    if(!havewarned && res < strlen(s) + extra)

        warning(_("wrote too few characters"));

    SEXP tval = PROTECT(deparse1(CAR(o), 0, opts));

    for (int j = 0; j < LENGTH(tval); j++) {

        res = Rconn_printf(con, "%s\n", CHAR(STRING_ELT(tval, j)));

        if(!havewarned &&

           res < strlen(CHAR(STRING_ELT(tval, j))) + 1) {

      warning(_("wrote too few characters"));

      havewarned = true;

        }

    }

    UNPROTECT(1); /* tval */

    o = CDR(o);

      }

      if(!wasopen) {endcontext(&cntxt); con->close(con);}

  }

    }

    UNPROTECT(2);

    return outnames;

}

static void linebreak(bool *lbreak, LocalParseData *d)

{

    if (d->len > d->cutoff) {

  if (!*lbreak) {

      *lbreak = true;

      d->indent++;

  }

  writeline(d);

    }

}

static void deparse2(SEXP what, SEXP svec, LocalParseData *d)

{

    d->strvec = svec;

    d->linenumber = 0;

    d->indent = 0;

    deparse2buff(what, d);

    writeline(d);

}

/* curlyahead looks at s to see if it is a list with

   the first op being a curly.  You need this kind of

   lookahead info to print if statements correctly.  */

static bool

curlyahead(SEXP s)

{

    if (isList(s) || isLanguage(s))

  if (TYPEOF(CAR(s)) == SYMSXP && CAR(s) == R_BraceSymbol)

      return true;

    return false;

}

/* needsparens looks at an arg to a unary or binary operator to

   determine if it needs to be parenthesized when deparsed

   mainop is a unary or binary operator,

   arg is an argument to it, on the left if left == 1 */

static bool needsparens(PPinfo mainop, SEXP arg, unsigned int left,

          unsigned int deepLeft)

{

    PPinfo arginfo;

    if (TYPEOF(arg) == LANGSXP) {

  if (TYPEOF(CAR(arg)) == SYMSXP) {

      if ((TYPEOF(SYMVALUE(CAR(arg))) == BUILTINSXP) ||

    (TYPEOF(SYMVALUE(CAR(arg))) == SPECIALSXP)) {

    arginfo = PPINFO(SYMVALUE(CAR(arg)));

    /* Not all binary ops are binary! */

    switch(arginfo.kind) {

    case PP_BINARY:

    case PP_BINARY2:

        switch(length(CDR(arg))) {

        case 1:

      /* binary +/- precedence upgraded as unary */

      if (arginfo.precedence == PREC_SUM)

          arginfo.precedence = PREC_SIGN;

      arginfo.kind = PP_UNARY;

      break;

        case 2:

      break;

        default:

      return false;

        }

    default:

        break;

    }

    switch(arginfo.kind) {

    case PP_SUBSET:

        switch (mainop.kind) {

        case PP_DOLLAR:

        case PP_SUBSET:

      if (mainop.precedence > arginfo.precedence)

          return false;

      /* else fall through */

        default:

      break;

        }

    case PP_BINARY:

    case PP_BINARY2:

        if (mainop.precedence == PREC_COMPARE &&

      arginfo.precedence == PREC_COMPARE)

      return true;     /*   a < b < c   is not legal syntax */

        /* else fall through */

    case PP_ASSIGN:

    case PP_ASSIGN2:

    case PP_DOLLAR:

        if (mainop.precedence > arginfo.precedence

      || (mainop.precedence == arginfo.precedence && left == mainop.rightassoc)) {

      return true;

        }

        break;

    case PP_UNARY:

        return (left && mainop.precedence > arginfo.precedence)

      || (deepLeft && deepLeft > arginfo.precedence);

    case PP_FOR:

    case PP_IF:

    case PP_WHILE:

    case PP_REPEAT:

        return left || deepLeft;

    default:

        return false;

    }

      } else if (isUserBinop(CAR(arg))) {

    if (mainop.precedence > PREC_PERCENT

        || (mainop.precedence == PREC_PERCENT && left == mainop.rightassoc)) {

        return true;

    }

      }

  }

    }

    else if ((TYPEOF(arg) == CPLXSXP) && (length(arg) == 1)) {

  if (mainop.precedence > PREC_SUM

      || (mainop.precedence == PREC_SUM && left == mainop.rightassoc)) {

      return true;

  }

    }

    return false;

}

/* does the character() vector x contain one `NA_character_` or is all "",

 * or if(isAtomic) does it have one "recursive" or "use.names" ?  */

static bool usable_nice_names(SEXP x, bool isAtomic)

{

    if(TYPEOF(x) == STRSXP) {

  R_xlen_t i, n = xlength(x);

  bool all_0 = true;

  if(isAtomic) // c(*, recursive=, use.names=): cannot use these as nice_names

      for (i = 0; i < n; i++) {

    if (STRING_ELT(x, i) == NA_STRING

        || strcmp(CHAR(STRING_ELT(x, i)), "recursive") == 0

        || strcmp(CHAR(STRING_ELT(x, i)), "use.names") == 0)

        return false;

    else if (all_0 && *CHAR(STRING_ELT(x, i))) /* length test */

        all_0 = false;

      }

  else

      for (i = 0; i < n; i++) {

    if (STRING_ELT(x, i) == NA_STRING)

        return false;

    else if (all_0 && *CHAR(STRING_ELT(x, i))) /* length test */

        all_0 = false;

      }

  return !all_0;

    }

    return true;

}

typedef enum { UNKNOWN = -1,

         SIMPLE = 0,

         OK_NAMES,   // no structure(*); names written as  (n1 = v1, ..)

         STRUC_ATTR, // use structure(*, <attr> = *, ..) for non-names only

         STRUC_NMS_A // use structure(*, <attr> = *, ..)  for names, too

} attr_type;

#ifdef DEBUG_DEPARSE

static const char* attrT2char(attr_type typ) {

    switch(typ) {

    case UNKNOWN: return "UNKNOWN";

    case SIMPLE: return "SIMPLE";

    case OK_NAMES: return "OK_NAMES";

    case STRUC_ATTR: return "STRUC_ATTR";

    case STRUC_NMS_A: return "STRUC_NMS_A";

    default: return "_unknown_ attr_type -- should *NOT* happen!";

    }

}

# define ChTF(_logic_) (_logic_ ? "true" : "false")

#endif

/* Exact semantic of NICE_NAMES and SHOWATTRIBUTES i.e. "niceNames" and "showAttributes"

C|  depCtrl   | attr1() result

-| -----------+-----------------------------------------------------------------------------

1|  NN &&  SA | STRUCT_ATTR + NN  or  STRUC_NMS_A (if NN are not "allowed")

2| !NN &&  SA | if(has attr) STRUC_NMS_A  else "SIMPLE"

3|  NN && !SA | OK_NAMES   ||  SIMPLE  if(!has_names)

4| !NN && !SA | SIMPLE

C|  depCtrl   : what should   deparse(*, control = depCtrl)   do ?

-| -----------+-----------------------------------------------------------------------------

1|  NN &&  SA : all attributes(but srcref); names "NICE"ly (<nam> = <val>) if valid [no NA]

2| !NN &&  SA : all attributes( "    "   ) use structure(..) incl names but no _nice_ names

3|  NN && !SA : no attributes but names, names nicely even when "wrong" (i.e. NA in names(.))

4| !NN && !SA : no attributes shown, not even names

*/

// is *only* called  if (d->opts & SHOW_ATTR_OR_NMS) = d->opts & (SHOW_A | NICE_N)

static attr_type attr1(SEXP s, LocalParseData *d)

{

    SEXP a = ATTRIB(s), nm = getAttrib(s, R_NamesSymbol);

    attr_type attr = UNKNOWN;

    bool

  nice_names = (bool) (d->opts & NICE_NAMES),

  show_attr  = d->opts & SHOWATTRIBUTES,

  has_names = !isNull(nm), ok_names;

#ifdef DEBUG_DEPARSE

    REprintf("  attr1(): has_names = %s", ChTF(has_names));

#endif

    if(has_names) {

  // ok only if there's no  NA_character_,.. in names() nor all """

  ok_names = nice_names && usable_nice_names(nm, isVectorAtomic(s));

#ifdef DEBUG_DEPARSE

  REprintf(", ok_names = %s", ChTF(ok_names));

#endif

  if(!ok_names)

      attr = show_attr ? STRUC_NMS_A :

    /* nice_names */  OK_NAMES; // even when not ok

    }

    while(attr == UNKNOWN && !isNull(a)) {

  if(has_names && TAG(a) == R_NamesSymbol) {

      // also  ok_names = true

  } else if(show_attr && TAG(a) != R_SrcrefSymbol) {

      attr = STRUC_ATTR;

      break;

  }

  // else

  a = CDR(a);

    }

    if(attr == UNKNOWN)

  attr = has_names ? OK_NAMES : SIMPLE;

    if(attr >= STRUC_ATTR) {

  print2buff("structure(", d);

    } else if(has_names) { // attr <= OK_NAMES

    }

#ifdef DEBUG_DEPARSE

    REprintf(", return()ing %s\n", attrT2char(attr));

#endif

    return attr;

}

/* deparse a single attribute as `<name> = <value>`, shared by attr2() (the

   structure(..) form) and the OBJSXP / object(..) deparse below. */

static void attrEntry(SEXP a, LocalParseData *d)

{

    if(TAG(a) == R_DimSymbol) {

  print2buff("dim", d); // was .Dim

    }

    else if(TAG(a) == R_DimNamesSymbol) {

  print2buff("dimnames", d); // was .Dimnames

    }

    else if(TAG(a) == R_NamesSymbol) {

  print2buff("names", d); // was .Names

    }

    else if(TAG(a) == R_TspSymbol) {

  print2buff("tsp", d); // was .Tsp

    }

    else if(TAG(a) == R_LevelsSymbol) {

  print2buff("levels", d); // was .Label

    }

    else {

  /* TAG(a) might contain spaces etc */

  const char *tag = CHAR(PRINTNAME(TAG(a)));

  int d_opts_in = d->opts;

  d->opts = SIMPLEDEPARSE; /* turn off quote()ing */

  if(isValidName(tag))

      deparse2buff(TAG(a), d);

  else {

      print2buff("\"", d);

      deparse2buff(TAG(a), d);

      print2buff("\"", d);

  }

  d->opts = d_opts_in;

    }

    print2buff(" = ", d);

    bool fnarg = d->fnarg;

    d->fnarg = true;

    deparse2buff(CAR(a), d);

    d->fnarg = fnarg;

}

// function attr2()  writes full  attributes(s) to 'buff'

static void attr2(SEXP s, LocalParseData *d, bool not_names)

{

    SEXP a = ATTRIB(s);

    while(!isNull(a)) {

  if(TAG(a) != R_SrcrefSymbol &&

     !(TAG(a) == R_NamesSymbol && not_names)) {

      print2buff(", ", d);

      attrEntry(a, d);

  }

  a = CDR(a);

    }

    print2buff(")", d);

}

static const char *quotify(SEXP name, int quote)

{

    const char *s = CHAR(name);

    /* If a symbol is not a valid name, put it in quotes, escaping

     * any quotes in the string itself */

    if (isValidName(s) || *s == '\0') return s;

    return EncodeString(name, 0, quote, Rprt_adj_none);

}

/* check for whether we need to parenthesize a caller.  The unevaluated ones

   are tricky:

   We want

     x$f(z)

     x[n](z)

     base::mean(x)

   but

     (f+g)(z)

     (function(x) 1)(x)

     etc.

*/

static bool parenthesizeCaller(SEXP s)

{

    SEXP op, sym;

    if (TYPEOF(s) == LANGSXP) { /* unevaluated */

  op = CAR(s);

  if (TYPEOF(op) == SYMSXP) {

      if (isUserBinop(op)) return true;   /* %foo% */

      sym = SYMVALUE(op);

      if (TYPEOF(sym) == BUILTINSXP

    || TYPEOF(sym) == SPECIALSXP) {

    if (PPINFO(sym).precedence >= PREC_SUBSET

        || PPINFO(sym).kind == PP_FUNCALL

        || PPINFO(sym).kind == PP_PAREN

        || PPINFO(sym).kind == PP_CURLY) return false; /* x$f(z) or x[n](z) or f(z) or (f) or {f} */

    else return true;   /* (f+g)(z) etc. */

      }

      return false;     /* regular function call */

   } else

      return true;     /* something strange, like (1)(x) */

    } else

  return TYPEOF(s) == CLOSXP;

}

/* This is the recursive part of deparsing. */

#define SIMPLE_OPTS (~QUOTEEXPRESSIONS & ~SHOWATTRIBUTES & ~DELAYPROMISES)

/* keep KEEPINTEGER | USESOURCE | KEEPNA | S_COMPAT, also

   WARNINCOMPLETE but that is not used below this point. */

#define SHOW_ATTR_OR_NMS (SHOWATTRIBUTES | NICE_NAMES)

static void deparse2buff(SEXP s, LocalParseData *d)

{

    bool lookahead = false, lbreak = false, fnarg = d->fnarg;

    attr_type attr = STRUC_ATTR;

    SEXP t;

    int d_opts_in = d->opts, i, n;

    d->fnarg = false;

    /* This flag should only be set when recursing through the LHS

       of binary ops, so by default we reset to zero */

    int prevLeft = d->left;

    d->left = 0;

    if (!d->active) return;

    if (IS_S4_OBJECT(s)) {

  d->isS4 = true;

  /* const void *vmax = vmaxget(); */

  SEXP class = getAttrib(s, R_ClassSymbol),

      cl_def = TYPEOF(class) == STRSXP ? STRING_ELT(class, 0) : R_NilValue;

  if(TYPEOF(cl_def) == CHARSXP) { // regular S4 objects

      print2buff("new(\"", d);

      print2buff(translateChar(cl_def), d);

      print2buff("\", ", d);

      SEXP slotNms; // ---- slotNms := methods::.slotNames(s)  ---------

      // computed alternatively, slotNms := names(getClassDef(class)@slots) :

      static SEXP R_getClassDef = NULL, R_slots = NULL, R_asS3 = NULL;

      if(R_getClassDef == NULL)