| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1997--2018 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; |
| Rboolean startline; /* = TRUE; */ |
| int indent; |
| SEXP strvec; |
| |
| DeparseBuffer buffer; |
| |
| int cutoff; |
| int backtick; |
| int opts; |
| int sourceable; |
| #ifdef longstring_WARN |
| int longstring; |
| #endif |
| int maxlines; |
| Rboolean active; |
| int isS4; |
| Rboolean fnarg; /* fn argument, so parenthesize = as assignment */ |
| } LocalParseData; |
| |
| static SEXP deparse1WithCutoff(SEXP call, Rboolean abbrev, int cutoff, |
| Rboolean 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 *, Rboolean do_names); |
| static void vector2buff(SEXP, LocalParseData *); |
| static void src2buff1(SEXP, LocalParseData *); |
| static Rboolean src2buff(SEXP, int, LocalParseData *); |
| static void linebreak(Rboolean *lbreak, LocalParseData *); |
| static void deparse2(SEXP, SEXP, LocalParseData *); |
| |
| // .Internal(deparse(expr, width.cutoff, backtick, .deparseOpts(control), nlines)) |
| SEXP attribute_hidden 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); |
| int backtick = isNull(CAR(args)) ? 0 : asLogical(CAR(args)); |
| 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") |
| SEXP deparse1m(SEXP call, Rboolean abbrev, int opts) |
| { |
| Rboolean 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, Rboolean abbrev, int opts) |
| { |
| Rboolean 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() */ |
| attribute_hidden |
| SEXP deparse1w(SEXP call, Rboolean abbrev, int opts) |
| { |
| Rboolean backtick = TRUE; |
| return deparse1WithCutoff(call, abbrev, R_print.cutoff, backtick, opts, -1); |
| } |
| |
| static SEXP deparse1WithCutoff(SEXP call, Rboolean abbrev, int cutoff, |
| Rboolean 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; |
| Rboolean need_ellipses = FALSE; |
| LocalParseData localData = |
| {/* linenumber */ 0, |
| 0, 0, 0, /*startline = */TRUE, 0, |
| NULL, |
| /* DeparseBuffer= */ {NULL, 0, BUFSIZE}, |
| DEFAULT_Cutoff, FALSE, 0, TRUE, |
| #ifdef longstring_WARN |
| FALSE, |
| #endif |
| /* maxlines = */ INT_MAX, |
| /* active = */TRUE, 0, FALSE}; |
| localData.cutoff = cutoff; |
| localData.backtick = backtick; |
| localData.opts = opts; |
| localData.strvec = R_NilValue; |
| |
| PrintDefaults(); /* from global options() */ |
| savedigits = R_print.digits; |
| R_print.digits = DBL_DIG;/* MAX precision */ |
| |
| 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 ... */ |
| 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 */ |
| SEXP deparse1line_(SEXP call, Rboolean abbrev, int opts) |
| { |
| Rboolean 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++) { |
| 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); |
| } |
| |
| SEXP deparse1line(SEXP call, Rboolean abbrev) |
| { |
| return deparse1line_(call, abbrev, SIMPLEDEPARSE); |
| } |
| |
| |
| // called only from ./errors.c for calls in warnings and errors : |
| SEXP attribute_hidden deparse1s(SEXP call) |
| { |
| Rboolean 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))) |
| SEXP attribute_hidden do_dput(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| |
| SEXP tval = CAR(args), |
| saveenv = R_NilValue; // -Wall |
| if (TYPEOF(tval) == CLOSXP) { |
| PROTECT(saveenv = CLOENV(tval)); |
| SET_CLOENV(tval, R_GlobalEnv); |
| } |
| int opts = isNull(CADDR(args)) ? SHOWATTRIBUTES : asInteger(CADDR(args)); |
| tval = deparse1(tval, 0, opts); |
| if (TYPEOF(CAR(args)) == CLOSXP) { |
| SET_CLOENV(CAR(args), saveenv); |
| UNPROTECT(1); |
| } |
| 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; |
| Rboolean 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")); |
| Rboolean 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)) |
| SEXP attribute_hidden 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, 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]); |
| Rboolean 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")); |
| Rboolean 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(Rboolean *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 Rboolean |
| 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 Rboolean needsparens(PPinfo mainop, SEXP arg, unsigned int left) |
| { |
| 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))); |
| switch(arginfo.kind) { |
| case PP_BINARY: /* Not all binary ops are binary! */ |
| case PP_BINARY2: |
| switch(length(CDR(arg))) { |
| case 1: |
| if (!left) |
| return FALSE; |
| if (arginfo.precedence == PREC_SUM) /* binary +/- precedence upgraded as unary */ |
| arginfo.precedence = PREC_SIGN; |
| case 2: |
| if (mainop.precedence == PREC_COMPARE && |
| arginfo.precedence == PREC_COMPARE) |
| return TRUE; /* a < b < c is not legal syntax */ |
| break; |
| default: |
| return FALSE; |
| } |
| case PP_SUBSET: |
| if (mainop.kind == PP_DOLLAR) |
| return FALSE; |
| /* fall through, don't break... */ |
| case PP_ASSIGN: |
| case PP_ASSIGN2: |
| case PP_UNARY: |
| case PP_DOLLAR: |
| /* Same as other unary operators above */ |
| if (arginfo.precedence == PREC_NOT && !left) |
| return FALSE; |
| if (mainop.precedence > arginfo.precedence |
| || (mainop.precedence == arginfo.precedence && left == mainop.rightassoc)) { |
| return TRUE; |
| } |
| break; |
| case PP_FOR: |
| case PP_IF: |
| case PP_WHILE: |
| case PP_REPEAT: |
| return left == 1; |
| break; |
| 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 Rboolean usable_nice_names(SEXP x, Rboolean isAtomic) |
| { |
| if(TYPEOF(x) == STRSXP) { |
| R_xlen_t i, n = xlength(x); |
| Rboolean 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; |
| Rboolean |
| nice_names = 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; |
| } |
| |
| static void attr2(SEXP s, LocalParseData *d, Rboolean not_names) |
| { |
| SEXP a = ATTRIB(s); |
| while(!isNull(a)) { |
| if(TAG(a) != R_SrcrefSymbol && |
| !(TAG(a) == R_NamesSymbol && not_names)) { |
| print2buff(", ", d); |
| if(TAG(a) == R_DimSymbol) { |
| print2buff(".Dim", d); |
| } |
| else if(TAG(a) == R_DimNamesSymbol) { |
| print2buff(".Dimnames", d); |
| } |
| else if(TAG(a) == R_NamesSymbol) { |
| print2buff(".Names", d); |
| } |
| else if(TAG(a) == R_TspSymbol) { |
| print2buff(".Tsp", d); |
| } |
| else if(TAG(a) == R_LevelsSymbol) { |
| print2buff(".Label", d); |
| } |
| 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); |
| Rboolean fnarg = d->fnarg; |
| d->fnarg = TRUE; |
| deparse2buff(CAR(a), d); |
| d->fnarg = fnarg; |
| } |
| a = CDR(a); |
| } |
| print2buff(")", d); |
| } |
| |
| |
| static void printcomment(SEXP s, LocalParseData *d) |
| { |
| SEXP cmt; |
| int i, ncmt; |
| const void *vmax = vmaxget(); |
| |
| /* look for old-style comments first */ |
| |
| if(isList(TAG(s)) && !isNull(TAG(s))) { |
| for (s = TAG(s); s != R_NilValue; s = CDR(s)) { |
| print2buff(translateChar(STRING_ELT(CAR(s), 0)), d); |
| writeline(d); |
| } |
| } |
| else { |
| cmt = getAttrib(s, R_CommentSymbol); |
| ncmt = length(cmt); |
| for(i = 0 ; i < ncmt ; i++) { |
| print2buff(translateChar(STRING_ELT(cmt, i)), d); |
| writeline(d); |
| } |
| } |
| vmaxset(vmax); |
| } |
| |
| |
| 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 Rboolean 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) |
| { |
| Rboolean 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; |
| |
| if (!d->active) return; |
| |
| Rboolean hasS4_t = TYPEOF(s) == S4SXP; |
| if (IS_S4_OBJECT(s) || hasS4_t) { |
| 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) |
| R_getClassDef = findFun(install("getClassDef"), R_MethodsNamespace); |
| if(R_slots == NULL) R_slots = install("slots"); |
| if(R_asS3 == NULL) R_asS3 = install("asS3"); |
| SEXP e = PROTECT(lang2(R_getClassDef, class)); |
| cl_def = PROTECT(eval(e, R_BaseEnv)); // correct env? |
| slotNms = // names( cl_def@slots ) : |
| getAttrib(R_do_slot(cl_def, R_slots), R_NamesSymbol); |
| UNPROTECT(2); // (e, cl_def) |
| int n; |
| Rboolean has_Data = FALSE;// does it have ".Data" slot? |
| if(TYPEOF(slotNms) == STRSXP && (n = LENGTH(slotNms))) { |
| PROTECT(slotNms); |
| SEXP slotlist = PROTECT(allocVector(VECSXP, n)); |
| // := structure(lapply(slotNms, slot, object=s), names=slotNms) |
| for(int i=0; i < n; i++) { |
| SEXP slot_i = STRING_ELT(slotNms, i); |
| SET_VECTOR_ELT(slotlist, i, R_do_slot(s, installTrChar(slot_i))); |
| if(!hasS4_t && !has_Data) |
| has_Data = (strcmp(CHAR(slot_i), ".Data") == 0); |
| } |
| setAttrib(slotlist, R_NamesSymbol, slotNms); |
| vec2buff(slotlist, d, TRUE); |
| /*-----------------*/ |
| UNPROTECT(2); // (slotNms, slotlist) |
| } |
| if(!hasS4_t && !has_Data) { |
| // may have *non*-slot contents, (i.e., not in .Data) |
| // ==> additionally deparse asS3(s) : |
| e = PROTECT(lang2(R_asS3, s)); // = asS3(s) |
| SEXP S3_s = PROTECT(eval(e, R_BaseEnv)); // correct env? |
| print2buff(", ", d); |
| deparse2buff(S3_s, d); |
| UNPROTECT(2); // (e, S3_s) |
| } |
| print2buff(")", d); |
| } |
| else { // exception: class is not CHARSXP |
| if(isNull(cl_def) && isNull(ATTRIB(s))) // special |
| print2buff("getClass(\"S4\")@prototype", d); |
| else { // irregular S4 ((does this ever trigger ??)) |
| d->sourceable = FALSE; |
| print2buff("<S4 object of class ", d); |
| deparse2buff(class, d); |
| print2buff(">", d); |
| } |
| } |
| /* vmaxset(vmax); */ |
| return; |
| } // if( S4 ) |
| |
| // non-S4 cases: |
| switch (TYPEOF(s)) { |
| case NILSXP: |
| print2buff("NULL", d); |
| break; |
| case SYMSXP: { |
| Rboolean |
| doquote = (d_opts_in & QUOTEEXPRESSIONS) && strlen(CHAR(PRINTNAME(s))); |
| if (doquote) { |
| attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(s, d) : SIMPLE; |
| print2buff("quote(", d); |
| } |
| if (d_opts_in & S_COMPAT) { |
| print2buff(quotify(PRINTNAME(s), '"'), d); |
| } else if (d->backtick) |
| print2buff(quotify(PRINTNAME(s), '`'), d); |
| else |
| print2buff(CHAR(PRINTNAME(s)), d); |
| if (doquote) { |
| print2buff(")", d); |
| if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); |
| } |
| break; |
| } |
| case CHARSXP: |
| { |
| const void *vmax = vmaxget(); |
| const char *ts = translateChar(s); |
| #ifdef longstring_WARN |
| /* versions of R < 2.7.0 cannot parse strings longer than 8192 chars */ |
| if(strlen(ts) >= 8192) d->longstring = TRUE; |
| #endif |
| print2buff(ts, d); |
| vmaxset(vmax); |
| break; |
| } |
| case SPECIALSXP: |
| case BUILTINSXP: |
| print2buff(".Primitive(\"", d); |
| print2buff(PRIMNAME(s), d); |
| print2buff("\")", d); |
| break; |
| case PROMSXP: |
| if(d->opts & DELAYPROMISES) { |
| d->sourceable = FALSE; |
| print2buff("<promise: ", d); |
| d->opts &= ~QUOTEEXPRESSIONS; /* don't want delay(quote()) */ |
| deparse2buff(PREXPR(s), d); |
| d->opts = d_opts_in; |
| print2buff(">", d); |
| } else { |
| PROTECT(s = eval(s, R_EmptyEnv)); /* eval uses env of promise */ |
| deparse2buff(s, d); |
| UNPROTECT(1); |
| } |
| break; |
| case CLOSXP: |
| attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(s, d) : SIMPLE; |
| if ((d->opts & USESOURCE) |
| && !isNull(t = getAttrib(s, R_SrcrefSymbol))) |
| src2buff1(t, d); |
| else { |
| /* We have established that we don't want to use the |
| source for this function */ |
| d->opts &= SIMPLE_OPTS & ~USESOURCE; |
| print2buff("function (", d); |
| args2buff(FORMALS(s), 0, 1, d); |
| print2buff(") ", d); |
| |
| writeline(d); |
| deparse2buff(BODY_EXPR(s), d); |
| d->opts = d_opts_in; |
| } |
| if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); |
| break; |
| case ENVSXP: |
| d->sourceable = FALSE; |
| print2buff("<environment>", d); |
| break; |
| case VECSXP: |
| attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(s, d) : SIMPLE; |
| print2buff("list(", d); |
| d->opts = d_opts_in;// vec2buff() must use unchanged d |
| vec2buff(s, d, attr == OK_NAMES || attr == STRUC_ATTR); |
| d->opts |= NICE_NAMES; |
| print2buff(")", d); |
| if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); |
| d->opts = d_opts_in; |
| break; |
| case EXPRSXP: |
| attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(s, d) : SIMPLE; |
| if(length(s) <= 0) |
| print2buff("expression()", d); |
| else { |
| int locOpts = d->opts; |
| print2buff("expression(", d); |
| d->opts &= SIMPLE_OPTS; |
| vec2buff(s, d, attr == OK_NAMES || attr == STRUC_ATTR); |
| d->opts = locOpts; |
| print2buff(")", d); |
| } |
| if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); |
| d->opts = d_opts_in; |
| break; |
| case LISTSXP: { |
| attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(s, d) : SIMPLE; |
| /* pairlist(x=) cannot be evaluated, hence with missings we use |
| as.pairlist(alist(...)) to allow evaluation of deparsed formals */ |
| Rboolean missing = FALSE; |
| for(t=s; t != R_NilValue; t=CDR(t)) |
| if (CAR(t) == R_MissingArg) { |
| missing = TRUE; |
| break; |
| } |
| if (missing) |
| print2buff("as.pairlist(alist(", d); |
| else |
| print2buff("pairlist(", d); |
| d->inlist++; |
| for (t=s ; CDR(t) != R_NilValue ; t=CDR(t) ) { |
| if( TAG(t) != R_NilValue ) { |
| d->opts = SIMPLEDEPARSE; /* turn off quote()ing */ |
| deparse2buff(TAG(t), d); |
| d->opts = d_opts_in; |
| print2buff(" = ", d); |
| } |
| deparse2buff(CAR(t), d); |
| print2buff(", ", d); |
| } |
| if( TAG(t) != R_NilValue ) { |
| d->opts = SIMPLEDEPARSE; /* turn off quote()ing */ |
| deparse2buff(TAG(t), d); |
| d->opts = d_opts_in; |
| print2buff(" = ", d); |
| } |
| deparse2buff(CAR(t), d); |
| if (missing) |
| print2buff("))", d); |
| else |
| print2buff(")", d); |
| d->inlist--; |
| if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); |
| break; |
| } |
| case LANGSXP: |
| printcomment(s, d); |
| if (!isNull(ATTRIB(s))) |
| d->sourceable = FALSE; |
| SEXP op = CAR(s); |
| Rboolean doquote = FALSE; |
| Rboolean maybe_quote = d_opts_in & QUOTEEXPRESSIONS; |
| if (maybe_quote) { |
| // do *not* quote() formulas: |
| doquote = // := op is not `~` (tilde) : |
| !((TYPEOF(op) == SYMSXP) && |
| !strcmp(CHAR(PRINTNAME(op)), "~")); |
| if (doquote) { |
| print2buff("quote(", d); |
| d->opts &= SIMPLE_OPTS; |
| } else { // `~` |
| d->opts &= ~QUOTEEXPRESSIONS; |
| } |
| } |
| if (TYPEOF(op) == SYMSXP) { |
| int userbinop = 0; |
| if ((TYPEOF(SYMVALUE(op)) == BUILTINSXP) || |
| (TYPEOF(SYMVALUE(op)) == SPECIALSXP) || |
| (userbinop = isUserBinop(op))) { |
| PPinfo fop; |
| Rboolean parens; |
| s = CDR(s); |
| if (userbinop) { |
| if (isNull(getAttrib(s, R_NamesSymbol))) { |
| // not quite right for spacing, but can't be unary : |
| fop.kind = PP_BINARY2; |
| fop.precedence = PREC_PERCENT; |
| fop.rightassoc = 0; |
| } else |
| // if args are named, deparse as function call (PR#15350): |
| fop.kind = PP_FUNCALL; |
| } else |
| fop = PPINFO(SYMVALUE(op)); |
| if (fop.kind == PP_BINARY) { |
| switch (length(s)) { |
| case 1: |
| fop.kind = PP_UNARY; |
| if (fop.precedence == PREC_SUM) |
| // binary +/- precedence upgraded as unary |
| fop.precedence = PREC_SIGN; |
| break; |
| case 2: |
| break; |
| default: |
| fop.kind = PP_FUNCALL; |
| break; |
| } |
| } |
| else if (fop.kind == PP_BINARY2) { |
| if (length(s) != 2) |
| fop.kind = PP_FUNCALL; |
| else if (userbinop) |
| fop.kind = PP_BINARY; |
| } |
| switch (fop.kind) { |
| case PP_IF: |
| print2buff("if (", d); |
| /* print the predicate */ |
| deparse2buff(CAR(s), d); |
| print2buff(") ", d); |
| if (d->incurly && !d->inlist ) { |
| lookahead = curlyahead(CAR(CDR(s))); |
| if (!lookahead) { |
| writeline(d); |
| d->indent++; |
| } |
| } |
| /* need to find out if there is an else */ |
| if (length(s) > 2) { |
| deparse2buff(CAR(CDR(s)), d); |
| if (d->incurly && !d->inlist) { |
| writeline(d); |
| if (!lookahead) |
| d->indent--; |
| } |
| else |
| print2buff(" ", d); |
| print2buff("else ", d); |
| deparse2buff(CAR(CDDR(s)), d); |
| } |
| else { |
| deparse2buff(CAR(CDR(s)), d); |
| if (d->incurly && !lookahead && !d->inlist ) |
| d->indent--; |
| } |
| break; |
| case PP_WHILE: |
| print2buff("while (", d); |
| deparse2buff(CAR(s), d); |
| print2buff(") ", d); |
| deparse2buff(CADR(s), d); |
| break; |
| case PP_FOR: |
| print2buff("for (", d); |
| deparse2buff(CAR(s), d); |
| print2buff(" in ", d); |
| deparse2buff(CADR(s), d); |
| print2buff(") ", d); |
| deparse2buff(CADR(CDR(s)), d); |
| break; |
| case PP_REPEAT: |
| print2buff("repeat ", d); |
| deparse2buff(CAR(s), d); |
| break; |
| case PP_CURLY: |
| print2buff("{", d); |
| d->incurly += 1; |
| d->indent++; |
| writeline(d); |
| while (s != R_NilValue) { |
| deparse2buff(CAR(s), d); |
| writeline(d); |
| s = CDR(s); |
| } |
| d->indent--; |
| print2buff("}", d); |
| d->incurly -= 1; |
| break; |
| case PP_PAREN: |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| print2buff(")", d); |
| break; |
| case PP_SUBSET: |
| if ((parens = needsparens(fop, CAR(s), 1))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| if (PRIMVAL(SYMVALUE(op)) == 1) |
| print2buff("[", d); |
| else |
| print2buff("[[", d); |
| args2buff(CDR(s), 0, 0, d); |
| if (PRIMVAL(SYMVALUE(op)) == 1) |
| print2buff("]", d); |
| else |
| print2buff("]]", d); |
| break; |
| case PP_FUNCALL: |
| case PP_RETURN: |
| if (d->backtick) |
| print2buff(quotify(PRINTNAME(op), '`'), d); |
| else |
| print2buff(quotify(PRINTNAME(op), '"'), d); |
| print2buff("(", d); |
| d->inlist++; |
| args2buff(s, 0, 0, d); |
| d->inlist--; |
| print2buff(")", d); |
| break; |
| case PP_FOREIGN: |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff("(", d); |
| d->inlist++; |
| args2buff(s, 1, 0, d); |
| d->inlist--; |
| print2buff(")", d); |
| break; |
| case PP_FUNCTION: |
| printcomment(s, d); |
| if (!(d->opts & USESOURCE) || !isString(CADDR(s))) { |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff("(", d); |
| args2buff(FORMALS(s), 0, 1, d); |
| print2buff(") ", d); |
| deparse2buff(CADR(s), d); |
| } else { |
| s = CADDR(s); |
| n = length(s); |
| const void *vmax = vmaxget(); |
| for(i = 0 ; i < n ; i++) { |
| print2buff(translateChar(STRING_ELT(s, i)), d); |
| writeline(d); |
| } |
| vmaxset(vmax); |
| } |
| break; |
| case PP_ASSIGN: |
| case PP_ASSIGN2: { |
| Rboolean outerparens = fnarg && !strcmp(CHAR(PRINTNAME(op)), "="); |
| if (outerparens) |
| print2buff("(", d); |
| if ((parens = needsparens(fop, CAR(s), 1))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| print2buff(" ", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff(" ", d); |
| if ((parens = needsparens(fop, CADR(s), 0))) |
| print2buff("(", d); |
| deparse2buff(CADR(s), d); |
| if (parens) |
| print2buff(")", d); |
| if (outerparens) |
| print2buff(")", d); |
| break; |
| } |
| case PP_DOLLAR: |
| if ((parens = needsparens(fop, CAR(s), 1))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| /*temp fix to handle printing of x$a's */ |
| if( isString(CADR(s)) && |
| isValidName(CHAR(STRING_ELT(CADR(s), 0)))) |
| deparse2buff(STRING_ELT(CADR(s), 0), d); |
| else { |
| if ((parens = needsparens(fop, CADR(s), 0))) |
| print2buff("(", d); |
| deparse2buff(CADR(s), d); |
| if (parens) |
| print2buff(")", d); |
| } |
| break; |
| case PP_BINARY: |
| if ((parens = needsparens(fop, CAR(s), 1))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| print2buff(" ", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff(" ", d); |
| linebreak(&lbreak, d); |
| if ((parens = needsparens(fop, CADR(s), 0))) |
| print2buff("(", d); |
| deparse2buff(CADR(s), d); |
| if (parens) |
| print2buff(")", d); |
| if (lbreak) { |
| d->indent--; |
| lbreak = FALSE; |
| } |
| break; |
| case PP_BINARY2: /* no space between op and args */ |
| if ((parens = needsparens(fop, CAR(s), 1))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| if ((parens = needsparens(fop, CADR(s), 0))) |
| print2buff("(", d); |
| deparse2buff(CADR(s), d); |
| if (parens) |
| print2buff(")", d); |
| break; |
| case PP_UNARY: |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| if ((parens = needsparens(fop, CAR(s), 0))) |
| print2buff("(", d); |
| deparse2buff(CAR(s), d); |
| if (parens) |
| print2buff(")", d); |
| break; |
| case PP_BREAK: |
| print2buff("break", d); |
| break; |
| case PP_NEXT: |
| print2buff("next", d); |
| break; |
| case PP_SUBASS: |
| if(d->opts & S_COMPAT) { |
| print2buff("\"", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff("\'(", d); |
| } else { |
| print2buff("`", d); |
| print2buff(CHAR(PRINTNAME(op)), d); /* ASCII */ |
| print2buff("`(", d); |
| } |
| args2buff(s, 0, 0, d); |
| print2buff(")", d); |
| break; |
| default: |
| d->sourceable = FALSE; |
| UNIMPLEMENTED("deparse2buff"); |
| } |
| } |
| else { |
| SEXP val = R_NilValue; /* -Wall */ |
| if (isSymbol(CAR(s))) { |
| val = SYMVALUE(CAR(s)); |
| if (TYPEOF(val) == PROMSXP) |
| val = eval(val, R_BaseEnv); |
| } |
| if ( isSymbol(CAR(s)) |
| && TYPEOF(val) == CLOSXP |
| && streql(CHAR(PRINTNAME(CAR(s))), "::") ) { // :: is special case |
| deparse2buff(CADR(s), d); |
| print2buff("::", d); |
| deparse2buff(CADDR(s), d); |
| } |
| else if ( isSymbol(CAR(s)) |
| && TYPEOF(val) == CLOSXP |
| && streql(CHAR(PRINTNAME(CAR(s))), ":::") ) { // ::: is special case |
| deparse2buff(CADR(s), d); |
| print2buff(":::", d); |
| deparse2buff(CADDR(s), d); |
| } |
| else { |
| if ( isSymbol(CAR(s)) ){ |
| if(d->opts & S_COMPAT) |
| print2buff(quotify(PRINTNAME(CAR(s)), '\''), d); |
| else |
| print2buff(quotify(PRINTNAME(CAR(s)), '`'), d); |
| } |
| else |
| deparse2buff(CAR(s), d); |
| print2buff("(", d); |
| args2buff(CDR(s), 0, 0, d); |
| print2buff(")", d); |
| } |
| } |
| } // end{op : SYMSXP } |
| else if (TYPEOF(op) == CLOSXP || TYPEOF(op) == SPECIALSXP |
| || TYPEOF(op) == BUILTINSXP) { |
| if (parenthesizeCaller(op)) { |
| print2buff("(", d); |
| deparse2buff(op, d); |
| print2buff(")", d); |
| } else |
| deparse2buff(op, d); |
| print2buff("(", d); |
| args2buff(CDR(s), 0, 0, d); |
| print2buff(")", d); |
| } |
| else { /* we have a lambda expression */ |
| if (parenthesizeCaller(op)) { |
| print2buff("(", d); |
| deparse2buff(op, d); |
| print2buff(")", d); |
| } else |
| deparse2buff(op, d); |
| print2buff("(", d); |
| args2buff(CDR(s), 0, 0, d); |
| print2buff(")", d); |
| } |
| if (maybe_quote) { |
| d->opts = d_opts_in; |
| if(doquote) |
| print2buff(")", d); |
| } |
| break; // end{case LANGSXP} --------------------------------------------- |
| case STRSXP: |
| case LGLSXP: |
| case INTSXP: |
| case REALSXP: |
| case CPLXSXP: |
| case RAWSXP: |
| vector2buff(s, d); |
| break; |
| case EXTPTRSXP: |
| { |
| char tpb[32]; /* need 12+2+2*sizeof(void*) */ |
| d->sourceable = FALSE; |
| snprintf(tpb, 32, "<pointer: %p>", R_ExternalPtrAddr(s)); |
| tpb[31] = '\0'; |
| print2buff(tpb, d); |
| } |
| break; |
| case BCODESXP: |
| d->sourceable = FALSE; |
| print2buff("<bytecode>", d); |
| break; |
| case WEAKREFSXP: |
| d->sourceable = FALSE; |
| print2buff("<weak reference>", d); |
| break; |
| case S4SXP: { |
| error("'S4SXP': should not happen - please report"); |
| break; |
| } |
| default: |
| d->sourceable = FALSE; |
| UNIMPLEMENTED_TYPE("deparse2buff", s); |
| } |
| } |
| |
| |
| /* If there is a string array active point to that, and */ |
| /* otherwise we are counting lines so don't do anything. */ |
| |
| static void writeline(LocalParseData *d) |
| { |
| if (d->strvec != R_NilValue && d->linenumber < d->maxlines) |
| SET_STRING_ELT(d->strvec, d->linenumber, mkChar(d->buffer.data)); |
| d->linenumber++; |
| if (d->linenumber >= d->maxlines) d->active = FALSE; |
| /* reset */ |
| d->len = 0; |
| d->buffer.data[0] = '\0'; |
| d->startline = TRUE; |
| } |
| |
| static void print2buff(const char *strng, LocalParseData *d) |
| { |
| size_t tlen, bufflen; |
| |
| if (d->startline) { |
| d->startline = FALSE; |
| printtab2buff(d->indent, d); /*if at the start of a line tab over */ |
| } |
| tlen = strlen(strng); |
| R_AllocStringBuffer(0, &(d->buffer)); |
| bufflen = strlen(d->buffer.data); |
| R_AllocStringBuffer(bufflen + tlen, &(d->buffer)); |
| strcat(d->buffer.data, strng); |
| d->len += (int) tlen; |
| } |
| |
| /* |
| * Encodes a complex value as a syntactically correct |
| * string that can be reparsed by R. This is required |
| * because by default strings like '1+Infi' or '3+NaNi' |
| * are produced which are not valid complex literals. |
| */ |
| |
| #define NB 1000 /* Same as printutils.c */ |
| #define NB2 2*NB+25 |
| static const char *EncodeNonFiniteComplexElement(Rcomplex x, char* buff) |
| { |
| int w, d, e, wi, di, ei; |
| |
| // format a first time to get width/decimals |
| formatComplex(&x, 1, &w, &d, &e, &wi, &di, &ei, 0); |
| |
| char Re[NB]; |
| char Im[NB]; |
| |
| strcpy(Re, EncodeReal0(x.r, w, d, e, ".")); |
| strcpy(Im, EncodeReal0(x.i, wi, di, ei, ".")); |
| |
| snprintf(buff, NB2, "complex(real=%s, imaginary=%s)", Re, Im); |
| buff[NB2-1] = '\0'; |
| return buff; |
| } |
| |
| static void deparse2buf_name(SEXP nv, int i, LocalParseData *d) { |
| if (!isNull(nv) && !isNull(STRING_ELT(nv, i)) |
| && *CHAR(STRING_ELT(nv, i))) { /* length test */ |
| /* d->opts = SIMPLEDEPARSE; This seems pointless */ |
| if(isValidName(translateChar(STRING_ELT(nv, i)))) |
| deparse2buff(STRING_ELT(nv, i), d); |
| else if(d->backtick) { |
| print2buff("`", d); |
| deparse2buff(STRING_ELT(nv, i), d); |
| print2buff("`", d); |
| } else { |
| print2buff("\"", d); |
| deparse2buff(STRING_ELT(nv, i), d); |
| print2buff("\"", d); |
| } |
| /* d->opts = d_opts_in; */ |
| print2buff(" = ", d); |
| } |
| } |
| |
| // deparse atomic vectors : |
| static void vector2buff(SEXP vector, LocalParseData *d) |
| { |
| // Known here: TYPEOF(vector) is one of the 6 atomic *SXPs |
| const char *strp; |
| char *buff = 0, hex[64]; // 64 is more than enough |
| int i, d_opts_in = d->opts, |
| tlen = length(vector), |
| quote = isString(vector) ? '"' : 0; |
| Rboolean surround = FALSE, allNA, |
| intSeq = FALSE; // := TRUE iff integer sequence 'm:n' (up *or* down) |
| if(TYPEOF(vector) == INTSXP) { |
| int *vec = INTEGER(vector), d_i; |
| intSeq = (tlen > 1 && |
| vec[0] != NA_INTEGER && |
| vec[1] != NA_INTEGER && |
| abs(d_i = vec[1] - vec[0]) == 1); |
| if(intSeq) for(i = 2; i < tlen; i++) { |
| if((vec[i] == NA_INTEGER) || (vec[i] - vec[i-1]) != d_i) { |
| intSeq = FALSE; |
| break; |
| } |
| } |
| } |
| |
| SEXP nv = R_NilValue; |
| Rboolean do_names = d_opts_in & SHOW_ATTR_OR_NMS;// iff TRUE use '<tag_i> = <comp_i>' |
| if(do_names) { |
| nv = getAttrib(vector, R_NamesSymbol); // only "do names" if have names: |
| if(isNull(nv)) |
| do_names = FALSE; |
| } |
| Rboolean |
| STR_names, // if true, use structure(.,*) for names even if(nice_names) |
| need_c = tlen > 1; // (?) only TRUE iff SHOW_ATTR_OR_NMS |
| STR_names = do_names && (intSeq || tlen == 0); |
| #ifdef DEBUG_DEPARSE |
| REprintf("vector2buff(v): length(v) = %d; initial (do|STR)_names) = (%s,%s)\n", |
| tlen, ChTF(do_names), ChTF(STR_names)); |
| #endif |
| if (STR_names) // use structure(.,*) for names even if(nice_names) |
| d->opts &= ~NICE_NAMES; |
| attr_type attr = (d_opts_in & SHOW_ATTR_OR_NMS) ? attr1(vector, d) : SIMPLE; |
| if(do_names) do_names = (attr == OK_NAMES || attr == STRUC_ATTR); |
| if(!need_c) need_c = do_names; // c(a = *) but not c(1) |
| #ifdef DEBUG_DEPARSE |
| REprintf(" -> final (do|STR)_names) = (%s,%s), attr = %s\n", |
| ChTF(do_names), ChTF(STR_names), attrT2char(attr)); |
| #endif |
| if (tlen == 0) { |
| switch(TYPEOF(vector)) { |
| case LGLSXP: print2buff("logical(0)", d); break; |
| case INTSXP: print2buff("integer(0)", d); break; |
| case REALSXP: print2buff("numeric(0)", d); break; |
| case CPLXSXP: print2buff("complex(0)", d); break; |
| case STRSXP: print2buff("character(0)", d); break; |
| case RAWSXP: print2buff("raw(0)", d); break; |
| default: UNIMPLEMENTED_TYPE("vector2buff", vector); |
| } |
| } |
| else if(TYPEOF(vector) == INTSXP) { |
| /* We treat integer separately, as S_compatible is relevant. |
| |
| Also, it is neat to deparse m:n in that form, |
| so we do so as from 2.5.0, and for m > n, from 3.5.0 |
| */ |
| if(intSeq) { // m:n |
| strp = EncodeElement(vector, 0, '"', '.'); |
| print2buff(strp, d); |
| print2buff(":", d); |
| strp = EncodeElement(vector, tlen - 1, '"', '.'); |
| print2buff(strp, d); |
| } else { |
| int *vec = INTEGER(vector); |
| Rboolean addL = d->opts & KEEPINTEGER & !(d->opts & S_COMPAT); |
| allNA = (d->opts & KEEPNA) || addL; |
| for(i = 0; i < tlen; i++) |
| if(vec[i] != NA_INTEGER) { |
| allNA = FALSE; |
| break; |
| } |
| if((d->opts & KEEPINTEGER && (d->opts & S_COMPAT))) { |
| print2buff("as.integer(", d); surround = TRUE; |
| } |
| allNA = allNA && !(d->opts & S_COMPAT); |
| if(need_c) print2buff("c(", d); |
| for (i = 0; i < tlen; i++) { |
| if(do_names) // put '<tag> = ' |
| deparse2buf_name(nv, i, d); |
| if(allNA && vec[i] == NA_INTEGER) { |
| print2buff("NA_integer_", d); |
| } else { |
| strp = EncodeElement(vector, i, quote, '.'); |
| print2buff(strp, d); |
| if(addL && vec[i] != NA_INTEGER) print2buff("L", d); |
| } |
| if (i < (tlen - 1)) print2buff(", ", d); |
| if (tlen > 1 && d->len > d->cutoff) writeline(d); |
| if (!d->active) break; |
| } |
| if(need_c) print2buff(")", d); |
| if(surround) print2buff(")", d); |
| } |
| } else { // tlen > 0; _not_ INTSXP |
| allNA = d->opts & KEEPNA; |
| if((d->opts & KEEPNA) && TYPEOF(vector) == REALSXP) { |
| for(i = 0; i < tlen; i++) |
| if(!ISNA(REAL(vector)[i])) { |
| allNA = FALSE; |
| break; |
| } |
| if(allNA && (d->opts & S_COMPAT)) { |
| print2buff("as.double(", d); surround = TRUE; |
| } |
| } else if((d->opts & KEEPNA) && TYPEOF(vector) == CPLXSXP) { |
| Rcomplex *vec = COMPLEX(vector); |
| for(i = 0; i < tlen; i++) { |
| if( !ISNA(vec[i].r) && !ISNA(vec[i].i) ) { |
| allNA = FALSE; |
| break; |
| } |
| } |
| if(allNA && (d->opts & S_COMPAT)) { |
| print2buff("as.complex(", d); surround = TRUE; |
| |
| } |
| } else if((d->opts & KEEPNA) && TYPEOF(vector) == STRSXP) { |
| for(i = 0; i < tlen; i++) |
| if(STRING_ELT(vector, i) != NA_STRING) { |
| allNA = FALSE; |
| break; |
| } |
| if(allNA && (d->opts & S_COMPAT)) { |
| print2buff("as.character(", d); surround = TRUE; |
| } |
| } else if(TYPEOF(vector) == RAWSXP) { |
| print2buff("as.raw(", d); surround = TRUE; |
| } |
| if(need_c) print2buff("c(", d); |
| allNA = allNA && !(d->opts & S_COMPAT); |
| for (i = 0; i < tlen; i++) { |
| if(do_names) // put '<tag> = ' |
| deparse2buf_name(nv, i, d); |
| if(allNA && TYPEOF(vector) == REALSXP && |
| ISNA(REAL(vector)[i])) { |
| strp = "NA_real_"; |
| } else if (TYPEOF(vector) == CPLXSXP && |
| (ISNA(COMPLEX(vector)[i].r) |
| && ISNA(COMPLEX(vector)[i].i)) ) { |
| strp = allNA ? "NA_complex_" : EncodeElement(vector, i, quote, '.'); |
| } else if(TYPEOF(vector) == CPLXSXP && |
| (ISNAN(COMPLEX(vector)[i].r) || !R_FINITE(COMPLEX(vector)[i].i)) ) { |
| if (!buff) |
| buff = alloca(NB2); |
| strp = EncodeNonFiniteComplexElement(COMPLEX(vector)[i], buff); |
| } else if (allNA && TYPEOF(vector) == STRSXP && |
| STRING_ELT(vector, i) == NA_STRING) { |
| strp = "NA_character_"; |
| } else if (TYPEOF(vector) == REALSXP && (d->opts & S_COMPAT)) { |
| int w, d, e; |
| formatReal(&REAL(vector)[i], 1, &w, &d, &e, 0); |
| strp = EncodeReal2(REAL(vector)[i], w, d, e); |
| } else if (TYPEOF(vector) == STRSXP) { |
| const void *vmax = vmaxget(); |
| #ifdef longstring_WARN |
| const char *ts = translateChar(STRING_ELT(vector, i)); |
| /* versions of R < 2.7.0 cannot parse strings longer than 8192 chars */ |
| if(strlen(ts) >= 8192) d->longstring = TRUE; |
| #endif |
| strp = EncodeElement(vector, i, quote, '.'); |
| vmaxset(vmax); |
| } else if (TYPEOF(vector) == RAWSXP) { |
| strp = EncodeRaw(RAW(vector)[i], "0x"); |
| } else if (TYPEOF(vector) == REALSXP && (d->opts & HEXNUMERIC)) { |
| double x = REAL(vector)[i]; |
| // Windows warns here, but incorrectly as this is C99 |
| // and the snprintf used from trio is compliant. |
| if (R_FINITE(x)) { |
| snprintf(hex, 32, "%a", x); |
| strp = hex; |
| } else |
| strp = EncodeElement(vector, i, quote, '.'); |
| } else if (TYPEOF(vector) == REALSXP && (d->opts & DIGITS16)) { |
| double x = REAL(vector)[i]; |
| if (R_FINITE(x)) { |
| snprintf(hex, 32, "%.17g", x); |
| strp = hex; |
| } else |
| strp = EncodeElement(vector, i, quote, '.'); |
| } else if (TYPEOF(vector) == CPLXSXP && (d->opts & HEXNUMERIC)) { |
| Rcomplex z = COMPLEX(vector)[i]; |
| if (R_FINITE(z.r) && R_FINITE(z.i)) { |
| snprintf(hex, 64, "%a + %ai", z.r, z.i); |
| strp = hex; |
| } else |
| strp = EncodeElement(vector, i, quote, '.'); |
| } else if (TYPEOF(vector) == CPLXSXP && (d->opts & DIGITS16)) { |
| Rcomplex z = COMPLEX(vector)[i]; |
| if (R_FINITE(z.r) && R_FINITE(z.i)) { |
| snprintf(hex, 64, "%.17g%+.17gi", z.r, z.i); |
| strp = hex; |
| } else |
| strp = EncodeElement(vector, i, quote, '.'); |
| } else |
| strp = EncodeElement(vector, i, quote, '.'); |
| print2buff(strp, d); |
| if (i < (tlen - 1)) print2buff(", ", d); |
| if (tlen > 1 && d->len > d->cutoff) writeline(d); |
| if (!d->active) break; |
| } // for(i in 1:tlen) |
| if(need_c ) print2buff(")", d); |
| if(surround) print2buff(")", d); |
| } |
| if(attr >= STRUC_ATTR) attr2(vector, d, (attr == STRUC_ATTR)); |
| if (STR_names) d->opts = d_opts_in; |
| } // vector2buff() |
| |
| |
| /* src2buff1: Deparse one source ref to buffer */ |
| |
| static void src2buff1(SEXP srcref, LocalParseData *d) |
| { |
| int i,n; |
| const void *vmax = vmaxget(); |
| PROTECT(srcref); |
| |
| PROTECT(srcref = lang2(R_AsCharacterSymbol, srcref)); |
| PROTECT(srcref = eval(srcref, R_BaseEnv)); |
| n = length(srcref); |
| for(i = 0 ; i < n ; i++) { |
| print2buff(translateChar(STRING_ELT(srcref, i)), d); |
| if(i < n-1) writeline(d); |
| } |
| UNPROTECT(3); |
| vmaxset(vmax); |
| } |
| |
| /* src2buff : Deparse source element k to buffer, if possible; return FALSE on failure */ |
| |
| static Rboolean src2buff(SEXP sv, int k, LocalParseData *d) |
| { |
| SEXP t; |
| |
| if (TYPEOF(sv) == VECSXP && length(sv) > k && !isNull(t = VECTOR_ELT(sv, k))) { |
| src2buff1(t, d); |
| return TRUE; |
| } |
| else return FALSE; |
| } |
| |
| /* Deparse vectors of S-expressions, i.e., list() and expression() objects. |
| In particular, this deparses objects of mode expression. */ |
| static void vec2buff(SEXP v, LocalParseData *d, |
| Rboolean do_names) // iff TRUE use '<tag_i> = <comp_i>' |
| { |
| Rboolean lbreak = FALSE; |
| const void *vmax = vmaxget(); |
| int n = length(v); |
| SEXP nv; |
| if(do_names) { |
| nv = getAttrib(v, R_NamesSymbol); // only "do names" if have names: |
| if (isNull(nv)) |
| do_names = FALSE; |
| } |
| |
| SEXP sv; // Srcref or NULL |
| if (d->opts & USESOURCE) { |
| sv = getAttrib(v, R_SrcrefSymbol); |
| if (TYPEOF(sv) != VECSXP) |
| sv = R_NilValue; |
| } else |
| sv = R_NilValue; |
| |
| for(int i = 0 ; i < n ; i++) { |
| if (i > 0) |
| print2buff(", ", d); |
| linebreak(&lbreak, d); |
| if(do_names) // put '<tag> = ' |
| deparse2buf_name(nv, i, d); |
| if (!src2buff(sv, i, d)) |
| deparse2buff(VECTOR_ELT(v, i), d); |
| } |
| if (lbreak) |
| d->indent--; |
| vmaxset(vmax); |
| } |
| |
| static void args2buff(SEXP arglist, int lineb, int formals, LocalParseData *d) |
| { |
| Rboolean lbreak = FALSE; |
| |
| while (arglist != R_NilValue) { |
| if (TYPEOF(arglist) != LISTSXP && TYPEOF(arglist) != LANGSXP) |
| error(_("badly formed function expression")); |
| if (TAG(arglist) != R_NilValue) { |
| SEXP s = TAG(arglist); |
| |
| if( s == R_DotsSymbol ) |
| print2buff(CHAR(PRINTNAME(s)), d); |
| else if(d->backtick) |
| print2buff(quotify(PRINTNAME(s), '`'), d); |
| else |
| print2buff(quotify(PRINTNAME(s), '"'), d); |
| |
| if(formals) { |
| if (CAR(arglist) != R_MissingArg) { |
| print2buff(" = ", d); |
| d->fnarg = TRUE; |
| deparse2buff(CAR(arglist), d); |
| } |
| } |
| else { |
| print2buff(" = ", d); |
| if (CAR(arglist) != R_MissingArg) { |
| d->fnarg = TRUE; |
| deparse2buff(CAR(arglist), d); |
| } |
| } |
| } |
| else { |
| d->fnarg = TRUE; |
| deparse2buff(CAR(arglist), d); |
| } |
| arglist = CDR(arglist); |
| if (arglist != R_NilValue) { |
| print2buff(", ", d); |
| linebreak(&lbreak, d); |
| } |
| } |
| if (lbreak) |
| d->indent--; |
| } |
| |
| /* This code controls indentation. Used to follow the S style, */ |
| /* (print 4 tabs and then start printing spaces only) but I */ |
| /* modified it to be closer to emacs style (RI). */ |
| |
| static void printtab2buff(int ntab, LocalParseData *d) |
| { |
| int i; |
| |
| for (i = 1; i <= ntab; i++) |
| if (i <= 4) |
| print2buff(" ", d); |
| else |
| print2buff(" ", d); |
| } |