The R Project SVN – R – Diff – /branches/djm-source/src/main/errors.c


/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2007  The R Development 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, write to the Free Software
 *  Foundation, Inc., 51 Franklin Street Fifth Floor, Boston, MA 02110-1301  USA
 */
 
/* <UTF8> char here is either ASCII or handled as a whole */
 
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
 
/* Now in Defn.h
#ifdef HAVE_AQUA
extern void R_ProcessEvents(void);
#endif
*/
 
#include <Defn.h>
/* -> Errormsg.h */
#include <Startup.h> /* rather cleanup ..*/
#include <Rconnections.h>
#include <Rinterface.h>
#include <R_ext/GraphicsDevice.h>
#include <R_ext/GraphicsEngine.h> /* for GEonExit */
#include <Rmath.h> /* for imax2 */
#if  !( defined(HAVE_AQUA) || defined(Win32) )
#include <R_ext/eventloop.h> /* for R_PolledEvents */
#endif
 
#ifndef min
#define min(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.
*/
static int inError = 0;
static int inWarning = 0;
static int inPrintWarnings = 0;
static int immediateWarning = 0;
 
static void try_jump_to_restart(void);
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 --> 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[]).
*/
 
static void reset_stack_limit(void *data)
{
    unsigned int *limit = (unsigned int *) data;
    R_CStackLimit = *limit;
}
 
void R_CheckStack(void)
{
    int dummy;
    long usage = R_CStackDir * (R_CStackStart - (unsigned long)&dummy);
 
    /* printf("usage %ld\n", usage); */
    if(R_CStackLimit != -1 && usage > 0.95 * R_CStackLimit) {
	/* We do need some stack space to process error recovery,
	   so temporarily raise the limit.
	 */
	RCNTXT cntxt;
	unsigned int stacklimit = R_CStackLimit;
	R_CStackLimit += 0.05*R_CStackLimit;
	begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
		     R_NilValue, R_NilValue);
	cntxt.cend = &reset_stack_limit;
	cntxt.cenddata = &stacklimit;
	
        errorcall(R_NilValue, "C stack usage is too close to the limit");
	/* Do not translate this, to save stack space */
    }
}
 
void R_CheckUserInterrupt(void)
{
    R_CheckStack();
    /* 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 */
#if  ( defined(HAVE_AQUA) || defined(Win32) )
    R_ProcessEvents();
#else
    R_PolledEvents();
    if (R_interrupts_pending)
	onintr();
#endif /* Win32 */
}
 
void onintr()
{
    if (R_interrupts_suspended) {
	R_interrupts_pending = 1;
	return;
    }
    else R_interrupts_pending = 0;
    signalInterrupt();
 
    REprintf("\n");
    /* Attempt to run user error option, 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, TRUE, TRUE, TRUE, 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 ....
*/
 
RETSIGTYPE attribute_hidden 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 */
}
 
 
RETSIGTYPE attribute_hidden 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, 50);
    setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, 50));
}
 
/* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate. */
static int Rvsnprintf(char *buf, size_t size, const char  *format, va_list ap)
{
    int val;
    val = vsnprintf(buf, size, format, ap);
    buf[size-1] = '\0';
    return val;
}
 
#define BUFSIZE 8192
void warning(const char *format, ...)
{
    char buf[BUFSIZE], *p;
    RCNTXT *c = R_GlobalContext;
 
    va_list(ap);
    va_start(ap, format);
    Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);
    va_end(ap);
    p = buf + strlen(buf) - 1;
    if(strlen(buf) > 0 && *p == '\n') *p = '\0';
    if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)
	strcat(buf, " [... truncated]");
    if (c && (c->callflag & CTXT_BUILTIN)) c = c->nextcontext;
    warningcall(c ? c->call : R_NilValue, "%s", buf);
}
 
/* temporary hook to allow experimenting with alternate warning mechanisms */
static void (*R_WarningHook)(SEXP, char *) = NULL;
 
/* 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);
static void invokeRestart(SEXP, SEXP);
 
static void reset_inWarning(void *data)
{
    inWarning = 0;
}
 
#ifdef SUPPORT_MBCS
#include <R_ext/rlocale.h>
 
static int wd(const char * buf)
{
    int nc = mbstowcs(NULL, buf, 0), nw;
    if(nc > 0 && nc < 2000) {
	wchar_t wc[2000];
	mbstowcs(wc, buf, nc + 1);
	nw = Ri18n_wcswidth(wc, 2147483647);
	return (nw < 1) ? nc : nw;
    }
    return nc;
}
#endif
 
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;
 
    if (inWarning)
	return;
 
    s = GetOption(install("warning.expression"), R_BaseEnv);
    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;
	eval(s, cptr->cloenv);
	return;
    }
 
    w = asInteger(GetOption(install("warn"), R_BaseEnv));
 
    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 */
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
	if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)
	    strcat(buf, " [... truncated]");
	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(deparse1(call, 0, DEFAULTDEPARSE), 0));
	} else dcall = "";
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);
	if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)
	    strcat(buf, " [... truncated]");
	if(dcall[0] == '\0')
	    REprintf(_("Warning: %s\n"), buf);
#ifdef SUPPORT_MBCS
	else if(mbcslocale &&
		18 + wd(dcall) + wd(buf) <= LONGWARN)
	    REprintf(_("Warning in %s : %s\n"), dcall, buf);
#endif
	else if(18+strlen(dcall)+strlen(buf) <= LONGWARN)
	    REprintf(_("Warning in %s : %s\n"), dcall, buf);
	else
	    REprintf(_("Warning in %s :\n  %s\n"), dcall, buf);
	if(R_ShowWarnCalls && call != R_NilValue) {
	    tr = R_ConciseTraceback(call, 0);
	    if (strlen(tr)) REprintf("Calls: %s\n", tr);
	}
    }
    else if(w == 0) {	/* collect them */
	char *tr; int nc; 
	if(!R_CollectWarnings)
	    setupwarnings();
	if( R_CollectWarnings > 49 )
	    return;
	SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);
	if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)
	    strcat(buf, " [... truncated]");
	if(R_ShowWarnCalls && call != R_NilValue) {
	    tr =  R_ConciseTraceback(call, 0); nc = strlen(tr);
	    if (nc && nc + strlen(buf) + 8 < BUFSIZE) {
		strcat(buf, "\nCalls: "); 
		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);
    vwarningcall_dflt(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;
}
 
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 = P_("Warning message:\n", "Warning messages:\n", R_CollectWarnings);
    if( R_CollectWarnings == 1 ) {
	REprintf("%s", 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 *dcall, *sep = " ", *msg = CHAR(STRING_ELT(names, 0));
	    dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0),
					     0, DEFAULTDEPARSE), 0));
#ifdef SUPPORT_MBCS
	    if (mbcslocale) {
		int msgline1;
		char *p = strchr(msg, '\n');
		if (p) {
		    *p = '\0';
		    msgline1 = wd(msg);
		    *p = '\n';
		} else msgline1 = wd(msg);
		if (6 + wd(dcall) + msgline1 > LONGWARN) sep = "\n  ";
	    } else
#endif
	    {
		int msgline1 = strlen(msg);
		char *p = strchr(msg, '\n');
		if (p) msgline1 = (int)(p - msg);
		if (6+strlen(dcall) + msgline1 > LONGWARN) sep = "\n  ";
	    }
	    REprintf("In %s :%s%s\n", dcall, sep, msg);
	}
    } else if( R_CollectWarnings <= 10 ) {
	REprintf("%s", 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, *sep = " ", *msg = CHAR(STRING_ELT(names, i));
		dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, i),
						 0, DEFAULTDEPARSE), 0));
#ifdef SUPPORT_MBCS
		if (mbcslocale) {
		    int msgline1;
		    char *p = strchr(msg, '\n');
		    if (p) {
			*p = '\0';
			msgline1 = wd(msg);
			*p = '\n';
		    } else msgline1 = wd(msg);
		    if (10 + wd(dcall) + msgline1 > LONGWARN) sep = "\n  ";
		} else
#endif
		{
		    int msgline1 = strlen(msg);
		    char *p = strchr(msg, '\n');
		    if (p) msgline1 = (int)(p - msg);
		    if (10+strlen(dcall) + msgline1 > LONGWARN) sep = "\n  ";
		}
		REprintf("%d: In %s :%s%s\n", i+1, dcall, sep, msg);
	    }
	}
    } else {
	if (R_CollectWarnings < 50)
	    REprintf(_("There were %d warnings (use warnings() to see them)\n"),
		     R_CollectWarnings);
	else
	    REprintf(_("There were 50 or more warnings (use warnings() to see the first 50)\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;
}
 
static char errbuf[BUFSIZE];
 
/* temporary hook to allow experimenting with alternate error mechanisms */
static void (*R_ErrorHook)(SEXP, char *) = NULL;
 
static void restore_inError(void *data)
{
    int *poldval = (int *) data;
    inError = *poldval;
    R_Expressions = R_Expressions_keep;
}
 
static void verrorcall_dflt(SEXP call, const char *format, va_list ap)
{
    RCNTXT cntxt;
    const char *dcall;
    char *p, *tr;
    int oldInError, nc;
 
    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(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"));
	}
	R_Expressions = R_Expressions_keep;
	jump_to_top_ex(FALSE, FALSE, FALSE, FALSE, FALSE);
    }
 
    /* set up a context to restore inError value on exit */
    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
		 R_NilValue, R_NilValue);
    cntxt.cend = &restore_inError;
    cntxt.cenddata = &oldInError;
    oldInError = inError;
    inError = 1;
 
    if(call != R_NilValue) {
	char tmp[BUFSIZE];
	char *head = _("Error in "), *mid = " : ", *tail = "\n  ";
	int len = strlen(head) + strlen(mid) + strlen(tail);
 
	Rvsnprintf(tmp, min(BUFSIZE, R_WarnLength) - strlen(head), format, ap);
	dcall = CHAR(STRING_ELT(deparse1(call, 0, DEFAULTDEPARSE), 0));
	if (len + strlen(dcall) + strlen(tmp) < BUFSIZE) {
	    sprintf(errbuf, "%s%s%s", head, dcall, mid);
#ifdef SUPPORT_MBCS
	    if (mbcslocale) {
		int msgline1;
		char *p = strchr(tmp, '\n');
		if (p) {
		    *p = '\0';
		    msgline1 = wd(tmp);
		    *p = '\n';
		} else msgline1 = wd(tmp);
		if (14 + wd(dcall) + wd(tmp) > LONGWARN) strcat(errbuf, tail);
	    } else
#endif
	    {
		int msgline1 = strlen(tmp);
		char *p = strchr(tmp, '\n');
		if (p) msgline1 = (int)(p - tmp);
		if (14 + strlen(dcall) + msgline1 > LONGWARN)
		    strcat(errbuf, tail);
	    }
	    strcat(errbuf, tmp);
	} else {
	    sprintf(errbuf, _("Error: "));
	    strcat(errbuf, tmp);
	}
    }
    else {
	sprintf(errbuf, _("Error: "));
	p = errbuf + strlen(errbuf);
	Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);
    }
    
    p = errbuf + strlen(errbuf) - 1;
    if(*p != '\n') strcat(errbuf, "\n");
 
    if(R_ShowErrorCalls && call != R_NilValue) {  /* assume we want to avoid deparse */
	tr = R_ConciseTraceback(call, 0); nc = strlen(tr);
	if (nc && nc + strlen(errbuf) + 8 < BUFSIZE) {
	    strcat(errbuf, "Calls: ");
	    strcat(errbuf, tr);
	    strcat(errbuf, "\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;
}
 
static void errorcall_dflt(SEXP call, const char *format,...)
{
    va_list(ap);
 
    va_start(ap, format);
    verrorcall_dflt(call, format, ap);
    va_end(ap);
}
 
void errorcall(SEXP call, const char *format,...)
{
    va_list(ap);
 
    va_start(ap, format);
    vsignalError(call, format, ap);
    va_end(ap);
 
    if (R_ErrorHook != NULL) {
	char buf[BUFSIZE];
	void (*hook)(SEXP, char *) = R_ErrorHook;
	R_ErrorHook = NULL; /* to avoid recursion */
	va_start(ap, format);
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
	va_end(ap);
	hook(call, buf);
    }
 
    va_start(ap, format);
    verrorcall_dflt(call, format, ap);
    va_end(ap);
}
 
SEXP attribute_hidden do_geterrmessage(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP res;
 
    checkArity(op, args);
    PROTECT(res = allocVector(STRSXP, 1));
    SET_STRING_ELT(res, 0, mkChar(errbuf));
    UNPROTECT(1);
    return res;
}
 
void error(const char *format, ...)
{
    char buf[BUFSIZE];
    RCNTXT *c = R_GlobalContext;
 
    va_list(ap);
    va_start(ap, format);
    Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
    va_end(ap);
    /* 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;
    errorcall(c ? c->call : R_NilValue, "%s", buf);
}
 
static void try_jump_to_restart(void)
{
    SEXP list;
 
    for (list = R_RestartStack; list != R_NilValue; list = CDR(list)) {
	SEXP restart = CAR(list);
	if (TYPEOF(restart) == VECSXP && LENGTH(restart) > 1) {
	    SEXP name = VECTOR_ELT(restart, 0);
	    if (TYPEOF(name) == STRSXP && LENGTH(name) == 1) {
		const char *cname = CHAR(STRING_ELT(name, 0));
		if (! strcmp(cname, "browser") ||
		    ! strcmp(cname, "tryRestart") ||
		    ! strcmp(cname, "abort")) /**** move abort eventually? */
		    invokeRestart(restart, R_NilValue);
	    }
	}
    }
}
 
/* Unwind the call stack in an orderly fashion */
/* calling the code installed by on.exit along the way */
/* and finally longjmping to the innermost TOPLEVEL context */
 
static void jump_to_top_ex(Rboolean traceback,
			   Rboolean tryUserHandler,
			   Rboolean processWarnings,
			   Rboolean resetConsole,
			   Rboolean ignoreRestartContexts)
{
    RCNTXT cntxt;
    SEXP s;
    int haveHandler, oldInError;
 
    /* set up a context to restore inError value on exit */
    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
		 R_NilValue, R_NilValue);
    cntxt.cend = &restore_inError;
    cntxt.cenddata = &oldInError;
 
    oldInError = inError;
 
    haveHandler = FALSE;
 
    if (tryUserHandler && inError < 3) {
	if (! inError)
	    inError = 1;
 
	/*now see if options("error") is set */
	s = GetOption(install("error"), R_BaseEnv);
	haveHandler = ( s != R_NilValue );
	if (haveHandler) {
	    if( !isLanguage(s) &&  ! isExpression(s) )  /* shouldn't happen */
		REprintf(_("invalid option \"error\"\n"));
	    else {
		inError = 3;
		if (isLanguage(s))
		    eval(s, R_GlobalEnv);
		else /* expression */
		    {
			int i, n = LENGTH(s);
			for (i = 0 ; i < n ; i++)
			    eval(VECTOR_ELT(s, i), R_GlobalEnv);
		    }
		inError = oldInError;
	    }
	}
	inError = oldInError;
    }
 
    /* print warnings if there are any left to be printed */
    if( processWarnings && R_CollectWarnings )
	PrintWarnings();
 
    /* reset some stuff--not sure (all) this belongs here */
    if (resetConsole) {
	R_ResetConsole();
	R_FlushConsole();
	R_ClearerrConsole();
	R_ParseError = 0;
	R_ParseErrorFile = NULL;
	R_ParseErrorMsg[0] = '\0';	
    }
 
    /*
     * Reset graphics state
     */
    GEonExit();
 
    /* WARNING: If oldInError > 0 ABSOLUTELY NO ALLOCATION can be
       triggered after this point except whatever happens in writing
       the traceback and R_run_onexits.  The error could be an out of
       memory error and any allocation could result in an
       infinite-loop condition. All you can do is reset things and
       exit.  */
 
    /* jump to a browser/try if one is on the stack */
    if (! ignoreRestartContexts)
	try_jump_to_restart();
    /* at this point, i.e. if we have not exited in
       try_jump_to_restart, we are heading for R_ToplevelContext */
 
    /* only run traceback if we are not going to bail out of a
       non-interactive session */
    if (R_Interactive || haveHandler) {
	/* write traceback if requested, unless we're already doing it
	   or there is an inconsistency between inError and oldInError
	   (which should not happen) */
	if (traceback && inError < 2 && inError == oldInError) {
	    inError = 2;
	    PROTECT(s = R_GetTraceback(0));
	    SET_SYMVALUE(install(".Traceback"), s);
	    /* should have been defineVar
	       setVar(install(".Traceback"), s, R_GlobalEnv); */
	    UNPROTECT(1);
	    inError = oldInError;
	}
    }
 
    /* Run onexit/cend code for all contexts down to but not including
       the jump target.  This may cause recursive calls to
       jump_to_top_ex, but the possible number of such recursive
       calls is limited since each exit function is removed before it
       is executed.  In addition, all but the first should have
       inError > 0.  This is not a great design because we could run
       out of other resources that are on the stack (like C stack for
       example).  The right thing to do is arrange to execute exit
       code *after* the LONGJMP, but that requires a more extensive
       redesign of the non-local transfer of control mechanism.
       LT. */
    R_run_onexits(R_ToplevelContext);
 
    if ( !R_Interactive && !haveHandler ) {
	REprintf(_("Execution halted\n"));
	R_CleanUp(SA_NOSAVE, 1, 0); /* quit, no save, no .Last, status=1 */
    }
 
    R_GlobalContext = R_ToplevelContext;
    R_restore_globals(R_GlobalContext);
    LONGJMP(R_ToplevelContext->cjmpbuf, 0);
    /* not reached */
    endcontext(&cntxt);
    inError = oldInError;
}
 
void jump_to_toplevel()
{
    /* no traceback, no user error option; for now, warnings are
       printed here and console is reset -- eventually these should be
       done after arriving at the jump target.  Now ignores
       try/browser frames--it really is a jump to toplevel */
    jump_to_top_ex(FALSE, FALSE, TRUE, TRUE, TRUE);
}
 
/* #define DEBUG_GETTEXT 1 */
 
/* gettext(domain, string) */
SEXP attribute_hidden do_gettext(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef ENABLE_NLS
    const char *domain = "";
    char *buf;
    SEXP ans, string = CADR(args);
    int i, n = LENGTH(string);
    
    checkArity(op, args);
    if(isNull(string) || !n) return string;
 
    if(!isString(string)) errorcall(call, _("invalid '%s' value"), "string");
 
    if(isNull(CAR(args))) {
	RCNTXT *cptr;
	SEXP rho = R_BaseEnv;
	for (cptr = R_GlobalContext->nextcontext;
	     cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
	     cptr = cptr->nextcontext)
	    if (cptr->callflag & CTXT_FUNCTION) {
		rho = cptr->cloenv;
		break;
	    }
	while(rho != R_EmptyEnv) {
	    if (rho == R_GlobalEnv) break;
	    else if (R_IsNamespaceEnv(rho)) {
		domain = translateChar(STRING_ELT(R_NamespaceEnvSpec(rho), 0));
		break;
	    }
	    rho = CDR(rho);
	}
	if(strlen(domain)) {
	    buf = (char *) alloca(strlen(domain)+3);
	    R_CheckStack();
	    sprintf(buf, "R-%s", domain);
	    domain = buf;
	}
    } else if(isString(CAR(args)))
	domain = translateChar(STRING_ELT(CAR(args),0));
    else errorcall(call, _("invalid '%s' value"), "domain");
 
    if(strlen(domain)) {
	PROTECT(ans = allocVector(STRSXP, n));
	for(i = 0; i < n; i++) {
	    int ihead = 0, itail = 0;
	    const char * This = translateChar(STRING_ELT(string, i));
	    char *tmp, *head = NULL, *tail = NULL, *p, *tr;
	    tmp = (char *) alloca(strlen(This) + 1);
	    R_CheckStack();
	    strcpy(tmp, This);
	    /* strip leading and trailing white spaces and 
	       add back after translation */
	    for(p = tmp;
		*p && (*p == ' ' || *p == '\t' || *p == '\n'); 
		p++, ihead++) ;
	    if(ihead > 0) {
		head = (char *) alloca(ihead + 1);
		R_CheckStack();
		strncpy(head, tmp, ihead);
		head[ihead] = '\0';
		tmp += ihead;
		}
	    if(strlen(tmp))
		for(p = tmp+strlen(tmp)-1; 
		    p >= tmp && (*p == ' ' || *p == '\t' || *p == '\n');
		    p--, itail++) ;
	    if(itail > 0) {
		tail = (char *) alloca(itail + 1);
		R_CheckStack();
		strcpy(tail, tmp+strlen(tmp)-itail);
		tmp[strlen(tmp)-itail] = '\0';
		}
	    if(strlen(tmp)) {
#ifdef DEBUG_GETTEXT
		REprintf("translating '%s' in domain '%s'\n", tmp, domain);
#endif
		tr = dgettext(domain, tmp);
		tmp = (char *) alloca(strlen(tr) + ihead + itail + 1);
		R_CheckStack();
		tmp[0] ='\0';
		if(ihead > 0) strcat(tmp, head);
		strcat(tmp, tr);
		if(itail > 0) strcat(tmp, tail);
		SET_STRING_ELT(ans, i, mkChar(tmp));
	    } else 
		SET_STRING_ELT(ans, i, mkChar(This));
	}
	UNPROTECT(1);
	return ans;
    } else return CADR(args);
#else
    return CADR(args);
#endif
}
 
/* ngettext(n, msg1, msg2, domain) */
SEXP attribute_hidden do_ngettext(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef ENABLE_NLS
    const char *domain = "";
    char *buf;
    SEXP ans, sdom = CADDDR(args);
#endif
    SEXP msg1 = CADR(args), msg2 = CADDR(args);
    int n = asInteger(CAR(args));
    
    checkArity(op, args);
    if(n == NA_INTEGER || n < 0) error(_("invalid 'n'"));
    if(!isString(msg1) || LENGTH(msg1) != 1)
	error(_("'msg1' must be a character string"));
    if(!isString(msg2) || LENGTH(msg2) != 1)
	error(_("'msg2' must be a character string"));
 
#ifdef ENABLE_NLS
    if(isNull(sdom)) {
	RCNTXT *cptr;
	SEXP rho = R_BaseEnv;
	for (cptr = R_GlobalContext->nextcontext;
	     cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
	     cptr = cptr->nextcontext)
	    if (cptr->callflag & CTXT_FUNCTION) {
		rho = cptr->cloenv;
		break;
	    }
	while(rho != R_EmptyEnv) {
	    if (rho == R_GlobalEnv) break;
	    else if (R_IsNamespaceEnv(rho)) {
		domain = translateChar(STRING_ELT(R_NamespaceEnvSpec(rho), 0));
		break;
	    }
	    rho = CDR(rho);
	}
	if(strlen(domain)) {
	    buf = (char *) alloca(strlen(domain)+3);
	    R_CheckStack();
	    sprintf(buf, "R-%s", domain);
	    domain = buf;
	}
    } else if(isString(sdom))
	domain = CHAR(STRING_ELT(sdom,0));
    else errorcall(call, _("invalid '%s' value"), "domain");
 
    /* libintl seems to malfunction if given a message of "" */
    if(strlen(domain) && length(STRING_ELT(msg1, 0))) {
	char *fmt = dngettext(domain,
			      translateChar(STRING_ELT(msg1, 0)),
			      translateChar(STRING_ELT(msg2, 0)),
			      n);
	PROTECT(ans = mkString(fmt));
	UNPROTECT(1);
	return ans;
    } else
#endif
	return n == 1 ? msg1 : msg2;
}
 
 
/* bindtextdomain(domain, dirname) */
SEXP attribute_hidden do_bindtextdomain(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef ENABLE_NLS
    char *res;
    
    checkArity(op, args);
    if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1) 
	errorcall(call, _("invalid '%s' value"), "domain");
    if(isNull(CADR(args))) {
	res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)), NULL);
    } else {
	if(!isString(CADR(args)) || LENGTH(CADR(args)) != 1) 
	    errorcall(call, _("invalid '%s' value"), "dirname");
	res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)),
			     translateChar(STRING_ELT(CADR(args),0)));
    }
    if(res) return mkString(res);
    /* else this failed */
#endif
    return R_NilValue;
}
 
static SEXP findCall(void)
{
    RCNTXT *cptr;
    for (cptr = R_GlobalContext->nextcontext;
	 cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
	 cptr = cptr->nextcontext)
	if (cptr->callflag & CTXT_FUNCTION)
	    return cptr->call;
    return R_NilValue;
}
 
SEXP attribute_hidden do_stop(SEXP call, SEXP op, SEXP args, SEXP rho)
{
/* error(.) : really doesn't return anything; but all do_foo() must be SEXP */
    SEXP c_call;
 
    if(asLogical(CAR(args))) /* find context -> "Error in ..:" */
	c_call = findCall();
    else
	c_call = R_NilValue;    
    
    args = CDR(args);
 
    if (CAR(args) != R_NilValue) { /* message */
      SETCAR(args, coerceVector(CAR(args), STRSXP));
      if(!isValidString(CAR(args)))
	  errorcall(c_call, _(" [invalid string in stop(.)]"));
      errorcall(c_call, "%s", translateChar(STRING_ELT(CAR(args), 0)));
    }
    else
      errorcall(c_call, "");
    /* never called: */return c_call;
}
 
SEXP attribute_hidden do_warning(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP c_call;
 
    if(asLogical(CAR(args))) /* find context -> "... in: ..:" */
	c_call = findCall();
    else
	c_call = R_NilValue;
 
    args = CDR(args);
    if(asLogical(CAR(args))) { /* immediate = TRUE */
	immediateWarning = 1;
    } else 
	immediateWarning = 0;
    args = CDR(args);
    if (CAR(args) != R_NilValue) {
	SETCAR(args, coerceVector(CAR(args), STRSXP));
	if(!isValidString(CAR(args)))
	    warningcall(c_call, _(" [invalid string in warning(.)]"));
	else
	    warningcall(c_call, "%s", translateChar(STRING_ELT(CAR(args), 0)));
    }
    else
	warningcall(c_call, "");
    immediateWarning = 0; /* reset to internal calls */
 
    return CAR(args);
}
 
/* Error recovery for incorrect argument count error. */
attribute_hidden
void WrongArgCount(const char *s)
{
    error(_("incorrect number of arguments to \"%s\""), s);
}
 
 
void UNIMPLEMENTED(const char *s)
{
    error(_("unimplemented feature in %s"), s);
}
 
/* ERROR_.. codes in Errormsg.h */
static struct {
    const R_ERROR code;
    const char* const format;
}
const ErrorDB[] = {
    { ERROR_NUMARGS,		N_("invalid number of arguments")	},
    { ERROR_ARGTYPE,		N_("invalid argument type")		},
 
    { ERROR_TSVEC_MISMATCH,	N_("time-series/vector length mismatch")},
    { ERROR_INCOMPAT_ARGS,	N_("incompatible arguments")		},
 
    { ERROR_UNIMPLEMENTED,	N_("unimplemented feature in %s")	},
    { ERROR_UNKNOWN,		N_("unknown error (report this!)")	}
};
 
static struct {
    R_WARNING code;
    char* format;
}
WarningDB[] = {
    { WARNING_coerce_NA,	N_("NAs introduced by coercion")	},
    { WARNING_coerce_INACC,	N_("inaccurate integer conversion in coercion")},
    { WARNING_coerce_IMAG,	N_("imaginary parts discarded in coercion") },
 
    { WARNING_UNKNOWN,		N_("unknown warning (report this!)")	},
};
 
 
void ErrorMessage(SEXP call, int which_error, ...)
{
    int i;
    char buf[BUFSIZE];
    va_list(ap);
 
    i = 0;
    while(ErrorDB[i].code != ERROR_UNKNOWN) {
	if (ErrorDB[i].code == which_error)
	    break;
	i++;
    }
 
    va_start(ap, which_error);
    Rvsnprintf(buf, BUFSIZE, _(ErrorDB[i].format), ap);
    va_end(ap);
    errorcall(call, "%s", buf);
}
 
void WarningMessage(SEXP call, R_WARNING which_warn, ...)
{
    int i;
    char buf[BUFSIZE];
    va_list(ap);
 
    i = 0;
    while(WarningDB[i].code != WARNING_UNKNOWN) {
	if (WarningDB[i].code == which_warn)
	    break;
	i++;
    }
 
    va_start(ap, which_warn);
    Rvsnprintf(buf, BUFSIZE, _(WarningDB[i].format), ap);
    va_end(ap);
    warningcall(call, "%s", buf);
}
 
 
/* Temporary hooks to allow experimenting with alternate error and
   warning mechanisms.  They are not in the header files for now, but
   the following snippet can serve as a header file: */
 
void R_ReturnOrRestart(SEXP val, SEXP env, Rboolean restart);
void R_PrintDeferredWarnings(void);
void R_SetErrmessage(const char *s);
void R_SetErrorHook(void (*hook)(SEXP, char *));
void R_SetWarningHook(void (*hook)(SEXP, char *));
void R_JumpToToplevel(Rboolean restart);
 
 
void R_SetWarningHook(void (*hook)(SEXP, char *))
{
    R_WarningHook = hook;
}
 
void R_SetErrorHook(void (*hook)(SEXP, char *))
{
    R_ErrorHook = hook;
}
 
void R_ReturnOrRestart(SEXP val, SEXP env, Rboolean restart)
{
    int mask;
    RCNTXT *c;
 
    mask = CTXT_BROWSER | CTXT_FUNCTION;
 
    for (c = R_GlobalContext; c; c = c->nextcontext) {
	if (c->callflag & mask && c->cloenv == env)
	    findcontext(mask, env, val);
	else if (restart && IS_RESTART_BIT_SET(c->callflag))
	    findcontext(CTXT_RESTART, c->cloenv, R_RestartToken);
	else if (c->callflag == CTXT_TOPLEVEL)
	    error(_("No function to return from, jumping to top level"));
    }
}
 
void R_JumpToToplevel(Rboolean restart)
{
    RCNTXT *c;
 
    /* Find the target for the jump */
    for (c = R_GlobalContext; c != NULL; c = c->nextcontext) {
	if (restart && IS_RESTART_BIT_SET(c->callflag))
	    findcontext(CTXT_RESTART, c->cloenv, R_RestartToken);
	else if (c->callflag == CTXT_TOPLEVEL)
	    break;
    }
    if (c != R_ToplevelContext)
	warning(_("top level inconsistency?"));
 
    /* Run onexit/cend code for everything above the target. */
    R_run_onexits(c);
 
    R_ToplevelContext = R_GlobalContext = c;
    R_restore_globals(R_GlobalContext);
    LONGJMP(c->cjmpbuf, CTXT_TOPLEVEL);
}
 
void R_SetErrmessage(const char *s)
{
    strncpy(errbuf, s, sizeof(errbuf));
    errbuf[sizeof(errbuf) - 1] = 0;
}
 
void R_PrintDeferredWarnings(void)
{
    if( R_ShowErrorMessages && R_CollectWarnings ) {
        REprintf(_("In addition: "));
        PrintWarnings();
    }
}
 
SEXP R_GetTraceback(int skip)
{
    int nback = 0, ns;
    RCNTXT *c;
    SEXP s, t;
 
    for (c = R_GlobalContext, ns = skip;
	 c != NULL && c->callflag != CTXT_TOPLEVEL;
	 c = c->nextcontext)
	if (c->callflag & (CTXT_FUNCTION | CTXT_BUILTIN) ) {
	    if (ns > 0)
		ns--;
	    else
		nback++;
	}
 
    PROTECT(s = allocList(nback));
    t = s;
    for (c = R_GlobalContext ;
	 c != NULL && c->callflag != CTXT_TOPLEVEL;
	 c = c->nextcontext)
	if (c->callflag & (CTXT_FUNCTION | CTXT_BUILTIN) ) {
	    if (skip > 0)
		skip--;
	    else {
		SETCAR(t, deparse1(c->call, 0, DEFAULTDEPARSE));
		t = CDR(t);
	    }
	}
    UNPROTECT(1);
    return s;
}
\
static char * R_ConciseTraceback(SEXP call, int skip)
{
    static char buf[560];
    RCNTXT *c;
    int nl, ncalls = 0;
    Rboolean too_many = FALSE;
    const char *top = "" /* -Wall */;
 
    buf[0] = '\0';
    for (c = R_GlobalContext;
	 c != NULL && c->callflag != CTXT_TOPLEVEL;
	 c = c->nextcontext)
	if (c->callflag & (CTXT_FUNCTION | CTXT_BUILTIN) ) {
	    if (skip > 0)
		skip--;
	    else {
		SEXP fun = CAR(c->call);
		const char *this = (TYPEOF(fun) == SYMSXP) ?
		    CHAR(PRINTNAME(fun)) : "<Anonymous>";
		if(streql(this, "stop") || 
		   streql(this, "warning") || 
		   streql(this, "suppressWarnings") || 
		   streql(this, ".signalSimpleWarning")) {
		    buf[0] =  '\0'; ncalls = 0; too_many = FALSE;
		} else {
		    ncalls++;
		    if(too_many) {
			top = this;
		    } else if(strlen(buf) > R_NShowCalls) {
			memmove(buf+4, buf, strlen(buf)+1);
			memcpy(buf, "... ", 4);
			too_many = TRUE;
			top = this;
		    } else if(strlen(buf)) {
			nl = strlen(this);
			memmove(buf+nl+4, buf, strlen(buf)+1);
			memcpy(buf, this, strlen(this));
			memcpy(buf+nl, " -> ", 4);
		    } else
			memcpy(buf, this, strlen(this)+1);
		}
	    }
	}
    if(too_many && (nl = strlen(top)) < 50) {
	memmove(buf+nl+1, buf, strlen(buf)+1);
	memcpy(buf, top, strlen(top));
	memcpy(buf+nl, " ", 1);
    }
    /* don't add Calls if it adds no extra information */
    /* However: do we want to include the call in the list if it is a
       primitive? */
    if (ncalls == 1 && call != R_NilValue) {
	SEXP fun = CAR(call);
	const char *this = (TYPEOF(fun) == SYMSXP) ?
	    CHAR(PRINTNAME(fun)) : "<Anonymous>";
	if(streql(buf, this)) return "";
    }
    return buf;
}
 
 
 
static SEXP mkHandlerEntry(SEXP klass, SEXP parentenv, SEXP handler, SEXP rho,
			   SEXP result, int calling)
{
    SEXP entry = allocVector(VECSXP, 5);
    SET_VECTOR_ELT(entry, 0, klass);
    SET_VECTOR_ELT(entry, 1, parentenv);
    SET_VECTOR_ELT(entry, 2, handler);
    SET_VECTOR_ELT(entry, 3, rho);
    SET_VECTOR_ELT(entry, 4, result);
    SETLEVELS(entry, calling);
    return entry;
}
 
/**** rename these??*/
#define IS_CALLING_ENTRY(e) LEVELS(e)
#define ENTRY_CLASS(e) VECTOR_ELT(e, 0)
#define ENTRY_CALLING_ENVIR(e) VECTOR_ELT(e, 1)
#define ENTRY_HANDLER(e) VECTOR_ELT(e, 2)
#define ENTRY_TARGET_ENVIR(e) VECTOR_ELT(e, 3)
#define ENTRY_RETURN_RESULT(e) VECTOR_ELT(e, 4)
 
#define RESULT_SIZE 3
 
SEXP attribute_hidden do_addCondHands(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP classes, handlers, parentenv, target, oldstack, newstack, result;
    int calling, i, n;
    PROTECT_INDEX osi;
 
    checkArity(op, args);
 
    classes = CAR(args); args = CDR(args);
    handlers = CAR(args); args = CDR(args);
    parentenv = CAR(args); args = CDR(args);
    target = CAR(args); args = CDR(args);
    calling = asLogical(CAR(args));
 
    if (classes == R_NilValue || handlers == R_NilValue)
	return R_HandlerStack;
 
    if (TYPEOF(classes) != STRSXP || TYPEOF(handlers) != VECSXP ||
	LENGTH(classes) != LENGTH(handlers))
	error(_("bad handler data"));
 
    n = LENGTH(handlers);
    oldstack = R_HandlerStack;
 
    PROTECT(result = allocVector(VECSXP, RESULT_SIZE));
    PROTECT_WITH_INDEX(newstack = oldstack, &osi);
 
    for (i = n - 1; i >= 0; i--) {
	SEXP klass = STRING_ELT(classes, i);
	SEXP handler = VECTOR_ELT(handlers, i);
	SEXP entry = mkHandlerEntry(klass, parentenv, handler, target, result,
				    calling);
	REPROTECT(newstack = CONS(entry, newstack), osi);
    }
 
    R_HandlerStack = newstack;
    UNPROTECT(2);
 
    return oldstack;
}
 
SEXP attribute_hidden do_resetCondHands(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    R_HandlerStack = CAR(args);
    return R_NilValue;
}
 
static SEXP findSimpleErrorHandler()
{
    SEXP list;
    for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {
	SEXP entry = CAR(list);
	if (! strcmp(CHAR(ENTRY_CLASS(entry)), "simpleError") ||
	    ! strcmp(CHAR(ENTRY_CLASS(entry)), "error") ||
	    ! strcmp(CHAR(ENTRY_CLASS(entry)), "condition"))
	    return list;
    }
    return R_NilValue;
}
 
static void vsignalWarning(SEXP call, const char *format, va_list ap)
{
    char buf[BUFSIZE];
    SEXP hooksym, quotesym, hcall, qcall;
 
    hooksym = install(".signalSimpleWarning");
    quotesym = install("quote");
    if (SYMVALUE(hooksym) != R_UnboundValue &&
	SYMVALUE(quotesym) != R_UnboundValue) {
	PROTECT(qcall = LCONS(quotesym, LCONS(call, R_NilValue)));
	PROTECT(hcall = LCONS(qcall, R_NilValue));
	Rvsnprintf(buf, BUFSIZE - 1, format, ap);
	hcall = LCONS(ScalarString(mkChar(buf)), hcall);
	PROTECT(hcall = LCONS(hooksym, hcall));
	eval(hcall, R_GlobalEnv);
	UNPROTECT(3);
    }
    else vwarningcall_dflt(call, format, ap);
}
 
static void gotoExitingHandler(SEXP cond, SEXP call, SEXP entry)
{
    SEXP rho = ENTRY_TARGET_ENVIR(entry);
    SEXP result = ENTRY_RETURN_RESULT(entry);
    SET_VECTOR_ELT(result, 0, cond);
    SET_VECTOR_ELT(result, 1, call);
    SET_VECTOR_ELT(result, 2, ENTRY_HANDLER(entry));
    findcontext(CTXT_FUNCTION, rho, result);
}
 
static void vsignalError(SEXP call, const char *format, va_list ap)
{
    char localbuf[BUFSIZE];
    SEXP list, oldstack;
 
    oldstack = R_HandlerStack;
    Rvsnprintf(localbuf, BUFSIZE - 1, format, ap);
    while ((list = findSimpleErrorHandler()) != R_NilValue) {
	char *buf = errbuf;
	SEXP entry = CAR(list);
	R_HandlerStack = CDR(list);
	strncpy(buf, localbuf, BUFSIZE - 1);
	/*	Rvsnprintf(buf, BUFSIZE - 1, format, ap);*/
	buf[BUFSIZE - 1] = 0;
	if (IS_CALLING_ENTRY(entry)) {
	    if (ENTRY_HANDLER(entry) == R_RestartToken)
		return; /* go to default error handling; do not reset stack */
	    else {
		SEXP hooksym, quotesym, hcall, qcall;
		/* protect oldstack here, not outside loop, so handler
		   stack gets unwound in case error is protect stack
		   overflow */
		PROTECT(oldstack);
		hooksym = install(".handleSimpleError");
		quotesym = install("quote");
		PROTECT(qcall = LCONS(quotesym, LCONS(call, R_NilValue)));
		PROTECT(hcall = LCONS(qcall, R_NilValue));
		hcall = LCONS(ScalarString(mkChar(buf)), hcall);
		hcall = LCONS(ENTRY_HANDLER(entry), hcall);
		PROTECT(hcall = LCONS(hooksym, hcall));
		eval(hcall, R_GlobalEnv);
		UNPROTECT(4);
	    }
	}
	else gotoExitingHandler(R_NilValue, call, entry);
    }
    R_HandlerStack = oldstack;
}
 
static SEXP findConditionHandler(SEXP cond)
{
    int i;
    SEXP list;
    SEXP classes = getAttrib(cond, R_ClassSymbol);
 
    if (TYPEOF(classes) != STRSXP)
	return R_NilValue;
 
    /**** need some changes here to allow conditions to be S4 classes */
    for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {
	SEXP entry = CAR(list);
	for (i = 0; i < LENGTH(classes); i++)
	    if (! strcmp(CHAR(ENTRY_CLASS(entry)),
			 CHAR(STRING_ELT(classes, i))))
		return list;
    }
    return R_NilValue;
}
 
SEXP attribute_hidden do_signalCondition(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP list, cond, msg, ecall, oldstack;
 
    checkArity(op, args);
 
    cond = CAR(args);
    msg = CADR(args);
    ecall = CADDR(args);
 
    PROTECT(oldstack = R_HandlerStack);
    while ((list = findConditionHandler(cond)) != R_NilValue) {
	SEXP entry = CAR(list);
	R_HandlerStack = CDR(list);
	if (IS_CALLING_ENTRY(entry)) {
	    SEXP h = ENTRY_HANDLER(entry);
	    if (h == R_RestartToken) {
		const char *msgstr = NULL;
		if (TYPEOF(msg) == STRSXP && LENGTH(msg) > 0)
		    msgstr = translateChar(STRING_ELT(msg, 0));
		else error(_("error message not a string"));
		errorcall_dflt(ecall, "%s", msgstr);
	    }
	    else {
		SEXP hcall = LCONS(h, LCONS(cond, R_NilValue));
		PROTECT(hcall);
		eval(hcall, R_GlobalEnv);
		UNPROTECT(1);
	    }
	}
	else gotoExitingHandler(cond, ecall, entry);
    }
    R_HandlerStack = oldstack;
    UNPROTECT(1);
    return R_NilValue;
}
 
static SEXP findInterruptHandler()
{
    SEXP list;
    for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {
	SEXP entry = CAR(list);
	if (! strcmp(CHAR(ENTRY_CLASS(entry)), "interrupt") ||
	    ! strcmp(CHAR(ENTRY_CLASS(entry)), "condition"))
	    return list;
    }
    return R_NilValue;
}
 
static SEXP getInterruptCondition()
{
    /**** FIXME: should probably pre-allocate this */
    SEXP cond, klass;
    PROTECT(cond = allocVector(VECSXP, 0));
    PROTECT(klass = allocVector(STRSXP, 2));
    SET_STRING_ELT(klass, 0, mkChar("interrupt"));
    SET_STRING_ELT(klass, 1, mkChar("condition"));
    classgets(cond, klass);
    UNPROTECT(2);
    return cond;
}
 
static void signalInterrupt(void)
{
    SEXP list, cond, oldstack;
 
    PROTECT(oldstack = R_HandlerStack);
    while ((list = findInterruptHandler()) != R_NilValue) {
	SEXP entry = CAR(list);
	R_HandlerStack = CDR(list);
	PROTECT(cond = getInterruptCondition());
	if (IS_CALLING_ENTRY(entry)) {
	    SEXP h = ENTRY_HANDLER(entry);
	    SEXP hcall = LCONS(h, LCONS(cond, R_NilValue));
	    PROTECT(hcall);
	    eval(hcall, R_GlobalEnv);
	    UNPROTECT(1);
	}
	else gotoExitingHandler(cond, R_NilValue, entry);
	UNPROTECT(1);
    }
    R_HandlerStack = oldstack;
    UNPROTECT(1);
}
 
void attribute_hidden
R_InsertRestartHandlers(RCNTXT *cptr, Rboolean browser)
{
    SEXP klass, rho, entry, name;
 
    if ((cptr->handlerstack != R_HandlerStack ||
	 cptr->handlerstack != R_HandlerStack)) {
	if (IS_RESTART_BIT_SET(cptr->callflag))
	    return;
	else
	    error(_("handler or restart stack mismatch in old restart"));
    }
 
    /**** need more here to keep recursive errors in browser? */
    rho = cptr->cloenv;
    PROTECT(klass = mkChar("error"));
    entry = mkHandlerEntry(klass, rho, R_RestartToken, rho, R_NilValue, TRUE);
    R_HandlerStack = CONS(entry, R_HandlerStack);
    UNPROTECT(1);
    PROTECT(name = ScalarString(mkChar(browser ? "browser" : "tryRestart")));
    PROTECT(entry = allocVector(VECSXP, 2));
    PROTECT(SET_VECTOR_ELT(entry, 0, name));
    SET_VECTOR_ELT(entry, 1, R_MakeExternalPtr(cptr, R_NilValue, R_NilValue));
    setAttrib(entry, R_ClassSymbol, ScalarString(mkChar("restart")));
    R_RestartStack = CONS(entry, R_RestartStack);
    UNPROTECT(3);
}
 
SEXP attribute_hidden do_dfltWarn(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    const char *msg;
    SEXP ecall;
 
    checkArity(op, args);
 
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
	error(_("bad error message"));
    msg = translateChar(STRING_ELT(CAR(args), 0));
    ecall = CADR(args);
 
    warningcall_dflt(ecall, "%s", msg);
    return R_NilValue;
}
 
SEXP attribute_hidden do_dfltStop(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    const char *msg;
    SEXP ecall;
 
    checkArity(op, args);
 
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
	error(_("bad error message"));
    msg = translateChar(STRING_ELT(CAR(args), 0));
    ecall = CADR(args);
 
    errorcall_dflt(ecall, "%s", msg);
    return R_NilValue; /* not reached */
}
 
 
/*
 * Restart Handling
 */
 
SEXP attribute_hidden do_getRestart(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int i;
    SEXP list;
    checkArity(op, args);
    i = asInteger(CAR(args));
    for (list = R_RestartStack;
	 list != R_NilValue && i > 1;
	 list = CDR(list), i--);
    if (list != R_NilValue)
	return CAR(list);
    else if (i == 1) {
	/**** need to pre-allocate */
	SEXP name, entry;
	PROTECT(name = ScalarString(mkChar("abort")));
	entry = allocVector(VECSXP, 2);
	SET_VECTOR_ELT(entry, 0, name);
	SET_VECTOR_ELT(entry, 1, R_NilValue);
	setAttrib(entry, R_ClassSymbol, ScalarString(mkChar("restart")));
	UNPROTECT(1);
	return entry;
    }
    else return R_NilValue;
}
 
/* very minimal error checking --just enough to avoid a segfault */
#define CHECK_RESTART(r) do { \
    SEXP __r__ = (r); \
    if (TYPEOF(__r__) != VECSXP || LENGTH(__r__) < 2) \
	error(_("bad restart")); \
} while (0)
 
SEXP attribute_hidden do_addRestart(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    CHECK_RESTART(CAR(args));
    R_RestartStack = CONS(CAR(args), R_RestartStack);
    return R_NilValue;
}
 
#define RESTART_EXIT(r) VECTOR_ELT(r, 1)
 
static void invokeRestart(SEXP r, SEXP arglist)
{
    SEXP exit = RESTART_EXIT(r);
 
    if (exit == R_NilValue) {
	R_RestartStack = R_NilValue;
	jump_to_toplevel();
    }
    else {
	for (; R_RestartStack != R_NilValue;
	     R_RestartStack = CDR(R_RestartStack))
	    if (exit == RESTART_EXIT(CAR(R_RestartStack))) {
		R_RestartStack = CDR(R_RestartStack);
		if (TYPEOF(exit) == EXTPTRSXP) {
		    RCNTXT *c = (RCNTXT *) R_ExternalPtrAddr(exit);
		    R_JumpToContext(c, CTXT_RESTART, R_RestartToken);
		}
		else findcontext(CTXT_FUNCTION, exit, arglist);
	    }
	error(_("restart not on stack"));
    }
}
 
SEXP attribute_hidden do_invokeRestart(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    CHECK_RESTART(CAR(args));
    invokeRestart(CAR(args), CADR(args));
    return R_NilValue; /* not reached */
}
 
SEXP attribute_hidden do_addTryHandlers(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if (R_GlobalContext == R_ToplevelContext ||
	! R_GlobalContext->callflag & CTXT_FUNCTION)
	errorcall(call, _("not in a try context"));
    SET_RESTART_BIT_ON(R_GlobalContext->callflag);
    R_InsertRestartHandlers(R_GlobalContext, FALSE);
    return R_NilValue;
}
 
SEXP attribute_hidden do_seterrmessage(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP msg;
 
    checkArity(op, args);
    msg = CAR(args);
    if(!isString(msg) || LENGTH(msg) != 1)
	error(_("error message must be a character string"));
    R_SetErrmessage(CHAR(STRING_ELT(msg, 0)));
    return R_NilValue;
}
 
SEXP attribute_hidden
do_printDeferredWarnings(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    R_PrintDeferredWarnings();
    return R_NilValue;
}

Rev 41966	Rev 42208
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1997--2007 The R Development Core Team.`	4	`* Copyright (C) 1997--2007 The R Development Core Team.`
5	`*`	5	`*`
6	`* This program is free software; you can redistribute it and/or modify`	6	`* This program is free software; you can redistribute it and/or modify`
7	`* it under the terms of the GNU General Public License as published by`	7	`* it under the terms of the GNU General Public License as published by`
8	`* the Free Software Foundation; either version 2 of the License, or`	8	`* the Free Software Foundation; either version 2 of the License, or`
9	`* (at your option) any later version.`	9	`* (at your option) any later version.`
10	`*`	10	`*`
11	`* This program is distributed in the hope that it will be useful,`	11	`* This program is distributed in the hope that it will be useful,`
12	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	12	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
13	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`	13	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
14	`* GNU General Public License for more details.`	14	`* GNU General Public License for more details.`
15	`*`	15	`*`
16	`* You should have received a copy of the GNU General Public License`	16	`* You should have received a copy of the GNU General Public License`
17	`* along with this program; if not, write to the Free Software`	17	`* along with this program; if not, write to the Free Software`
18	`* Foundation, Inc., 51 Franklin Street Fifth Floor, Boston, MA 02110-1301 USA`	18	`* Foundation, Inc., 51 Franklin Street Fifth Floor, Boston, MA 02110-1301 USA`
19	`*/`	19	`*/`
20		20
21	`/* <UTF8> char here is either ASCII or handled as a whole */`	21	`/* <UTF8> char here is either ASCII or handled as a whole */`
22		22
23	`#ifdef HAVE_CONFIG_H`	23	`#ifdef HAVE_CONFIG_H`
24	`#include <config.h>`	24	`#include <config.h>`
25	`#endif`	25	`#endif`
26		26
27	`/* Now in Defn.h`	27	`/* Now in Defn.h`
28	`#ifdef HAVE_AQUA`	28	`#ifdef HAVE_AQUA`
29	`extern void R_ProcessEvents(void);`	29	`extern void R_ProcessEvents(void);`
30	`#endif`	30	`#endif`
31	`*/`	31	`*/`
32		32
33	`#include <Defn.h>`	33	`#include <Defn.h>`
34	`/* -> Errormsg.h */`	34	`/* -> Errormsg.h */`
35	`#include <Startup.h> /* rather cleanup ..*/`	35	`#include <Startup.h> /* rather cleanup ..*/`
36	`#include <Rconnections.h>`	36	`#include <Rconnections.h>`
37	`#include <Rinterface.h>`	37	`#include <Rinterface.h>`
38	`#include <R_ext/GraphicsDevice.h>`	38	`#include <R_ext/GraphicsDevice.h>`
39	`#include <R_ext/GraphicsEngine.h> /* for GEonExit */`	39	`#include <R_ext/GraphicsEngine.h> /* for GEonExit */`
40	`#include <Rmath.h> /* for imax2 */`	40	`#include <Rmath.h> /* for imax2 */`
41	`#if !( defined(HAVE_AQUA) \|\| defined(Win32) )`	41	`#if !( defined(HAVE_AQUA) \|\| defined(Win32) )`
42	`#include <R_ext/eventloop.h> /* for R_PolledEvents */`	42	`#include <R_ext/eventloop.h> /* for R_PolledEvents */`
43	`#endif`	43	`#endif`
44		44
45	`#ifndef min`	45	`#ifndef min`
46	`#define min(a, b) (a<b?a:b)`	46	`#define min(a, b) (a<b?a:b)`
47	`#endif`	47	`#endif`
48		48
49	`/* Total line length, in chars, before splitting in warnings/errors */`	49	`/* Total line length, in chars, before splitting in warnings/errors */`
50	`#define LONGWARN 75`	50	`#define LONGWARN 75`
51		51
52	`/*`	52	`/*`
53	`Different values of inError are used to indicate different places`	53	`Different values of inError are used to indicate different places`
54	`in the error handling.`	54	`in the error handling.`
55	`*/`	55	`*/`
56	`static int inError = 0;`	56	`static int inError = 0;`
57	`static int inWarning = 0;`	57	`static int inWarning = 0;`
58	`static int inPrintWarnings = 0;`	58	`static int inPrintWarnings = 0;`
59	`static int immediateWarning = 0;`	59	`static int immediateWarning = 0;`
60		60
61	`static void try_jump_to_restart(void);`	61	`static void try_jump_to_restart(void);`
62	`static void jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);`	62	`static void jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);`
63	`static void signalInterrupt(void);`	63	`static void signalInterrupt(void);`
64	`static char * R_ConciseTraceback(SEXP call, int skip);`	64	`static char * R_ConciseTraceback(SEXP call, int skip);`
65		65
66	`/* Interface / Calling Hierarchy :`	66	`/* Interface / Calling Hierarchy :`
67		67
68	`R__stop() -> do_error -> errorcall --> jump_to_top_ex`	68	`R__stop() -> do_error -> errorcall --> jump_to_top_ex`
69	`/`	69	`/`
70	`error`	70	`error`
71		71
72	`R__warning()-> do_warning -> warningcall -> if(warn >= 2) errorcall`	72	`R__warning()-> do_warning -> warningcall -> if(warn >= 2) errorcall`
73	`/`	73	`/`
74	`warning /`	74	`warning /`
75		75
76	`ErrorMessage()-> errorcall (but with message from ErrorDB[])`	76	`ErrorMessage()-> errorcall (but with message from ErrorDB[])`
77		77
78	`WarningMessage()-> warningcall (but with message from WarningDB[]).`	78	`WarningMessage()-> warningcall (but with message from WarningDB[]).`
79	`*/`	79	`*/`
80		80
81	`static void reset_stack_limit(void *data)`	81	`static void reset_stack_limit(void *data)`
82	`{`	82	`{`
83	`unsigned int limit = (unsigned int ) data;`	83	`unsigned int limit = (unsigned int ) data;`
84	`R_CStackLimit = *limit;`	84	`R_CStackLimit = *limit;`
85	`}`	85	`}`
86		86
87	`void R_CheckStack(void)`	87	`void R_CheckStack(void)`
88	`{`	88	`{`
89	`int dummy;`	89	`int dummy;`
90	`long usage = R_CStackDir * (R_CStackStart - (unsigned long)&dummy);`	90	`long usage = R_CStackDir * (R_CStackStart - (unsigned long)&dummy);`
91		91
92	`/* printf("usage %ld\n", usage); */`	92	`/* printf("usage %ld\n", usage); */`
93	`if(R_CStackLimit != -1 && usage > 0.95 * R_CStackLimit) {`	93	`if(R_CStackLimit != -1 && usage > 0.95 * R_CStackLimit) {`
94	`/* We do need some stack space to process error recovery,`	94	`/* We do need some stack space to process error recovery,`
95	`so temporarily raise the limit.`	95	`so temporarily raise the limit.`
96	`*/`	96	`*/`
97	`RCNTXT cntxt;`	97	`RCNTXT cntxt;`
98	`unsigned int stacklimit = R_CStackLimit;`	98	`unsigned int stacklimit = R_CStackLimit;`
99	`R_CStackLimit += 0.05*R_CStackLimit;`	99	`R_CStackLimit += 0.05*R_CStackLimit;`
100	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`	100	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`
101	`R_NilValue, R_NilValue);`	101	`R_NilValue, R_NilValue);`
102	`cntxt.cend = &reset_stack_limit;`	102	`cntxt.cend = &reset_stack_limit;`
103	`cntxt.cenddata = &stacklimit;`	103	`cntxt.cenddata = &stacklimit;`
104		104
105	`errorcall(R_NilValue, "C stack usage is too close to the limit");`	105	`errorcall(R_NilValue, "C stack usage is too close to the limit");`
106	`/* Do not translate this, to save stack space */`	106	`/* Do not translate this, to save stack space */`
107	`}`	107	`}`
108	`}`	108	`}`
109		109
110	`void R_CheckUserInterrupt(void)`	110	`void R_CheckUserInterrupt(void)`
111	`{`	111	`{`
112	`R_CheckStack();`	112	`R_CheckStack();`
113	`/* This is the point where GUI systems need to do enough event`	113	`/* This is the point where GUI systems need to do enough event`
114	`processing to determine whether there is a user interrupt event`	114	`processing to determine whether there is a user interrupt event`
115	`pending. Need to be careful not to do too much event`	115	`pending. Need to be careful not to do too much event`
116	`processing though: if event handlers written in R are allowed`	116	`processing though: if event handlers written in R are allowed`
117	`to run at this point then we end up with concurrent R`	117	`to run at this point then we end up with concurrent R`
118	`evaluations and that can cause problems until we have proper`	118	`evaluations and that can cause problems until we have proper`
119	`concurrency support. LT */`	119	`concurrency support. LT */`
120	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`	120	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`
121	`R_ProcessEvents();`	121	`R_ProcessEvents();`
122	`#else`	122	`#else`
123	`R_PolledEvents();`	123	`R_PolledEvents();`
124	`if (R_interrupts_pending)`	124	`if (R_interrupts_pending)`
125	`onintr();`	125	`onintr();`
126	`#endif /* Win32 */`	126	`#endif /* Win32 */`
127	`}`	127	`}`
128		128
129	`void onintr()`	129	`void onintr()`
130	`{`	130	`{`
131	`if (R_interrupts_suspended) {`	131	`if (R_interrupts_suspended) {`
132	`R_interrupts_pending = 1;`	132	`R_interrupts_pending = 1;`
133	`return;`	133	`return;`
134	`}`	134	`}`
135	`else R_interrupts_pending = 0;`	135	`else R_interrupts_pending = 0;`
136	`signalInterrupt();`	136	`signalInterrupt();`
137		137
138	`REprintf("\n");`	138	`REprintf("\n");`
139	`/* Attempt to run user error option, save a traceback, show`	139	`/* Attempt to run user error option, save a traceback, show`
140	`warnings, and reset console; also stop at restart (try/browser)`	140	`warnings, and reset console; also stop at restart (try/browser)`
141	`frames. Not clear this is what we really want, but this`	141	`frames. Not clear this is what we really want, but this`
142	`preserves current behavior */`	142	`preserves current behavior */`
143	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`	143	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`
144	`}`	144	`}`
145		145
146	`/* SIGUSR1: save and quit`	146	`/* SIGUSR1: save and quit`
147	`SIGUSR2: save and quit, don't run .Last or on.exit().`	147	`SIGUSR2: save and quit, don't run .Last or on.exit().`
148		148
149	`These do far more processing than is allowed in a signal handler ....`	149	`These do far more processing than is allowed in a signal handler ....`
150	`*/`	150	`*/`
151		151
152	`RETSIGTYPE attribute_hidden onsigusr1(int dummy)`	152	`RETSIGTYPE attribute_hidden onsigusr1(int dummy)`
153	`{`	153	`{`
154	`if (R_interrupts_suspended) {`	154	`if (R_interrupts_suspended) {`
155	`/**** ought to save signal and handle after suspend */`	155	`/**** ought to save signal and handle after suspend */`
156	`REprintf(_("interrupts suspended; signal ignored"));`	156	`REprintf(_("interrupts suspended; signal ignored"));`
157	`signal(SIGUSR1, onsigusr1);`	157	`signal(SIGUSR1, onsigusr1);`
158	`return;`	158	`return;`
159	`}`	159	`}`
160		160
161	`inError = 1;`	161	`inError = 1;`
162		162
163	`if(R_CollectWarnings) PrintWarnings();`	163	`if(R_CollectWarnings) PrintWarnings();`
164		164
165	`R_ResetConsole();`	165	`R_ResetConsole();`
166	`R_FlushConsole();`	166	`R_FlushConsole();`
167	`R_ClearerrConsole();`	167	`R_ClearerrConsole();`
168	`R_ParseError = 0;`	168	`R_ParseError = 0;`
169	`R_ParseErrorFile = NULL;`	169	`R_ParseErrorFile = NULL;`
170	`R_ParseErrorMsg[0] = '\0';`	170	`R_ParseErrorMsg[0] = '\0';`
171		171
172	`/* Bail out if there is a browser/try on the stack--do we really`	172	`/* Bail out if there is a browser/try on the stack--do we really`
173	`want this? No, as from R 2.4.0`	173	`want this? No, as from R 2.4.0`
174	`try_jump_to_restart(); */`	174	`try_jump_to_restart(); */`
175		175
176	`/* Run all onexit/cend code on the stack (without stopping at`	176	`/* Run all onexit/cend code on the stack (without stopping at`
177	`intervening CTXT_TOPLEVEL's. Since intervening CTXT_TOPLEVEL's`	177	`intervening CTXT_TOPLEVEL's. Since intervening CTXT_TOPLEVEL's`
178	`get used by what are conceptually concurrent computations, this`	178	`get used by what are conceptually concurrent computations, this`
179	`is a bit like telling all active threads to terminate and clean`	179	`is a bit like telling all active threads to terminate and clean`
180	`up on the way out. */`	180	`up on the way out. */`
181	`R_run_onexits(NULL);`	181	`R_run_onexits(NULL);`
182		182
183	`R_CleanUp(SA_SAVE, 2, 1); /* quit, save, .Last, status=2 */`	183	`R_CleanUp(SA_SAVE, 2, 1); /* quit, save, .Last, status=2 */`
184	`}`	184	`}`
185		185
186		186
187	`RETSIGTYPE attribute_hidden onsigusr2(int dummy)`	187	`RETSIGTYPE attribute_hidden onsigusr2(int dummy)`
188	`{`	188	`{`
189	`inError = 1;`	189	`inError = 1;`
190		190
191	`if (R_interrupts_suspended) {`	191	`if (R_interrupts_suspended) {`
192	`/**** ought to save signal and handle after suspend */`	192	`/**** ought to save signal and handle after suspend */`
193	`REprintf(_("interrupts suspended; signal ignored"));`	193	`REprintf(_("interrupts suspended; signal ignored"));`
194	`signal(SIGUSR2, onsigusr2);`	194	`signal(SIGUSR2, onsigusr2);`
195	`return;`	195	`return;`
196	`}`	196	`}`
197		197
198	`if(R_CollectWarnings) PrintWarnings();`	198	`if(R_CollectWarnings) PrintWarnings();`
199		199
200	`R_ResetConsole();`	200	`R_ResetConsole();`
201	`R_FlushConsole();`	201	`R_FlushConsole();`
202	`R_ClearerrConsole();`	202	`R_ClearerrConsole();`
203	`R_ParseError = 0;`	203	`R_ParseError = 0;`
204	`R_ParseErrorFile = NULL;`	204	`R_ParseErrorFile = NULL;`
205	`R_ParseErrorMsg[0] = '\0';`	205	`R_ParseErrorMsg[0] = '\0';`
206	`R_CleanUp(SA_SAVE, 0, 0);`	206	`R_CleanUp(SA_SAVE, 0, 0);`
207	`}`	207	`}`
208		208
209		209
210	`static void setupwarnings(void)`	210	`static void setupwarnings(void)`
211	`{`	211	`{`
212	`R_Warnings = allocVector(VECSXP, 50);`	212	`R_Warnings = allocVector(VECSXP, 50);`
213	`setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, 50));`	213	`setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, 50));`
214	`}`	214	`}`
215		215
216	`/* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate. */`	216	`/* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate. */`
217	`static int Rvsnprintf(char buf, size_t size, const char format, va_list ap)`	217	`static int Rvsnprintf(char buf, size_t size, const char format, va_list ap)`
218	`{`	218	`{`
219	`int val;`	219	`int val;`
220	`val = vsnprintf(buf, size, format, ap);`	220	`val = vsnprintf(buf, size, format, ap);`
221	`buf[size-1] = '\0';`	221	`buf[size-1] = '\0';`
222	`return val;`	222	`return val;`
223	`}`	223	`}`
224		224
225	`#define BUFSIZE 8192`	225	`#define BUFSIZE 8192`
226	`void warning(const char *format, ...)`	226	`void warning(const char *format, ...)`
227	`{`	227	`{`
228	`char buf[BUFSIZE], *p;`	228	`char buf[BUFSIZE], *p;`
229	`RCNTXT *c = R_GlobalContext;`	229	`RCNTXT *c = R_GlobalContext;`
230		230
231	`va_list(ap);`	231	`va_list(ap);`
232	`va_start(ap, format);`	232	`va_start(ap, format);`
233	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`	233	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`
234	`va_end(ap);`	234	`va_end(ap);`
235	`p = buf + strlen(buf) - 1;`	235	`p = buf + strlen(buf) - 1;`
236	`if(strlen(buf) > 0 && p == '\n') p = '\0';`	236	`if(strlen(buf) > 0 && p == '\n') p = '\0';`
237	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`	237	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`
238	`strcat(buf, " [... truncated]");`	238	`strcat(buf, " [... truncated]");`
239	`if (c && (c->callflag & CTXT_BUILTIN)) c = c->nextcontext;`	239	`if (c && (c->callflag & CTXT_BUILTIN)) c = c->nextcontext;`
240	`warningcall(c ? c->call : R_NilValue, "%s", buf);`	240	`warningcall(c ? c->call : R_NilValue, "%s", buf);`
241	`}`	241	`}`
242		242
243	`/* temporary hook to allow experimenting with alternate warning mechanisms */`	243	`/* temporary hook to allow experimenting with alternate warning mechanisms */`
244	`static void (R_WarningHook)(SEXP, char ) = NULL;`	244	`static void (R_WarningHook)(SEXP, char ) = NULL;`
245		245
246	`/* declarations for internal condition handling */`	246	`/* declarations for internal condition handling */`
247		247
248	`static void vsignalError(SEXP call, const char *format, va_list ap);`	248	`static void vsignalError(SEXP call, const char *format, va_list ap);`
249	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`	249	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`
250	`static void invokeRestart(SEXP, SEXP);`	250	`static void invokeRestart(SEXP, SEXP);`
251		251
252	`static void reset_inWarning(void *data)`	252	`static void reset_inWarning(void *data)`
253	`{`	253	`{`
254	`inWarning = 0;`	254	`inWarning = 0;`
255	`}`	255	`}`
256		256
257	`#ifdef SUPPORT_MBCS`	257	`#ifdef SUPPORT_MBCS`
258	`#include <R_ext/rlocale.h>`	258	`#include <R_ext/rlocale.h>`
259		259
260	`static int wd(const char * buf)`	260	`static int wd(const char * buf)`
261	`{`	261	`{`
262	`int nc = mbstowcs(NULL, buf, 0), nw;`	262	`int nc = mbstowcs(NULL, buf, 0), nw;`
263	`if(nc > 0 && nc < 2000) {`	263	`if(nc > 0 && nc < 2000) {`
264	`wchar_t wc[2000];`	264	`wchar_t wc[2000];`
265	`mbstowcs(wc, buf, nc + 1);`	265	`mbstowcs(wc, buf, nc + 1);`
266	`nw = Ri18n_wcswidth(wc, 2147483647);`	266	`nw = Ri18n_wcswidth(wc, 2147483647);`
267	`return (nw < 1) ? nc : nw;`	267	`return (nw < 1) ? nc : nw;`
268	`}`	268	`}`
269	`return nc;`	269	`return nc;`
270	`}`	270	`}`
271	`#endif`	271	`#endif`
272		272
273	`static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)`	273	`static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)`
274	`{`	274	`{`
275	`int w;`	275	`int w;`
276	`SEXP names, s;`	276	`SEXP names, s;`
277	`const char *dcall;`	277	`const char *dcall;`
278	`char buf[BUFSIZE];`	278	`char buf[BUFSIZE];`
279	`RCNTXT *cptr;`	279	`RCNTXT *cptr;`
280	`RCNTXT cntxt;`	280	`RCNTXT cntxt;`
281		281
282	`if (inWarning)`	282	`if (inWarning)`
283	`return;`	283	`return;`
284		284
285	`s = GetOption(install("warning.expression"), R_BaseEnv);`	285	`s = GetOption(install("warning.expression"), R_BaseEnv);`
286	`if( s != R_NilValue ) {`	286	`if( s != R_NilValue ) {`
287	`if( !isLanguage(s) && ! isExpression(s) )`	287	`if( !isLanguage(s) && ! isExpression(s) )`
288	`error(_("invalid option \"warning.expression\""));`	288	`error(_("invalid option \"warning.expression\""));`
289	`cptr = R_GlobalContext;`	289	`cptr = R_GlobalContext;`
290	`while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag )`	290	`while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag )`
291	`cptr = cptr->nextcontext;`	291	`cptr = cptr->nextcontext;`
292	`eval(s, cptr->cloenv);`	292	`eval(s, cptr->cloenv);`
293	`return;`	293	`return;`
294	`}`	294	`}`
295		295
296	`w = asInteger(GetOption(install("warn"), R_BaseEnv));`	296	`w = asInteger(GetOption(install("warn"), R_BaseEnv));`
297		297
298	`if( w == NA_INTEGER ) /* set to a sensible value */`	298	`if( w == NA_INTEGER ) /* set to a sensible value */`
299	`w = 0;`	299	`w = 0;`
300		300
301	`if( w <= 0 && immediateWarning ) w = 1;`	301	`if( w <= 0 && immediateWarning ) w = 1;`
302		302
303	`if( w < 0 \|\| inWarning \|\| inError) /* ignore if w<0 or already in here*/`	303	`if( w < 0 \|\| inWarning \|\| inError) /* ignore if w<0 or already in here*/`
304	`return;`	304	`return;`
305		305
306	`/* set up a context which will restore inWarning if there is an exit */`	306	`/* set up a context which will restore inWarning if there is an exit */`
307	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`	307	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`
308	`R_NilValue, R_NilValue);`	308	`R_NilValue, R_NilValue);`
309	`cntxt.cend = &reset_inWarning;`	309	`cntxt.cend = &reset_inWarning;`
310		310
311	`inWarning = 1;`	311	`inWarning = 1;`
312		312
313	`if(w >= 2) { /* make it an error */`	313	`if(w >= 2) { /* make it an error */`
314	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	314	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
315	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`	315	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`
316	`strcat(buf, " [... truncated]");`	316	`strcat(buf, " [... truncated]");`
317	`inWarning = 0; /* PR#1570 */`	317	`inWarning = 0; /* PR#1570 */`
318	`errorcall(call, _("(converted from warning) %s"), buf);`	318	`errorcall(call, _("(converted from warning) %s"), buf);`
319	`}`	319	`}`
320	`else if(w == 1) { /* print as they happen */`	320	`else if(w == 1) { /* print as they happen */`
321	`char *tr;`	321	`char *tr;`
322	`if( call != R_NilValue ) {`	322	`if( call != R_NilValue ) {`
323	`dcall = CHAR(STRING_ELT(deparse1(call, 0, DEFAULTDEPARSE), 0));`	323	`dcall = CHAR(STRING_ELT(deparse1(call, 0, DEFAULTDEPARSE), 0));`
324	`} else dcall = "";`	324	`} else dcall = "";`
325	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`	325	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`
326	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`	326	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`
327	`strcat(buf, " [... truncated]");`	327	`strcat(buf, " [... truncated]");`
328	`if(dcall[0] == '\0')`	328	`if(dcall[0] == '\0')`
329	`REprintf(_("Warning: %s\n"), buf);`	329	`REprintf(_("Warning: %s\n"), buf);`
330	`#ifdef SUPPORT_MBCS`	330	`#ifdef SUPPORT_MBCS`
331	`else if(mbcslocale &&`	331	`else if(mbcslocale &&`
332	`18 + wd(dcall) + wd(buf) <= LONGWARN)`	332	`18 + wd(dcall) + wd(buf) <= LONGWARN)`
333	`REprintf(_("Warning in %s : %s\n"), dcall, buf);`	333	`REprintf(_("Warning in %s : %s\n"), dcall, buf);`
334	`#endif`	334	`#endif`
335	`else if(18+strlen(dcall)+strlen(buf) <= LONGWARN)`	335	`else if(18+strlen(dcall)+strlen(buf) <= LONGWARN)`
336	`REprintf(_("Warning in %s : %s\n"), dcall, buf);`	336	`REprintf(_("Warning in %s : %s\n"), dcall, buf);`
337	`else`	337	`else`
338	`REprintf(_("Warning in %s :\n %s\n"), dcall, buf);`	338	`REprintf(_("Warning in %s :\n %s\n"), dcall, buf);`
339	`if(R_ShowWarnCalls && call != R_NilValue) {`	339	`if(R_ShowWarnCalls && call != R_NilValue) {`
340	`tr = R_ConciseTraceback(call, 0);`	340	`tr = R_ConciseTraceback(call, 0);`
341	`if (strlen(tr)) REprintf("Calls: %s\n", tr);`	341	`if (strlen(tr)) REprintf("Calls: %s\n", tr);`
342	`}`	342	`}`
343	`}`	343	`}`
344	`else if(w == 0) { /* collect them */`	344	`else if(w == 0) { /* collect them */`
345	`char *tr; int nc;`	345	`char *tr; int nc;`
346	`if(!R_CollectWarnings)`	346	`if(!R_CollectWarnings)`
347	`setupwarnings();`	347	`setupwarnings();`
348	`if( R_CollectWarnings > 49 )`	348	`if( R_CollectWarnings > 49 )`
349	`return;`	349	`return;`
350	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`	350	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`
351	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`	351	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength+1), format, ap);`
352	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`	352	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`
353	`strcat(buf, " [... truncated]");`	353	`strcat(buf, " [... truncated]");`
354	`if(R_ShowWarnCalls && call != R_NilValue) {`	354	`if(R_ShowWarnCalls && call != R_NilValue) {`
355	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`	355	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`
356	`if (nc && nc + strlen(buf) + 8 < BUFSIZE) {`	356	`if (nc && nc + strlen(buf) + 8 < BUFSIZE) {`
357	`strcat(buf, "\nCalls: ");`	357	`strcat(buf, "\nCalls: ");`
358	`strcat(buf, tr);`	358	`strcat(buf, tr);`
359	`}`	359	`}`
360	`}`	360	`}`
361	`names = CAR(ATTRIB(R_Warnings));`	361	`names = CAR(ATTRIB(R_Warnings));`
362	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`	362	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`
363	`}`	363	`}`
364	`/* else: w <= -1 */`	364	`/* else: w <= -1 */`
365	`endcontext(&cntxt);`	365	`endcontext(&cntxt);`
366	`inWarning = 0;`	366	`inWarning = 0;`
367	`}`	367	`}`
368		368
369	`static void warningcall_dflt(SEXP call, const char *format,...)`	369	`static void warningcall_dflt(SEXP call, const char *format,...)`
370	`{`	370	`{`
371	`va_list(ap);`	371	`va_list(ap);`
372		372
373	`va_start(ap, format);`	373	`va_start(ap, format);`
374	`vwarningcall_dflt(call, format, ap);`	374	`vwarningcall_dflt(call, format, ap);`
375	`va_end(ap);`	375	`va_end(ap);`
376	`}`	376	`}`
377		377
378	`void warningcall(SEXP call, const char *format, ...)`	378	`void warningcall(SEXP call, const char *format, ...)`
379	`{`	379	`{`
380	`va_list(ap);`	380	`va_list(ap);`
381	`va_start(ap, format);`	381	`va_start(ap, format);`
382	`vsignalWarning(call, format, ap);`	382	`vsignalWarning(call, format, ap);`
383	`va_end(ap);`	383	`va_end(ap);`
384	`}`	384	`}`
385		385
386	`void warningcall_immediate(SEXP call, const char *format, ...)`	386	`void warningcall_immediate(SEXP call, const char *format, ...)`
387	`{`	387	`{`
388	`va_list(ap);`	388	`va_list(ap);`
389		389
390	`immediateWarning = 1;`	390	`immediateWarning = 1;`
391	`va_start(ap, format);`	391	`va_start(ap, format);`
392	`vwarningcall_dflt(call, format, ap);`	392	`vwarningcall_dflt(call, format, ap);`
393	`va_end(ap);`	393	`va_end(ap);`
394	`immediateWarning = 0;`	394	`immediateWarning = 0;`
395	`}`	395	`}`
396		396
397	`static void cleanup_PrintWarnings(void *data)`	397	`static void cleanup_PrintWarnings(void *data)`
398	`{`	398	`{`
399	`if (R_CollectWarnings) {`	399	`if (R_CollectWarnings) {`
400	`R_CollectWarnings = 0;`	400	`R_CollectWarnings = 0;`
401	`R_Warnings = R_NilValue;`	401	`R_Warnings = R_NilValue;`
402	`REprintf(_("Lost warning messages\n"));`	402	`REprintf(_("Lost warning messages\n"));`
403	`}`	403	`}`
404	`inPrintWarnings = 0;`	404	`inPrintWarnings = 0;`
405	`}`	405	`}`
406		406
407	`void PrintWarnings(void)`	407	`void PrintWarnings(void)`
408	`{`	408	`{`
409	`int i;`	409	`int i;`
410	`char *header;`	410	`char *header;`
411	`SEXP names, s, t;`	411	`SEXP names, s, t;`
412	`RCNTXT cntxt;`	412	`RCNTXT cntxt;`
413		413
414	`if (R_CollectWarnings == 0)`	414	`if (R_CollectWarnings == 0)`
415	`return;`	415	`return;`
416	`else if (inPrintWarnings) {`	416	`else if (inPrintWarnings) {`
417	`if (R_CollectWarnings) {`	417	`if (R_CollectWarnings) {`
418	`R_CollectWarnings = 0;`	418	`R_CollectWarnings = 0;`
419	`R_Warnings = R_NilValue;`	419	`R_Warnings = R_NilValue;`
420	`REprintf(_("Lost warning messages\n"));`	420	`REprintf(_("Lost warning messages\n"));`
421	`}`	421	`}`
422	`return;`	422	`return;`
423	`}`	423	`}`
424		424
425	`/* set up a context which will restore inPrintWarnings if there is`	425	`/* set up a context which will restore inPrintWarnings if there is`
426	`an exit */`	426	`an exit */`
427	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`	427	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`
428	`R_NilValue, R_NilValue);`	428	`R_NilValue, R_NilValue);`
429	`cntxt.cend = &cleanup_PrintWarnings;`	429	`cntxt.cend = &cleanup_PrintWarnings;`
430		430
431	`inPrintWarnings = 1;`	431	`inPrintWarnings = 1;`
432	`header = P_("Warning message:\n", "Warning messages:\n", R_CollectWarnings);`	432	`header = P_("Warning message:\n", "Warning messages:\n", R_CollectWarnings);`
433	`if( R_CollectWarnings == 1 ) {`	433	`if( R_CollectWarnings == 1 ) {`
434	`REprintf("%s", header);`	434	`REprintf("%s", header);`
435	`names = CAR(ATTRIB(R_Warnings));`	435	`names = CAR(ATTRIB(R_Warnings));`
436	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`	436	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`
437	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`	437	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`
438	`else {`	438	`else {`
439	`const char dcall, sep = " ", *msg = CHAR(STRING_ELT(names, 0));`	439	`const char dcall, sep = " ", *msg = CHAR(STRING_ELT(names, 0));`
440	`dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0),`	440	`dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0),`
441	`0, DEFAULTDEPARSE), 0));`	441	`0, DEFAULTDEPARSE), 0));`
442	`#ifdef SUPPORT_MBCS`	442	`#ifdef SUPPORT_MBCS`
443	`if (mbcslocale) {`	443	`if (mbcslocale) {`
444	`int msgline1;`	444	`int msgline1;`
445	`char *p = strchr(msg, '\n');`	445	`char *p = strchr(msg, '\n');`
446	`if (p) {`	446	`if (p) {`
447	`*p = '\0';`	447	`*p = '\0';`
448	`msgline1 = wd(msg);`	448	`msgline1 = wd(msg);`
449	`*p = '\n';`	449	`*p = '\n';`
450	`} else msgline1 = wd(msg);`	450	`} else msgline1 = wd(msg);`
451	`if (6 + wd(dcall) + msgline1 > LONGWARN) sep = "\n ";`	451	`if (6 + wd(dcall) + msgline1 > LONGWARN) sep = "\n ";`
452	`} else`	452	`} else`
453	`#endif`	453	`#endif`
454	`{`	454	`{`
455	`int msgline1 = strlen(msg);`	455	`int msgline1 = strlen(msg);`
456	`char *p = strchr(msg, '\n');`	456	`char *p = strchr(msg, '\n');`
457	`if (p) msgline1 = (int)(p - msg);`	457	`if (p) msgline1 = (int)(p - msg);`
458	`if (6+strlen(dcall) + msgline1 > LONGWARN) sep = "\n ";`	458	`if (6+strlen(dcall) + msgline1 > LONGWARN) sep = "\n ";`
459	`}`	459	`}`
460	`REprintf("In %s :%s%s\n", dcall, sep, msg);`	460	`REprintf("In %s :%s%s\n", dcall, sep, msg);`
461	`}`	461	`}`
462	`} else if( R_CollectWarnings <= 10 ) {`	462	`} else if( R_CollectWarnings <= 10 ) {`
463	`REprintf("%s", header);`	463	`REprintf("%s", header);`
464	`names = CAR(ATTRIB(R_Warnings));`	464	`names = CAR(ATTRIB(R_Warnings));`
465	`for(i = 0; i < R_CollectWarnings; i++) {`	465	`for(i = 0; i < R_CollectWarnings; i++) {`
466	`if( VECTOR_ELT(R_Warnings, i) == R_NilValue )`	466	`if( VECTOR_ELT(R_Warnings, i) == R_NilValue )`
467	`REprintf("%d: %s \n", i+1, CHAR(STRING_ELT(names, i)));`	467	`REprintf("%d: %s \n", i+1, CHAR(STRING_ELT(names, i)));`
468	`else {`	468	`else {`
469	`const char dcall, sep = " ", *msg = CHAR(STRING_ELT(names, i));`	469	`const char dcall, sep = " ", *msg = CHAR(STRING_ELT(names, i));`
470	`dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, i),`	470	`dcall = CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, i),`
471	`0, DEFAULTDEPARSE), 0));`	471	`0, DEFAULTDEPARSE), 0));`
472	`#ifdef SUPPORT_MBCS`	472	`#ifdef SUPPORT_MBCS`
473	`if (mbcslocale) {`	473	`if (mbcslocale) {`
474	`int msgline1;`	474	`int msgline1;`
475	`char *p = strchr(msg, '\n');`	475	`char *p = strchr(msg, '\n');`
476	`if (p) {`	476	`if (p) {`
477	`*p = '\0';`	477	`*p = '\0';`
478	`msgline1 = wd(msg);`	478	`msgline1 = wd(msg);`
479	`*p = '\n';`	479	`*p = '\n';`
480	`} else msgline1 = wd(msg);`	480	`} else msgline1 = wd(msg);`
481	`if (10 + wd(dcall) + msgline1 > LONGWARN) sep = "\n ";`	481	`if (10 + wd(dcall) + msgline1 > LONGWARN) sep = "\n ";`
482	`} else`	482	`} else`
483	`#endif`	483	`#endif`
484	`{`	484	`{`
485	`int msgline1 = strlen(msg);`	485	`int msgline1 = strlen(msg);`
486	`char *p = strchr(msg, '\n');`	486	`char *p = strchr(msg, '\n');`
487	`if (p) msgline1 = (int)(p - msg);`	487	`if (p) msgline1 = (int)(p - msg);`
488	`if (10+strlen(dcall) + msgline1 > LONGWARN) sep = "\n ";`	488	`if (10+strlen(dcall) + msgline1 > LONGWARN) sep = "\n ";`
489	`}`	489	`}`
490	`REprintf("%d: In %s :%s%s\n", i+1, dcall, sep, msg);`	490	`REprintf("%d: In %s :%s%s\n", i+1, dcall, sep, msg);`
491	`}`	491	`}`
492	`}`	492	`}`
493	`} else {`	493	`} else {`
494	`if (R_CollectWarnings < 50)`	494	`if (R_CollectWarnings < 50)`
495	`REprintf(_("There were %d warnings (use warnings() to see them)\n"),`	495	`REprintf(_("There were %d warnings (use warnings() to see them)\n"),`
496	`R_CollectWarnings);`	496	`R_CollectWarnings);`
497	`else`	497	`else`
498	`REprintf(_("There were 50 or more warnings (use warnings() to see the first 50)\n"));`	498	`REprintf(_("There were 50 or more warnings (use warnings() to see the first 50)\n"));`
499	`}`	499	`}`
500	`/* now truncate and install last.warning */`	500	`/* now truncate and install last.warning */`

The R Project SVN R

(root)/branches/djm-source/src/main/errors.c – Rev 41966 → 42208