The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

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

 */

#ifdef HAVE_CONFIG_H

#include <config.h>

#endif

#define R_USE_SIGNALS 1

#include <Defn.h>

/* -> Errormsg.h , R_ext/Error.h */

#include <Internal.h>

#include <Startup.h> /* rather cleanup ..*/

#include <Rconnections.h>

#include <Rinterface.h>

#include <R_ext/GraphicsEngine.h> /* for GEonExit */

#include <Rmath.h> /* for imax2 */

#include <R_ext/Print.h>

#include <stdarg.h>

/* eval() sets R_Visible = TRUE. Thas may not be wanted when eval() is

   used in C code. This is a version that saves/restores R_Visible.

   This should probably be moved to eval.c, be make public, and used

   in  more places. LT */

static SEXP evalKeepVis(SEXP e, SEXP rho)

{

    Rboolean oldvis = R_Visible;

    SEXP val = eval(e, rho);

    R_Visible = oldvis;

    return val;

}

#ifndef min

#define min(a, b) (a<b?a:b)

#endif

#ifndef max

#define max(a, b) (a>b?a:b)

#endif

/* Total line length, in chars, before splitting in warnings/errors */

#define LONGWARN 75

/*

Different values of inError are used to indicate different places

in the error handling:

inError = 1: In internal error handling, e.g. `verrorcall_dflt`, others.

inError = 2: Writing traceback

inError = 3: In user error handler (i.e. options(error=handler))

*/

static int inError = 0;

static int inWarning = 0;

static int inPrintWarnings = 0;

static int immediateWarning = 0;

static int noBreakWarning = 0;

static void try_jump_to_restart(void);

// The next is crucial to the use of NORET attributes.

NORET static void 

jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);

static void signalInterrupt(void);

static char * R_ConciseTraceback(SEXP call, int skip);

/* Interface / Calling Hierarchy :

  R__stop()   -> do_error ->   errorcall --> (eventually) jump_to_top_ex

			 /

		    error

  R__warning()-> do_warning   -> warningcall -> if(warn >= 2) errorcall

			     /

		    warning /

  ErrorMessage()-> errorcall   (but with message from ErrorDB[])

  WarningMessage()-> warningcall (but with message from WarningDB[]).

*/

NORET void R_SignalCStackOverflow(intptr_t usage)

{

    /* We do need some stack space to process error recovery, so

       temporarily raise the limit.  We have 5% head room because we

       reduced R_CStackLimit to 95% of the initial value in

       setup_Rmainloop.

    */

    if (R_OldCStackLimit == 0) {

	R_OldCStackLimit = R_CStackLimit;

	R_CStackLimit = (uintptr_t) (R_CStackLimit / 0.95);

    }

    SEXP cond = R_makeCStackOverflowError(R_NilValue, usage);

    PROTECT(cond);

    /* calling handlers at this point might produce a C stack

       overflow/SEGFAULT so treat them as failed and skip them */

    /* use R_NilValue as the call to avoid using stack in deparsing */

    R_signalErrorConditionEx(cond, R_NilValue, TRUE);

    UNPROTECT(1); /* cond; not reached */

}

void attribute_no_sanitizer_instrumentation (R_CheckStack)(void)

{

    int dummy;

    intptr_t usage = R_CStackDir * (R_CStackStart - (uintptr_t)&dummy);

    /* printf("usage %ld\n", usage); */

    if(R_CStackLimit != -1 && usage > ((intptr_t) R_CStackLimit))

	R_SignalCStackOverflow(usage);

}

void attribute_no_sanitizer_instrumentation R_CheckStack2(size_t extra)

{

    int dummy;

    intptr_t usage = R_CStackDir * (R_CStackStart - (uintptr_t)&dummy);

    if (INTPTR_MAX - usage < extra)

	/* addition would overflow, this is definitely too much */

	R_SignalCStackOverflow(INTPTR_MAX);

    /* do it this way, as some compilers do usage + extra

       in unsigned arithmetic */

    usage += extra;

    if(R_CStackLimit != -1 && usage > ((intptr_t) R_CStackLimit))

	R_SignalCStackOverflow(usage);

}

void R_CheckUserInterrupt(void)

{

    R_CheckStack();

    /* Don't do any processing of interrupts, timing limits, or other

       asynchronous events if interrupts are suspended. */

    if (R_interrupts_suspended) return;

    /* This is the point where GUI systems need to do enough event

       processing to determine whether there is a user interrupt event

       pending.  Need to be careful not to do too much event

       processing though: if event handlers written in R are allowed

       to run at this point then we end up with concurrent R

       evaluations and that can cause problems until we have proper

       concurrency support. LT */

    R_ProcessEvents(); /* Also processes timing limits */

    if (R_interrupts_pending) onintr();

}

static SEXP getInterruptCondition(void);

static void addInternalRestart(RCNTXT *, const char *);

static void onintrEx(Rboolean resumeOK)

{

    if (R_interrupts_suspended) {

	R_interrupts_pending = 1;

	return;

    }

    else R_interrupts_pending = 0;

    if (resumeOK) {

	SEXP rho = R_GlobalContext->cloenv;

	int dbflag = RDEBUG(rho);

	RCNTXT restartcontext;

	begincontext(&restartcontext, CTXT_RESTART, R_NilValue, R_GlobalEnv,

		     R_BaseEnv, R_NilValue, R_NilValue);

	if (SETJMP(restartcontext.cjmpbuf)) {

	    SET_RDEBUG(rho, dbflag); /* in case browser() has messed with it */

	    R_ReturnedValue = R_NilValue;

	    R_Visible = FALSE;

	    endcontext(&restartcontext);

	    return;

	}

	addInternalRestart(&restartcontext, "resume");

	signalInterrupt();

	endcontext(&restartcontext);

    }

    else signalInterrupt();

    /* Interrupts do not inherit from error, so we should not run the

       user error handler. But we have been, so as a transition,

       continue to use options('error') if options('interrupt') is not

       set */

    Rboolean tryUserError = GetOption1(install("interrupt")) == R_NilValue;

    REprintf("\n");

    /* Attempt to save a traceback, show warnings, and reset console;

       also stop at restart (try/browser) frames.  Not clear this is

       what we really want, but this preserves current behavior */

    jump_to_top_ex(TRUE, tryUserError, TRUE, TRUE, FALSE);

}

void onintr(void)  { onintrEx(TRUE); }

void onintrNoResume(void) { onintrEx(FALSE); }

/* SIGUSR1: save and quit

   SIGUSR2: save and quit, don't run .Last or on.exit().

   These do far more processing than is allowed in a signal handler ....

*/

attribute_hidden void onsigusr1(int dummy)

{

    if (R_interrupts_suspended) {

	/**** ought to save signal and handle after suspend */

	REprintf(_("interrupts suspended; signal ignored"));

	signal(SIGUSR1, onsigusr1);

	return;

    }

    inError = 1;

    if(R_CollectWarnings) PrintWarnings();

    R_ResetConsole();

    R_FlushConsole();

    R_ClearerrConsole();

    R_ParseError = 0;

    R_ParseErrorFile = NULL;

    R_ParseErrorMsg[0] = '\0';

    /* Bail out if there is a browser/try on the stack--do we really

       want this?  No, as from R 2.4.0

    try_jump_to_restart(); */

    /* Run all onexit/cend code on the stack (without stopping at

       intervening CTXT_TOPLEVEL's.  Since intervening CTXT_TOPLEVEL's

       get used by what are conceptually concurrent computations, this

       is a bit like telling all active threads to terminate and clean

       up on the way out. */

    R_run_onexits(NULL);

    R_CleanUp(SA_SAVE, 2, 1); /* quit, save,  .Last, status=2 */

}

attribute_hidden void onsigusr2(int dummy)

{

    inError = 1;

    if (R_interrupts_suspended) {

	/**** ought to save signal and handle after suspend */

	REprintf(_("interrupts suspended; signal ignored"));

	signal(SIGUSR2, onsigusr2);

	return;

    }

    if(R_CollectWarnings) PrintWarnings();

    R_ResetConsole();

    R_FlushConsole();

    R_ClearerrConsole();

    R_ParseError = 0;

    R_ParseErrorFile = NULL;

    R_ParseErrorMsg[0] = '\0';

    R_CleanUp(SA_SAVE, 0, 0);

}

static void setupwarnings(void)

{

    R_Warnings = allocVector(VECSXP, R_nwarnings);

    setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, R_nwarnings));

}

/* Rvsnprintf_mbcs: like vsnprintf, but guaranteed to null-terminate and not to

   split multi-byte characters, except if size is zero in which case the buffer

   is untouched and thus may not be null-terminated.

   This function may be invoked by the error handler via REvprintf.  Do not

   change it unless you are SURE that your changes are compatible with the

   error handling mechanism.

   REvprintf is also used in R_Suicide on Unix.

   Dangerous pattern: `Rvsnprintf_mbcs(buf, size - n, )` with n >= size */

#ifdef Win32

int trio_vsnprintf(char *buffer, size_t bufferSize, const char *format,

		   va_list args);

attribute_hidden

int Rvsnprintf_mbcs(char *buf, size_t size, const char *format, va_list ap)

{

    int val;

    val = trio_vsnprintf(buf, size, format, ap);

    if (size) {

	if (val < 0) buf[0] = '\0'; /* not all uses check val < 0 */

	else buf[size-1] = '\0';

	if (val >= size)

	    mbcsTruncateToValid(buf);

    }

    return val;

}

#else

attribute_hidden

int Rvsnprintf_mbcs(char *buf, size_t size, const char *format, va_list ap)

{

    int val;

    val = vsnprintf(buf, size, format, ap);

    if (size) {

	if (val < 0) buf[0] = '\0'; /* not all uses check val < 0 */

	else buf[size-1] = '\0';

	if (val >= size)

	    mbcsTruncateToValid(buf);

    }

    return val;

}

#endif

/* Rsnprintf_mbcs: like snprintf, but guaranteed to null-terminate and

   not to split multi-byte characters, except if size is zero in which

   case the buffer is untouched and thus may not be null-terminated.

   Dangerous pattern: `Rsnprintf_mbcs(buf, size - n, )` with maybe n >= size*/

attribute_hidden

int Rsnprintf_mbcs(char *str, size_t size, const char *format, ...)

{

    int val;

    va_list ap;

    va_start(ap, format);

    val = Rvsnprintf_mbcs(str, size, format, ap);

    va_end(ap);

    return val;

}

/* Rstrncat: like strncat, but guaranteed not to split multi-byte characters */

static char *Rstrncat(char *dest, const char *src, size_t n)

{

    size_t after;

    size_t before = strlen(dest);

    strncat(dest, src, n);

    after = strlen(dest);

    if (after - before == n)

	/* the string may have been truncated, but we cannot know for sure

	   because str may not be null terminated */

	mbcsTruncateToValid(dest + before);

    return dest;

}

/* Rstrncpy: like strncpy, but guaranteed to null-terminate and not to

   split multi-byte characters */

static char *Rstrncpy(char *dest, const char *src, size_t n)

{

    strncpy(dest, src, n);

    if (n) {

	dest[n-1] = '\0';

	mbcsTruncateToValid(dest);

    }

    return dest;

}

#define BUFSIZE 8192

static R_INLINE void RprintTrunc(char *buf, int truncated)

{

    if (truncated) {

	char *msg = _("[... truncated]");

	if (strlen(buf) + 1 + strlen(msg) < BUFSIZE) {

	    strcat(buf, " ");

	    strcat(buf, msg);

	}

    }

}

static SEXP getCurrentCall(void)

{

    RCNTXT *c = R_GlobalContext;

    /* This can be called before R_GlobalContext is defined, so... */

    /* If profiling is on, this can be a CTXT_BUILTIN */

    if (c && (c->callflag & CTXT_BUILTIN)) c = c->nextcontext;

    if (c == R_GlobalContext && R_BCIntActive)

	return R_getBCInterpreterExpression();

    else

	return c ? c->call : R_NilValue;

}

void warning(const char *format, ...)

{

    char buf[BUFSIZE], *p;

    va_list(ap);

    va_start(ap, format);

    size_t psize;

    int pval;

    psize = min(BUFSIZE, R_WarnLength+1);

    pval = Rvsnprintf_mbcs(buf, psize, format, ap);

    va_end(ap);

    p = buf + strlen(buf) - 1;

    if(strlen(buf) > 0 && *p == '\n') *p = '\0';

    RprintTrunc(buf, pval >= psize);

    SEXP call = PROTECT(getCurrentCall());

    warningcall(call, "%s", buf);

    UNPROTECT(1);

}

/* declarations for internal condition handling */

static void vsignalError(SEXP call, const char *format, va_list ap);

static void vsignalWarning(SEXP call, const char *format, va_list ap);

NORET static void invokeRestart(SEXP, SEXP);

static void reset_inWarning(void *data)

{

    inWarning = 0;

}

#include <rlocale.h>

static int wd(const char * buf)

{

    int nc = (int) mbstowcs(NULL, buf, 0), nw;

    if(nc > 0 && nc < 2000) {

	wchar_t wc[2000];

	mbstowcs(wc, buf, nc + 1);

	// FIXME: width could conceivably exceed MAX_INT.

#ifdef USE_RI18N_WIDTH

	nw = Ri18n_wcswidth(wc, 2147483647);

#else

	nw = wcswidth(wc, 2147483647);

#endif

	return (nw < 0) ? nc : nw;

    }

    return nc;

}

static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)

{

    int w;

    SEXP names, s;

    const char *dcall;

    char buf[BUFSIZE];

    RCNTXT *cptr;

    RCNTXT cntxt;

    size_t psize;

    int pval;

    if (inWarning)

	return;

    s = GetOption1(install("warning.expression"));

    if( s != R_NilValue ) {

	if( !isLanguage(s) &&  ! isExpression(s) )

	    error(_("invalid option \"warning.expression\""));

	cptr = R_GlobalContext;

	while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag )

	    cptr = cptr->nextcontext;

	evalKeepVis(s, cptr->cloenv);

	return;

    }

    w = asInteger(GetOption1(install("warn")));

    if( w == NA_INTEGER ) /* set to a sensible value */

	w = 0;

    if( w <= 0 && immediateWarning ) w = 1;

    if( w < 0 || inWarning || inError) /* ignore if w<0 or already in here*/

	return;

    /* set up a context which will restore inWarning if there is an exit */

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

		 R_NilValue, R_NilValue);

    cntxt.cend = &reset_inWarning;

    inWarning = 1;

    if(w >= 2) { /* make it an error */

	psize = min(BUFSIZE, R_WarnLength+1);

	pval = Rvsnprintf_mbcs(buf, psize, format, ap);

	RprintTrunc(buf, pval >= psize);

	inWarning = 0; /* PR#1570 */

	errorcall(call, _("(converted from warning) %s"), buf);

    }

    else if(w == 1) {	/* print as they happen */

	char *tr;

	if( call != R_NilValue ) {

	    dcall = CHAR(STRING_ELT(deparse1s(call), false));

	} else dcall = "";

	psize = min(BUFSIZE, R_WarnLength+1);

	pval = Rvsnprintf_mbcs(buf, psize, format, ap);

	RprintTrunc(buf, pval >= psize);

	if(dcall[0] == '\0') REprintf(_("Warning:"));

	else {

	    REprintf(_("Warning in %s :"), dcall);

	    // This did not allow for buf containing line breaks

	    // We can put the first line on the same line as the warning

	    // if it fits within LONGWARN.

	    char buf1[BUFSIZE];

	    strncpy(buf1, buf, BUFSIZE);

	    char *p = strstr(buf1, "\n");

	    if(p) *p = '\0';

	    if(!(noBreakWarning ||

		 ( mbcslocale && (18 + wd(dcall) + wd(buf1) <= LONGWARN)) ||

		 (!mbcslocale && (18 + strlen(dcall) + strlen(buf1) <= LONGWARN))))

		REprintf("\n ");

	}

	REprintf(" %s\n", buf);

	if(R_ShowWarnCalls && call != R_NilValue) {

	    tr = R_ConciseTraceback(call, 0);

	    if (strlen(tr)) {REprintf(_("Calls:")); REprintf(" %s\n", tr);}

	}

    }

    else if(w == 0) {	/* collect them */

	if(!R_CollectWarnings) setupwarnings();

	if(R_CollectWarnings < R_nwarnings) {

	    SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);

	    psize = min(BUFSIZE, R_WarnLength+1);

	    pval = Rvsnprintf_mbcs(buf, psize, format, ap);

	    RprintTrunc(buf, pval >= psize);

	    if(R_ShowWarnCalls && call != R_NilValue) {

		char *tr =  R_ConciseTraceback(call, 0);

		size_t nc = strlen(tr);

		if (nc && nc + (int)strlen(buf) + 8 < BUFSIZE) {

		    strcat(buf, "\n");

		    strcat(buf, _("Calls:"));

		    strcat(buf, " ");

		    strcat(buf, tr);

		}

	    }

	    names = CAR(ATTRIB(R_Warnings));

	    SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));

	}

    }

    /* else:  w <= -1 */

    endcontext(&cntxt);

    inWarning = 0;

}

static void warningcall_dflt(SEXP call, const char *format,...)

{

    va_list(ap);

    va_start(ap, format);

    vwarningcall_dflt(call, format, ap);

    va_end(ap);

}

void warningcall(SEXP call, const char *format, ...)

{

    va_list(ap);

    va_start(ap, format);

    vsignalWarning(call, format, ap);

    va_end(ap);

}

void warningcall_immediate(SEXP call, const char *format, ...)

{

    va_list(ap);

    immediateWarning = 1;

    va_start(ap, format);

    vsignalWarning(call, format, ap);

    va_end(ap);

    immediateWarning = 0;

}

static void cleanup_PrintWarnings(void *data)

{

    if (R_CollectWarnings) {

	R_CollectWarnings = 0;

	R_Warnings = R_NilValue;

	REprintf(_("Lost warning messages\n"));

    }

    inPrintWarnings = 0;

}

attribute_hidden

void PrintWarnings(void)

{

    int i;

    char *header;

    SEXP names, s, t;

    RCNTXT cntxt;

    if (R_CollectWarnings == 0)

	return;

    else if (inPrintWarnings) {

	if (R_CollectWarnings) {

	    R_CollectWarnings = 0;

	    R_Warnings = R_NilValue;

	    REprintf(_("Lost warning messages\n"));

	}

	return;

    }

    /* set up a context which will restore inPrintWarnings if there is

       an exit */

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

		 R_NilValue, R_NilValue);

    cntxt.cend = &cleanup_PrintWarnings;

    inPrintWarnings = 1;

    header = ngettext("Warning message:", "Warning messages:",

		      R_CollectWarnings);

    if( R_CollectWarnings == 1 ) {

	REprintf("%s\n", header);

	names = CAR(ATTRIB(R_Warnings));

	if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )

	    REprintf("%s \n", CHAR(STRING_ELT(names, 0)));

	else {

	    const char *msg = CHAR(STRING_ELT(names, 0));

	    const char *dcall = CHAR(STRING_ELT(deparse1s(VECTOR_ELT(R_Warnings, 0)), 0));

	    REprintf(_("In %s :"), dcall);

	    if (mbcslocale) {

		int msgline1;

		if (strchr(msg, '\n')) {

		    // this branch alters msg temporarily

		    char msg1[strlen(msg) + 1];

		    strcpy(msg1, msg);

		    char *p = strchr(msg1, '\n');

		    *p = '\0';

		    msgline1 = wd(msg1);

		} else msgline1 = wd(msg);

		if (6 + wd(dcall) + msgline1 > LONGWARN) REprintf("\n ");

		REprintf(" %s\n", msg);

	    } else {

		size_t msgline1 = strlen(msg);

		const char *p = strchr(msg, '\n');

		if (p) msgline1 = (int)(p - msg);

		if (6 + strlen(dcall) + msgline1 > LONGWARN) REprintf("\n ");

		REprintf(" %s\n", msg);

	    }

	}

    } else if( R_CollectWarnings <= 10 ) {

	REprintf("%s\n", header);

	names = CAR(ATTRIB(R_Warnings));

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

	    if( VECTOR_ELT(R_Warnings, i) == R_NilValue ) {

		REprintf("%d: %s \n", i+1, CHAR(STRING_ELT(names, i)));

	    } else {

		const char *dcall, *msg = CHAR(STRING_ELT(names, i));

		dcall = CHAR(STRING_ELT(deparse1s(VECTOR_ELT(R_Warnings, i)), 0));

		REprintf("%d: ", i + 1);

		REprintf(_("In %s :"), dcall);

		if (mbcslocale) {

		    int msgline1;

		    if (strchr(msg, '\n')) {

			// this branch alters msg temporarily

			char msg1[strlen(msg) + 1];

			strcpy(msg1, msg);

			char *p = strchr(msg1, '\n');

			*p = '\0';

			msgline1 = wd(msg1);

		    } else msgline1 = wd(msg);

		    if (10 + wd(dcall) + msgline1 > LONGWARN) {

			REprintf("\n ");

		    }

		} else {

		    size_t msgline1 = strlen(msg);

		    const char *p = strchr(msg, '\n');

		    if (p) msgline1 = (int)(p - msg);

		    if (10 + strlen(dcall) + msgline1 > LONGWARN) {

			REprintf("\n ");

		    }

		}

		REprintf(" %s\n", msg);

	    }

	}

    } else {

	if (R_CollectWarnings < R_nwarnings)

	    REprintf(ngettext("There was %d warning (use warnings() to see it)",

			      "There were %d warnings (use warnings() to see them)",

			      R_CollectWarnings),

		     R_CollectWarnings);

	else

	    REprintf(_("There were %d or more warnings (use warnings() to see the first %d)"),

		     R_nwarnings, R_nwarnings);

	REprintf("\n");

    }

    /* now truncate and install last.warning */

    PROTECT(s = allocVector(VECSXP, R_CollectWarnings));

    PROTECT(t = allocVector(STRSXP, R_CollectWarnings));

    names = CAR(ATTRIB(R_Warnings));

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

	SET_VECTOR_ELT(s, i, VECTOR_ELT(R_Warnings, i));

	SET_STRING_ELT(t, i, STRING_ELT(names, i));

    }

    setAttrib(s, R_NamesSymbol, t);

    SET_SYMVALUE(install("last.warning"), s);

    UNPROTECT(2);

    endcontext(&cntxt);

    inPrintWarnings = 0;

    R_CollectWarnings = 0;

    R_Warnings = R_NilValue;

    return;

}

/* Return a constructed source location (e.g. filename#123) from a srcref.  If the srcref

   is not valid "" will be returned.

*/

static SEXP GetSrcLoc(SEXP srcref)

{

    SEXP sep, line, result, srcfile;

    if (TYPEOF(srcref) != INTSXP || length(srcref) < 4)

	return ScalarString(mkChar(""));

    PROTECT(srcref);

    PROTECT(srcfile = R_GetSrcFilename(srcref));

    SEXP e2 = PROTECT(lang2( install("basename"), srcfile));

    PROTECT(srcfile = eval(e2, R_BaseEnv ) );

    PROTECT(sep = ScalarString(mkChar("#")));

    PROTECT(line = ScalarInteger(INTEGER(srcref)[0]));

    SEXP e = PROTECT(lang4( install("paste0"), srcfile, sep, line ));

    result = eval(e, R_BaseEnv );

    UNPROTECT(7);

    return result;

}

static char errbuf[BUFSIZE + 1]; /* add 1 to leave room for a null byte */

#define ERRBUFCAT(txt) Rstrncat(errbuf, txt, BUFSIZE - strlen(errbuf))

const char *R_curErrorBuf(void) {

    return (const char *)errbuf;

}

static void restore_inError(void *data)

{

    int *poldval = (int *) data;

    inError = *poldval;

    R_Expressions = R_Expressions_keep;

}

/* Do not check constants on error more than this number of times per one

   R process lifetime; if so many errors are generated, the performance

   overhead due to the checks would be too high, and the program is doing

   something strange anyway (i.e. running no-segfault tests). The constant

   checks in GC and session exit (or .Call) do not have such limit. */

static int allowedConstsChecks = 1000;

/* Construct newline terminated error message, write it to global errbuf, and

   possibly display with REprintf. */

NORET static void

verrorcall_dflt(SEXP call, const char *format, va_list ap)

{

    if (allowedConstsChecks > 0) {

	allowedConstsChecks--;

	R_checkConstants(TRUE);

    }

    if (inError) {

	/* fail-safe handler for recursive errors */

	if(inError == 3) {

	     /* Can REprintf generate an error? If so we should guard for it */

	    REprintf(_("Error during wrapup: "));

	    /* this does NOT try to print the call since that could

	       cause a cascade of error calls */

	    Rvsnprintf_mbcs(errbuf, sizeof(errbuf), format, ap);

	    REprintf("%s\n", errbuf);

	}

	if (R_Warnings != R_NilValue) {

	    R_CollectWarnings = 0;

	    R_Warnings = R_NilValue;

	    REprintf(_("Lost warning messages\n"));

	}

	REprintf(_("Error: no more error handlers available "

		   "(recursive errors?); invoking 'abort' restart\n"));

	R_Expressions = R_Expressions_keep;

	jump_to_top_ex(FALSE, FALSE, FALSE, FALSE, FALSE);

    }

    /* set up a context to restore inError value on exit */

    RCNTXT cntxt;

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

		 R_NilValue, R_NilValue);

    int oldInError;

    cntxt.cend = &restore_inError;

    cntxt.cenddata = &oldInError;

    oldInError = inError;

    inError = 1;

    // For use with Rv?snprintf, which truncates at size - 1, hence the + 1

    size_t msg_len = min(BUFSIZE, R_WarnLength) + 1;

    if(call != R_NilValue) {

	char tmp[BUFSIZE], tmp2[BUFSIZE];

	char *head = _("Error in "), *tail = "\n  ";

	SEXP srcloc = R_NilValue; // -Wall

	size_t len = 0;	// indicates if srcloc has been set

	int protected = 0, show = 0;

	SEXP opt = GetOption1(install("show.error.locations"));

	if (length(opt) == 1 &&

	    (asLogical(opt) == 1 ||

	     (TYPEOF(opt) == STRSXP &&

	      pmatch(ScalarString(mkChar("top")), opt, 0))))

	    	show = 1;

	const char *dcall = CHAR(STRING_ELT(deparse1s(call), 0));

	Rsnprintf_mbcs(tmp2, BUFSIZE,  "%s", head);

	if (show) {

	    PROTECT(srcloc = GetSrcLoc(R_GetCurrentSrcref(NA_INTEGER)));

	    protected++;

	    len = strlen(CHAR(STRING_ELT(srcloc, 0)));

	    if (len)

		Rsnprintf_mbcs(tmp2, BUFSIZE,  _("Error in %s (from %s) : "),

			       dcall, CHAR(STRING_ELT(srcloc, 0)));

	}

	Rvsnprintf_mbcs(tmp, max(msg_len - strlen(head), 0), format, ap);

	if (strlen(tmp2) + strlen(tail) + strlen(tmp) < BUFSIZE) {

	    if(len) Rsnprintf_mbcs(errbuf, BUFSIZE,

				   _("Error in %s (from %s) : "),

				   dcall, CHAR(STRING_ELT(srcloc, 0)));

	    else Rsnprintf_mbcs(errbuf, BUFSIZE,  _("Error in %s : "), dcall);

	    if (mbcslocale) {

		int msgline1;

		// tmp is local array, so OK to temporaily edit in place

		char *p = strchr(tmp, '\n');

		if (p) {

		    *p = '\0';

		    msgline1 = wd(tmp);

		    *p = '\n';

		} else msgline1 = wd(tmp);

		// gcc 8 warns here

		// 'output may be truncated copying between 0 and 8191 bytes from a string of length 8191'

		// but truncation is intentional.

		if (14 + wd(dcall) + msgline1 > LONGWARN)

		    ERRBUFCAT(tail);

	    } else {

		size_t msgline1 = strlen(tmp);

		const char *p = strchr(tmp, '\n');

		if (p) msgline1 = (int)(p - tmp);

		if (14 + strlen(dcall) + msgline1 > LONGWARN)

		    ERRBUFCAT(tail);

	    }

	    ERRBUFCAT(tmp);

	} else {

	    Rsnprintf_mbcs(errbuf, BUFSIZE, _("Error: "));

	    ERRBUFCAT(tmp);

	}

	UNPROTECT(protected);

    }

    else {

	Rsnprintf_mbcs(errbuf, BUFSIZE, _("Error: "));

	char *p = errbuf + strlen(errbuf);

	Rvsnprintf_mbcs(p, max(msg_len - strlen(errbuf), 0), format, ap);

    }

    /* Approximate truncation detection, may produce false positives.  Assumes

       R_MB_CUR_MAX > 0. Note: approximation is fine, as the string may include

       dots, anyway */

    size_t nc = strlen(errbuf); // > 0, ignoring possibility of failure

    if (nc > BUFSIZE - 1 - (R_MB_CUR_MAX - 1)) {

	size_t end = min(nc + 1, (BUFSIZE + 1) - 4); // room for "...\n\0"

	for(size_t i = end; i <= BUFSIZE + 1; ++i) errbuf[i - 1] = '\0';

	mbcsTruncateToValid(errbuf);

	ERRBUFCAT("...\n");

    } else {

	char *p = errbuf + nc - 1;

	if(*p != '\n') {

	    ERRBUFCAT("\n");  // guaranteed to have room for this

	    ++nc;

	}

	if(R_ShowErrorCalls && call != R_NilValue) {  /* assume we want to avoid deparse */

	    char *tr = R_ConciseTraceback(call, 0);

	    size_t nc_tr = strlen(tr);

	    if (nc_tr) {

		char * call_trans = _("Calls:");

		if (nc_tr + nc + strlen(call_trans) + 2 < BUFSIZE + 1) {

		    ERRBUFCAT(call_trans);

		    ERRBUFCAT(" ");

		    ERRBUFCAT(tr);

		    ERRBUFCAT("\n");

		}

	    }

	}

    }

    if (R_ShowErrorMessages) REprintf("%s", errbuf);

    if( R_ShowErrorMessages && R_CollectWarnings ) {

	REprintf(_("In addition: "));

	PrintWarnings();

    }

    jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);

    /* not reached */

    endcontext(&cntxt);

    inError = oldInError;

}

NORET static void errorcall_dflt(SEXP call, const char *format,...)

{

    va_list(ap);

    va_start(ap, format);

    verrorcall_dflt(call, format, ap);

    va_end(ap);

}

NORET void errorcall(SEXP call, const char *format,...)

{

    va_list(ap);

    if (call == R_CurrentExpression)

	/* behave like error( */

	call = getCurrentCall();

    va_start(ap, format);

    vsignalError(call, format, ap);

    va_end(ap);

    va_start(ap, format);

    verrorcall_dflt(call, format, ap);

    va_end(ap);

}

/* Like errorcall, but copies all data for the error message into a buffer

   before doing anything else. */

NORET attribute_hidden

void errorcall_cpy(SEXP call, const char *format, ...)

{

    char buf[BUFSIZE];

    va_list(ap);

    va_start(ap, format);

    Rvsnprintf_mbcs(buf, BUFSIZE, format, ap);

    va_end(ap);