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--2002  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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */
 
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
 
#ifdef HAVE_AQUA
extern void R_ProcessEvents(void);
#endif
 
 
#include <Defn.h>
/* -> Errormsg.h */
#include <Startup.h> /* rather cleanup ..*/
#include <Rconnections.h>
 
#ifndef min
#define min(a, b) (a<b?a:b)
#endif
 
/* limit on call length at which errorcall/warningcall is split over
   two lines */
#define LONGCALL 30
 
/*
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 void try_jump_to_restart(void);
static void jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);
static void signalInterrupt(void);
 
/* 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[]).
*/
 
 
void R_CheckUserInterrupt(void)
{
    /* 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
    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().
*/
 
void onsigusr1()
{
    if (R_interrupts_suspended) {
	/**** ought to save signal and handle after suspend */
	REprintf("interrupts suspended; signal ignored");
	return;
    }
 
    inError = 1;
 
    if( R_CollectWarnings )
	PrintWarnings();
 
    R_ResetConsole();
    R_FlushConsole();
    R_ClearerrConsole();
    R_ParseError = 0;
 
    /* Bail out if there is a browser/try on the stack--do we really
       want this? */
    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 */
}
 
 
void onsigusr2()
{
    inError = 1;
 
    if (R_interrupts_suspended) {
	/**** ought to save signal and handle after suspend */
	REprintf("interrupts suspended; signal ignored");
	return;
    }
 
    if( R_CollectWarnings )
	PrintWarnings();
 
    R_ResetConsole();
    R_FlushConsole();
    R_ClearerrConsole();
    R_ParseError = 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;
 
    va_list(ap);
    va_start(ap, format);
    Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
    va_end(ap);
    p = buf + strlen(buf) - 1;
    if(strlen(buf) > 0 && *p == '\n') *p = '\0';
    warningcall(R_NilValue, buf);
}
 
/* temporary hook to allow experimenting with alternate warning mechanisms */
static void (*R_WarningHook)(SEXP, char *) = NULL;
 
#ifdef NEW_CONDITION_HANDLING
/* 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);
#endif
 
static void reset_inWarning(void *data)
{
    inWarning = 0;
}
 
static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)
{
    int w;
    SEXP names, s;
    char *dcall, buf[BUFSIZE];
    RCNTXT *cptr;
    RCNTXT cntxt;
 
    if (inWarning)
	return;
 
    s = GetOption(install("warning.expression"), R_NilValue);
    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_NilValue));
 
    if( w == NA_INTEGER ) /* set to a sensible value */
	w = 0;
 
    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_NilValue, R_NilValue,
		 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);
	inWarning = 0; /* PR#1570 */
	errorcall(call, "(converted from warning) %s", buf);
    }
    else if(w == 1) {	/* print as they happen */
	if( call != R_NilValue ) {
	    dcall = CHAR(STRING_ELT(deparse1(call, 0, SIMPLEDEPARSE), 0));
	    REprintf("Warning in %s : ", dcall);
	    if (strlen(dcall) > LONGCALL) REprintf("\n	 ");
	}
	else
	    REprintf("Warning: ");
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
	REprintf("%s\n", buf);
    }
    else if(w == 0) {	/* collect them */
	if(!R_CollectWarnings)
	    setupwarnings();
	if( R_CollectWarnings > 49 )
	    return;
	SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
	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);
#ifdef NEW_CONDITION_HANDLING
    va_start(ap, format);
    vsignalWarning(call, format, ap);
    va_end(ap);
#else
    if (R_WarningHook != NULL) {
	char buf[BUFSIZE];
	va_start(ap, format);
	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
	va_end(ap);
	R_WarningHook(call, buf);
	return;
    }
 
    va_start(ap, format);
    vwarningcall_dflt(call, format, ap);
    va_end(ap);
#endif
}
 
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;
    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_NilValue, R_NilValue,
		 R_NilValue, R_NilValue);
    cntxt.cend = &cleanup_PrintWarnings;
 
    inPrintWarnings = 1;
    if( R_CollectWarnings == 1 ) {
	REprintf("Warning message: \n");
	names = CAR(ATTRIB(R_Warnings));
	if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )
	   REprintf("%s \n", CHAR(STRING_ELT(names, 0)));
	else
	   REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),
		CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0), 0, SIMPLEDEPARSE), 0)));
    }
    else if( R_CollectWarnings <= 10 ) {
	REprintf("Warning messages: \n");
	names = CAR(ATTRIB(R_Warnings));
	for(i=0; i<R_CollectWarnings; i++) {
	    if( STRING_ELT(R_Warnings, i) == R_NilValue )
	       REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));
	    else
	       REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),
		   CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0, SIMPLEDEPARSE), 0)));
	}
    }
    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_VECTOR_ELT(t, i, VECTOR_ELT(names, i));
    }
    setAttrib(s, R_NamesSymbol, t);
    defineVar(install("last.warning"), s, R_GlobalEnv);
    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 = data;
    inError = *poldval;
}
 
static void verrorcall_dflt(SEXP call, const char *format, va_list ap)
{
    RCNTXT cntxt;
    char *p, *dcall;
    int oldInError;
 
    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");
	}
	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_NilValue, R_NilValue,
		 R_NilValue, R_NilValue);
    cntxt.cend = &restore_inError;
    cntxt.cenddata = &oldInError;
    oldInError = inError;
    inError = 1;
 
    if(call != R_NilValue) {
	char *head = "Error in ";
	char *mid = " : ";
	char *tail = "\n\t";/* <- TAB */
	int len = strlen(head) + strlen(mid) + strlen(tail);
 
	dcall = CHAR(STRING_ELT(deparse1(call, 0, SIMPLEDEPARSE), 0));
	if (strlen(dcall) + len < BUFSIZE) {
	    sprintf(errbuf, "%s%s%s", head, dcall, mid);
	    if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);
	}
	else
	    sprintf(errbuf, "Error: ");
    }
    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_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);
 
#ifdef NEW_CONDITION_HANDLING
    va_start(ap, format);
    vsignalError(call, format, ap);
    va_end(ap);
#endif
 
    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 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];
 
    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... */
    errorcall(R_GlobalContext ?
	      R_GlobalContext->call : R_NilValue, "%s", buf);
}
 
static void try_jump_to_restart(void)
{
#ifdef NEW_CONDITION_HANDLING
    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) {
		char *cname = CHAR(STRING_ELT(name, 0));
		if (! strcmp(cname, "browser") ||
		    ! strcmp(cname, "tryRestart") ||
		    ! strcmp(cname, "abort")) /**** move abort eventually? */
		    invokeRestart(restart, R_NilValue);
	    }
	}
    }
#else
    RCNTXT *c;
 
    for (c = R_GlobalContext; c; c = c->nextcontext) {
	if (IS_RESTART_BIT_SET(c->callflag)) {
	    inError=0;
	    findcontext(CTXT_RESTART, c->cloenv, R_RestartToken);
	}
	if (c->callflag == CTXT_TOPLEVEL)
	    break;
    }
#endif
}
 
/* 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_NilValue, R_NilValue,
		 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_NilValue);
	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;
    }
 
    /* 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 inconsistenty between inError and oldInError
	   (which should not happen) */
	if (traceback && inError < 2 && inError == oldInError) {
	    inError = 2;
	    PROTECT(s = R_GetTraceback(0));
	    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);
}
 
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 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", CHAR(STRING_ELT(CAR(args), 0)));
    }
    else
      errorcall(c_call, "");
    /* never called: */return c_call;
}
 
SEXP 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 (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", CHAR(STRING_ELT(CAR(args), 0)));
    }
    else
	warningcall(c_call, "");
 
    /* need to set R_Visible since it may have been changed by a callback */
    R_Visible = 0;
    return CAR(args);
}
 
/* Error recovery for incorrect argument count error. */
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_WARNING code;
    const char* const format;
}
const ErrorDB[] = {
    { ERROR_NUMARGS,		"invalid number of arguments"		},
    { ERROR_ARGTYPE,		"invalid argument type"			},
 
    { ERROR_TSVEC_MISMATCH,	"time-series/vector length mismatch"	},
    { ERROR_INCOMPAT_ARGS,	"incompatible arguments"		},
 
    { ERROR_UNIMPLEMENTED,	"unimplemented feature in %s"		},
    { ERROR_UNKNOWN,		"unknown error (report this!)"		}
};
 
static struct {
    R_WARNING code;
    char* format;
}
WarningDB[] = {
    { WARNING_coerce_NA,	"NAs introduced by coercion"		},
    { WARNING_coerce_INACC,	"inaccurate integer conversion in coercion" },
    { WARNING_coerce_IMAG,	"imaginary parts discarded in coercion" },
 
    { WARNING_UNKNOWN,		"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(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(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 ) {
	    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 ) {
	    if (skip > 0)
		skip--;
	    else {
		SETCAR(t, deparse1(c->call, 0, SIMPLEDEPARSE));
		t = CDR(t);
	    }
	}
    UNPROTECT(1);
    return s;
}
 
#ifdef NEW_CONDITION_HANDLING
static SEXP mkHandlerEntry(SEXP class, SEXP parentenv, SEXP handler, SEXP rho,
			   SEXP result, int calling)
{
    SEXP entry = allocVector(VECSXP, 5);
    SET_VECTOR_ELT(entry, 0, class);
    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 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 class = STRING_ELT(classes, i);
	SEXP handler = VECTOR_ELT(handlers, i);
	SEXP entry = mkHandlerEntry(class, parentenv, handler, target, result,
				    calling);
	REPROTECT(newstack = CONS(entry, newstack), osi);
    }
 
    R_HandlerStack = newstack;
    UNPROTECT(2);
 
    return oldstack;
}
 
SEXP 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)
{
    SEXP list, oldstack;
 
    oldstack = R_HandlerStack;
    while ((list = findSimpleErrorHandler()) != R_NilValue) {
	char *buf = errbuf;
	SEXP entry = CAR(list);
	R_HandlerStack = CDR(list);
	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 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) {
		char *msgstr = NULL;
		if (TYPEOF(msg) == STRSXP && LENGTH(msg) > 0)
		    msgstr = CHAR(STRING_ELT(msg, 0));
		else error("error message not a strring");
		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, class;
    PROTECT(cond = allocVector(VECSXP, 0));
    PROTECT(class = allocVector(STRSXP, 2));
    SET_STRING_ELT(class, 0, mkChar("interrupt"));
    SET_STRING_ELT(class, 1, mkChar("condition"));
    R_set_class(cond, class, R_NilValue);
    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 R_InsertRestartHandlers(RCNTXT *cptr, Rboolean browser)
{
    SEXP class, 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(class = mkChar("error"));
    entry = mkHandlerEntry(class, rho, R_RestartToken, rho, R_NilValue, TRUE);
    R_HandlerStack = CONS(entry, R_HandlerStack);
    UNPROTECT(1);
    PROTECT(name = ScalarString(mkChar(browser ? "browser" : "tryRestart")));
    entry = allocVector(VECSXP, 2);
    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(1);
}
 
SEXP do_dfltWarn(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    char *msg;
    SEXP ecall;
 
    checkArity(op, args);
 
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
	error("bad error message");
    msg = CHAR(STRING_ELT(CAR(args), 0));
    ecall = CADR(args);
 
    warningcall_dflt(ecall, "%s", msg);
    return R_NilValue;
}
 
SEXP do_dfltStop(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    char *msg;
    SEXP ecall;
 
    checkArity(op, args);
 
    if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) != 1)
	error("bad error message");
    msg = CHAR(STRING_ELT(CAR(args), 0));
    ecall = CADR(args);
 
    errorcall_dflt(ecall, "%s", msg);
    return R_NilValue; /* not reached */
}
 
 
/*
 * Restart Handling
 */
 
SEXP 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 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 = R_ExternalPtrAddr(exit);
		    R_JumpToContext(c, CTXT_RESTART, R_RestartToken);
		}
		else findcontext(CTXT_FUNCTION, exit, arglist);
	    }
	error("restart not on stack");
    }
}
 
SEXP 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 */
}
#endif
 
SEXP 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);
#ifdef NEW_CONDITION_HANDLING
    R_InsertRestartHandlers(R_GlobalContext, FALSE);
#endif
    return R_NilValue;
}

Rev 29864	Rev 30691
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--2002 The R Development Core Team.`	4	`* Copyright (C) 1997--2002 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`	18	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`
19	`*/`	19	`*/`
20		20
21	`#ifdef HAVE_CONFIG_H`	21	`#ifdef HAVE_CONFIG_H`
22	`#include <config.h>`	22	`#include <config.h>`
23	`#endif`	23	`#endif`
24		24
25	`#ifdef HAVE_AQUA`	25	`#ifdef HAVE_AQUA`
26	`extern void R_ProcessEvents(void);`	26	`extern void R_ProcessEvents(void);`
27	`#endif`	27	`#endif`
28		28
29		-
30	`#include <Defn.h>`	29	`#include <Defn.h>`
31	`/* -> Errormsg.h */`	30	`/* -> Errormsg.h */`
32	`#include <Startup.h> /* rather cleanup ..*/`	31	`#include <Startup.h> /* rather cleanup ..*/`
33	`#include <Rconnections.h>`	32	`#include <Rconnections.h>`
34		33
35	`#ifndef min`	34	`#ifndef min`
36	`#define min(a, b) (a<b?a:b)`	35	`#define min(a, b) (a<b?a:b)`
37	`#endif`	36	`#endif`
38		37
39	`/* limit on call length at which errorcall/warningcall is split over`	38	`/* limit on call length at which errorcall/warningcall is split over`
40	`two lines */`	39	`two lines */`
41	`#define LONGCALL 30`	40	`#define LONGCALL 30`
42		41
43	`/*`	42	`/*`
44	`Different values of inError are used to indicate different places`	43	`Different values of inError are used to indicate different places`
45	`in the error handling.`	44	`in the error handling.`
46	`*/`	45	`*/`
47	`static int inError = 0;`	46	`static int inError = 0;`
48	`static int inWarning = 0;`	47	`static int inWarning = 0;`
49	`static int inPrintWarnings = 0;`	48	`static int inPrintWarnings = 0;`
50		49
51	`static void try_jump_to_restart(void);`	50	`static void try_jump_to_restart(void);`
52	`static void jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);`	51	`static void jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean);`
53	`static void signalInterrupt(void);`	52	`static void signalInterrupt(void);`
54		53
55	`/* Interface / Calling Hierarchy :`	54	`/* Interface / Calling Hierarchy :`
56		55
57	`R__stop() -> do_error -> errorcall --> jump_to_top_ex`	56	`R__stop() -> do_error -> errorcall --> jump_to_top_ex`
58	`/`	57	`/`
59	`error`	58	`error`
60		59
61	`R__warning()-> do_warning -> warningcall -> if(warn >= 2) errorcall`	60	`R__warning()-> do_warning -> warningcall -> if(warn >= 2) errorcall`
62	`/`	61	`/`
63	`warning /`	62	`warning /`
64		63
65	`ErrorMessage()-> errorcall (but with message from ErrorDB[])`	64	`ErrorMessage()-> errorcall (but with message from ErrorDB[])`
66		65
67	`WarningMessage()-> warningcall (but with message from WarningDB[]).`	66	`WarningMessage()-> warningcall (but with message from WarningDB[]).`
68	`*/`	67	`*/`
69		68
70		69
71	`void R_CheckUserInterrupt(void)`	70	`void R_CheckUserInterrupt(void)`
72	`{`	71	`{`
73	`/* This is the point where GUI systems need to do enough event`	72	`/* This is the point where GUI systems need to do enough event`
74	`processing to determine whether there is a user interrupt event`	73	`processing to determine whether there is a user interrupt event`
75	`pending. Need to be careful not to do too much event`	74	`pending. Need to be careful not to do too much event`
76	`processing though: if event handlers written in R are allowed`	75	`processing though: if event handlers written in R are allowed`
77	`to run at this point then we end up with concurrent R`	76	`to run at this point then we end up with concurrent R`
78	`evaluations and that can cause problems until we have proper`	77	`evaluations and that can cause problems until we have proper`
79	`concurrency support. LT */`	78	`concurrency support. LT */`
80	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`	79	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`
81	`R_ProcessEvents();`	80	`R_ProcessEvents();`
82	`#else`	81	`#else`
83	`if (R_interrupts_pending)`	82	`if (R_interrupts_pending)`
84	`onintr();`	83	`onintr();`
85	`#endif /* Win32 */`	84	`#endif /* Win32 */`
86	`}`	85	`}`
87		86
88	`void onintr()`	87	`void onintr()`
89	`{`	88	`{`
90	`if (R_interrupts_suspended) {`	89	`if (R_interrupts_suspended) {`
91	`R_interrupts_pending = 1;`	90	`R_interrupts_pending = 1;`
92	`return;`	91	`return;`
93	`}`	92	`}`
94	`else R_interrupts_pending = 0;`	93	`else R_interrupts_pending = 0;`
95		-
96	`signalInterrupt();`	94	`signalInterrupt();`
97		95
98	`REprintf("\n");`	96	`REprintf("\n");`
99	`/* Attempt to run user error option, save a traceback, show`	97	`/* Attempt to run user error option, save a traceback, show`
100	`warnings, and reset console; also stop at restart (try/browser)`	98	`warnings, and reset console; also stop at restart (try/browser)`
101	`frames. Not clear this is what we really want, but this`	99	`frames. Not clear this is what we really want, but this`
102	`preserves current behavior */`	100	`preserves current behavior */`
103	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`	101	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`
104	`}`	102	`}`
105		103
106	`/* SIGUSR1: save and quit`	104	`/* SIGUSR1: save and quit`
107	`SIGUSR2: save and quit, don't run .Last or on.exit().`	105	`SIGUSR2: save and quit, don't run .Last or on.exit().`
108	`*/`	106	`*/`
109		107
110	`void onsigusr1()`	108	`void onsigusr1()`
111	`{`	109	`{`
112	`if (R_interrupts_suspended) {`	110	`if (R_interrupts_suspended) {`
113	`/**** ought to save signal and handle after suspend */`	111	`/**** ought to save signal and handle after suspend */`
114	`REprintf("interrupts suspended; signal ignored");`	112	`REprintf("interrupts suspended; signal ignored");`
115	`return;`	113	`return;`
116	`}`	114	`}`
117		115
118	`inError = 1;`	116	`inError = 1;`
119		117
120	`if( R_CollectWarnings )`	118	`if( R_CollectWarnings )`
121	`PrintWarnings();`	119	`PrintWarnings();`
122		120
123	`R_ResetConsole();`	121	`R_ResetConsole();`
124	`R_FlushConsole();`	122	`R_FlushConsole();`
125	`R_ClearerrConsole();`	123	`R_ClearerrConsole();`
126	`R_ParseError = 0;`	124	`R_ParseError = 0;`
127		125
128	`/* Bail out if there is a browser/try on the stack--do we really`	126	`/* Bail out if there is a browser/try on the stack--do we really`
129	`want this? */`	127	`want this? */`
130	`try_jump_to_restart();`	128	`try_jump_to_restart();`
131		129
132	`/* Run all onexit/cend code on the stack (without stopping at`	130	`/* Run all onexit/cend code on the stack (without stopping at`
133	`intervening CTXT_TOPLEVEL's. Since intervening CTXT_TOPLEVEL's`	131	`intervening CTXT_TOPLEVEL's. Since intervening CTXT_TOPLEVEL's`
134	`get used by what are conceptually concurrent computations, this`	132	`get used by what are conceptually concurrent computations, this`
135	`is a bit like telling all active threads to terminate and clean`	133	`is a bit like telling all active threads to terminate and clean`
136	`up on the way out. */`	134	`up on the way out. */`
137	`R_run_onexits(NULL);`	135	`R_run_onexits(NULL);`
138		136
139	`R_CleanUp(SA_SAVE, 2, 1); /* quit, save, .Last, status=2 */`	137	`R_CleanUp(SA_SAVE, 2, 1); /* quit, save, .Last, status=2 */`
140	`}`	138	`}`
141		139
142		140
143	`void onsigusr2()`	141	`void onsigusr2()`
144	`{`	142	`{`
145	`inError = 1;`	143	`inError = 1;`
146		144
147	`if (R_interrupts_suspended) {`	145	`if (R_interrupts_suspended) {`
148	`/**** ought to save signal and handle after suspend */`	146	`/**** ought to save signal and handle after suspend */`
149	`REprintf("interrupts suspended; signal ignored");`	147	`REprintf("interrupts suspended; signal ignored");`
150	`return;`	148	`return;`
151	`}`	149	`}`
152		150
153	`if( R_CollectWarnings )`	151	`if( R_CollectWarnings )`
154	`PrintWarnings();`	152	`PrintWarnings();`
155		153
156	`R_ResetConsole();`	154	`R_ResetConsole();`
157	`R_FlushConsole();`	155	`R_FlushConsole();`
158	`R_ClearerrConsole();`	156	`R_ClearerrConsole();`
159	`R_ParseError = 0;`	157	`R_ParseError = 0;`
160	`R_CleanUp(SA_SAVE, 0, 0);`	158	`R_CleanUp(SA_SAVE, 0, 0);`
161	`}`	159	`}`
162		160
163		161
164	`static void setupwarnings(void)`	162	`static void setupwarnings(void)`
165	`{`	163	`{`
166	`R_Warnings = allocVector(VECSXP, 50);`	164	`R_Warnings = allocVector(VECSXP, 50);`
167	`setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, 50));`	165	`setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, 50));`
168	`}`	166	`}`
169		167
170	`/* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate. */`	168	`/* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate. */`
171	`static int Rvsnprintf(char buf, size_t size, const char format, va_list ap)`	169	`static int Rvsnprintf(char buf, size_t size, const char format, va_list ap)`
172	`{`	170	`{`
173	`int val;`	171	`int val;`
174	`val = vsnprintf(buf, size, format, ap);`	172	`val = vsnprintf(buf, size, format, ap);`
175	`buf[size-1] = '\0';`	173	`buf[size-1] = '\0';`
176	`return val;`	174	`return val;`
177	`}`	175	`}`
178		176
179	`#define BUFSIZE 8192`	177	`#define BUFSIZE 8192`
180	`void warning(const char *format, ...)`	178	`void warning(const char *format, ...)`
181	`{`	179	`{`
182	`char buf[BUFSIZE], *p;`	180	`char buf[BUFSIZE], *p;`
183		181
184	`va_list(ap);`	182	`va_list(ap);`
185	`va_start(ap, format);`	183	`va_start(ap, format);`
186	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	184	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
187	`va_end(ap);`	185	`va_end(ap);`
188	`p = buf + strlen(buf) - 1;`	186	`p = buf + strlen(buf) - 1;`
189	`if(strlen(buf) > 0 && p == '\n') p = '\0';`	187	`if(strlen(buf) > 0 && p == '\n') p = '\0';`
190	`warningcall(R_NilValue, buf);`	188	`warningcall(R_NilValue, buf);`
191	`}`	189	`}`
192		190
193	`/* temporary hook to allow experimenting with alternate warning mechanisms */`	191	`/* temporary hook to allow experimenting with alternate warning mechanisms */`
194	`static void (R_WarningHook)(SEXP, char ) = NULL;`	192	`static void (R_WarningHook)(SEXP, char ) = NULL;`
195		193
196	`#ifdef NEW_CONDITION_HANDLING`	194	`#ifdef NEW_CONDITION_HANDLING`
197	`/* declarations for internal condition handling */`	195	`/* declarations for internal condition handling */`
198		196
199	`static void vsignalError(SEXP call, const char *format, va_list ap);`	197	`static void vsignalError(SEXP call, const char *format, va_list ap);`
200	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`	198	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`
201	`static void invokeRestart(SEXP, SEXP);`	199	`static void invokeRestart(SEXP, SEXP);`
202	`#endif`	200	`#endif`
203		201
204	`static void reset_inWarning(void *data)`	202	`static void reset_inWarning(void *data)`
205	`{`	203	`{`
206	`inWarning = 0;`	204	`inWarning = 0;`
207	`}`	205	`}`
208		206
209	`static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)`	207	`static void vwarningcall_dflt(SEXP call, const char *format, va_list ap)`
210	`{`	208	`{`
211	`int w;`	209	`int w;`
212	`SEXP names, s;`	210	`SEXP names, s;`
213	`char *dcall, buf[BUFSIZE];`	211	`char *dcall, buf[BUFSIZE];`
214	`RCNTXT *cptr;`	212	`RCNTXT *cptr;`
215	`RCNTXT cntxt;`	213	`RCNTXT cntxt;`
216		214
217	`if (inWarning)`	215	`if (inWarning)`
218	`return;`	216	`return;`
219		217
220	`s = GetOption(install("warning.expression"), R_NilValue);`	218	`s = GetOption(install("warning.expression"), R_NilValue);`
221	`if( s!= R_NilValue ) {`	219	`if( s!= R_NilValue ) {`
222	`if( !isLanguage(s) && ! isExpression(s) )`	220	`if( !isLanguage(s) && ! isExpression(s) )`
223	`error("invalid option \"warning.expression\"");`	221	`error("invalid option \"warning.expression\"");`
224	`cptr = R_GlobalContext;`	222	`cptr = R_GlobalContext;`
225	`while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag )`	223	`while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag )`
226	`cptr = cptr->nextcontext;`	224	`cptr = cptr->nextcontext;`
227	`eval(s, cptr->cloenv);`	225	`eval(s, cptr->cloenv);`
228	`return;`	226	`return;`
229	`}`	227	`}`
230		228
231	`w = asInteger(GetOption(install("warn"), R_NilValue));`	229	`w = asInteger(GetOption(install("warn"), R_NilValue));`
232		230
233	`if( w == NA_INTEGER ) /* set to a sensible value */`	231	`if( w == NA_INTEGER ) /* set to a sensible value */`
234	`w = 0;`	232	`w = 0;`
235		233
236	`if(w < 0 \|\| inWarning \|\| inError) {/* ignore if w<0 or already in here*/`	234	`if(w < 0 \|\| inWarning \|\| inError) {/* ignore if w<0 or already in here*/`
237	`return;`	235	`return;`
238	`}`	236	`}`
239		237
240	`/* set up a context which will restore inWarning if there is an exit */`	238	`/* set up a context which will restore inWarning if there is an exit */`
241	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`	239	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`
242	`R_NilValue, R_NilValue);`	240	`R_NilValue, R_NilValue);`
243	`cntxt.cend = &reset_inWarning;`	241	`cntxt.cend = &reset_inWarning;`
244		242
245	`inWarning = 1;`	243	`inWarning = 1;`
246		244
247	`if(w >= 2) { /* make it an error */`	245	`if(w >= 2) { /* make it an error */`
248	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	246	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
249	`inWarning = 0; /* PR#1570 */`	247	`inWarning = 0; /* PR#1570 */`
250	`errorcall(call, "(converted from warning) %s", buf);`	248	`errorcall(call, "(converted from warning) %s", buf);`
251	`}`	249	`}`
252	`else if(w == 1) { /* print as they happen */`	250	`else if(w == 1) { /* print as they happen */`
253	`if( call != R_NilValue ) {`	251	`if( call != R_NilValue ) {`
254	`dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE, FALSE), 0));`	252	`dcall = CHAR(STRING_ELT(deparse1(call, 0, SIMPLEDEPARSE), 0));`
255	`REprintf("Warning in %s : ", dcall);`	253	`REprintf("Warning in %s : ", dcall);`
256	`if (strlen(dcall) > LONGCALL) REprintf("\n ");`	254	`if (strlen(dcall) > LONGCALL) REprintf("\n ");`
257	`}`	255	`}`
258	`else`	256	`else`
259	`REprintf("Warning: ");`	257	`REprintf("Warning: ");`
260	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	258	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
261	`REprintf("%s\n", buf);`	259	`REprintf("%s\n", buf);`
262	`}`	260	`}`
263	`else if(w == 0) { /* collect them */`	261	`else if(w == 0) { /* collect them */`
264	`if(!R_CollectWarnings)`	262	`if(!R_CollectWarnings)`
265	`setupwarnings();`	263	`setupwarnings();`
266	`if( R_CollectWarnings > 49 )`	264	`if( R_CollectWarnings > 49 )`
267	`return;`	265	`return;`
268	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`	266	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`
269	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	267	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
270	`names = CAR(ATTRIB(R_Warnings));`	268	`names = CAR(ATTRIB(R_Warnings));`
271	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`	269	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`
272	`}`	270	`}`
273	`/* else: w <= -1 */`	271	`/* else: w <= -1 */`
274	`endcontext(&cntxt);`	272	`endcontext(&cntxt);`
275	`inWarning = 0;`	273	`inWarning = 0;`
276	`}`	274	`}`
277		275
278	`static void warningcall_dflt(SEXP call, const char *format,...)`	276	`static void warningcall_dflt(SEXP call, const char *format,...)`
279	`{`	277	`{`
280	`va_list(ap);`	278	`va_list(ap);`
281		279
282	`va_start(ap, format);`	280	`va_start(ap, format);`
283	`vwarningcall_dflt(call, format, ap);`	281	`vwarningcall_dflt(call, format, ap);`
284	`va_end(ap);`	282	`va_end(ap);`
285	`}`	283	`}`
286		284
287	`void warningcall(SEXP call, const char *format, ...)`	285	`void warningcall(SEXP call, const char *format, ...)`
288	`{`	286	`{`
289	`va_list(ap);`	287	`va_list(ap);`
290	`#ifdef NEW_CONDITION_HANDLING`	288	`#ifdef NEW_CONDITION_HANDLING`
291	`va_start(ap, format);`	289	`va_start(ap, format);`
292	`vsignalWarning(call, format, ap);`	290	`vsignalWarning(call, format, ap);`
293	`va_end(ap);`	291	`va_end(ap);`
294	`#else`	292	`#else`
295	`if (R_WarningHook != NULL) {`	293	`if (R_WarningHook != NULL) {`
296	`char buf[BUFSIZE];`	294	`char buf[BUFSIZE];`
297	`va_start(ap, format);`	295	`va_start(ap, format);`
298	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	296	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
299	`va_end(ap);`	297	`va_end(ap);`
300	`R_WarningHook(call, buf);`	298	`R_WarningHook(call, buf);`
301	`return;`	299	`return;`
302	`}`	300	`}`
303		301
304	`va_start(ap, format);`	302	`va_start(ap, format);`
305	`vwarningcall_dflt(call, format, ap);`	303	`vwarningcall_dflt(call, format, ap);`
306	`va_end(ap);`	304	`va_end(ap);`
307	`#endif`	305	`#endif`
308	`}`	306	`}`
309		307
310	`static void cleanup_PrintWarnings(void *data)`	308	`static void cleanup_PrintWarnings(void *data)`
311	`{`	309	`{`
312	`if (R_CollectWarnings) {`	310	`if (R_CollectWarnings) {`
313	`R_CollectWarnings = 0;`	311	`R_CollectWarnings = 0;`
314	`R_Warnings = R_NilValue;`	312	`R_Warnings = R_NilValue;`
315	`REprintf("Lost warning messages\n");`	313	`REprintf("Lost warning messages\n");`
316	`}`	314	`}`
317	`inPrintWarnings = 0;`	315	`inPrintWarnings = 0;`
318	`}`	316	`}`
319		317
320	`void PrintWarnings(void)`	318	`void PrintWarnings(void)`
321	`{`	319	`{`
322	`int i;`	320	`int i;`
323	`SEXP names, s, t;`	321	`SEXP names, s, t;`
324	`RCNTXT cntxt;`	322	`RCNTXT cntxt;`
325		323
326	`if (R_CollectWarnings == 0)`	324	`if (R_CollectWarnings == 0)`
327	`return;`	325	`return;`
328	`else if (inPrintWarnings) {`	326	`else if (inPrintWarnings) {`
329	`if (R_CollectWarnings) {`	327	`if (R_CollectWarnings) {`
330	`R_CollectWarnings = 0;`	328	`R_CollectWarnings = 0;`
331	`R_Warnings = R_NilValue;`	329	`R_Warnings = R_NilValue;`
332	`REprintf("Lost warning messages\n");`	330	`REprintf("Lost warning messages\n");`
333	`}`	331	`}`
334	`return;`	332	`return;`
335	`}`	333	`}`
336		334
337	`/* set up a context which will restore inPrintWarnings if there is`	335	`/* set up a context which will restore inPrintWarnings if there is`
338	`an exit */`	336	`an exit */`
339	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`	337	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`
340	`R_NilValue, R_NilValue);`	338	`R_NilValue, R_NilValue);`
341	`cntxt.cend = &cleanup_PrintWarnings;`	339	`cntxt.cend = &cleanup_PrintWarnings;`
342		340
343	`inPrintWarnings = 1;`	341	`inPrintWarnings = 1;`
344	`if( R_CollectWarnings == 1 ) {`	342	`if( R_CollectWarnings == 1 ) {`
345	`REprintf("Warning message: \n");`	343	`REprintf("Warning message: \n");`
346	`names = CAR(ATTRIB(R_Warnings));`	344	`names = CAR(ATTRIB(R_Warnings));`
347	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`	345	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`
348	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`	346	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`
349	`else`	347	`else`
350	`REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),`	348	`REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),`
351	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0), 0, TRUE, FALSE), 0)));`	349	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0), 0, SIMPLEDEPARSE), 0)));`
352	`}`	350	`}`
353	`else if( R_CollectWarnings <= 10 ) {`	351	`else if( R_CollectWarnings <= 10 ) {`
354	`REprintf("Warning messages: \n");`	352	`REprintf("Warning messages: \n");`
355	`names = CAR(ATTRIB(R_Warnings));`	353	`names = CAR(ATTRIB(R_Warnings));`
356	`for(i=0; i<R_CollectWarnings; i++) {`	354	`for(i=0; i<R_CollectWarnings; i++) {`
357	`if( STRING_ELT(R_Warnings, i) == R_NilValue )`	355	`if( STRING_ELT(R_Warnings, i) == R_NilValue )`
358	`REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));`	356	`REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));`
359	`else`	357	`else`
360	`REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),`	358	`REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),`
361	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0, TRUE, FALSE), 0)));`	359	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0, SIMPLEDEPARSE), 0)));`
362	`}`	360	`}`
363	`}`	361	`}`
364	`else {`	362	`else {`
365	`if (R_CollectWarnings < 50)`	363	`if (R_CollectWarnings < 50)`
366	`REprintf("There were %d warnings (use warnings() to see them)\n",`	364	`REprintf("There were %d warnings (use warnings() to see them)\n",`
367	`R_CollectWarnings);`	365	`R_CollectWarnings);`
368	`else`	366	`else`
369	`REprintf("There were 50 or more warnings (use warnings() to see the first 50)\n");`	367	`REprintf("There were 50 or more warnings (use warnings() to see the first 50)\n");`
370	`}`	368	`}`
371	`/* now truncate and install last.warning */`	369	`/* now truncate and install last.warning */`
372	`PROTECT(s = allocVector(VECSXP, R_CollectWarnings));`	370	`PROTECT(s = allocVector(VECSXP, R_CollectWarnings));`
373	`PROTECT(t = allocVector(STRSXP, R_CollectWarnings));`	371	`PROTECT(t = allocVector(STRSXP, R_CollectWarnings));`
374	`names = CAR(ATTRIB(R_Warnings));`	372	`names = CAR(ATTRIB(R_Warnings));`
375	`for(i=0; i<R_CollectWarnings; i++) {`	373	`for(i=0; i<R_CollectWarnings; i++) {`
376	`SET_VECTOR_ELT(s, i, VECTOR_ELT(R_Warnings, i));`	374	`SET_VECTOR_ELT(s, i, VECTOR_ELT(R_Warnings, i));`
377	`SET_VECTOR_ELT(t, i, VECTOR_ELT(names, i));`	375	`SET_VECTOR_ELT(t, i, VECTOR_ELT(names, i));`
378	`}`	376	`}`
379	`setAttrib(s, R_NamesSymbol, t);`	377	`setAttrib(s, R_NamesSymbol, t);`
380	`defineVar(install("last.warning"), s, R_GlobalEnv);`	378	`defineVar(install("last.warning"), s, R_GlobalEnv);`
381	`UNPROTECT(2);`	379	`UNPROTECT(2);`
382		380
383	`endcontext(&cntxt);`	381	`endcontext(&cntxt);`
384		382
385	`inPrintWarnings = 0;`	383	`inPrintWarnings = 0;`
386	`R_CollectWarnings = 0;`	384	`R_CollectWarnings = 0;`
387	`R_Warnings = R_NilValue;`	385	`R_Warnings = R_NilValue;`
388	`return;`	386	`return;`
389	`}`	387	`}`
390		388
391	`static char errbuf[BUFSIZE];`	389	`static char errbuf[BUFSIZE];`
392		390
393	`/* temporary hook to allow experimenting with alternate error mechanisms */`	391	`/* temporary hook to allow experimenting with alternate error mechanisms */`
394	`static void (R_ErrorHook)(SEXP, char ) = NULL;`	392	`static void (R_ErrorHook)(SEXP, char ) = NULL;`
395		393
396	`static void restore_inError(void *data)`	394	`static void restore_inError(void *data)`
397	`{`	395	`{`
398	`int *poldval = data;`	396	`int *poldval = data;`
399	`inError = *poldval;`	397	`inError = *poldval;`
400	`}`	398	`}`
401		399
402	`static void verrorcall_dflt(SEXP call, const char *format, va_list ap)`	400	`static void verrorcall_dflt(SEXP call, const char *format, va_list ap)`
403	`{`	401	`{`
404	`RCNTXT cntxt;`	402	`RCNTXT cntxt;`
405	`char p, dcall;`	403	`char p, dcall;`
406	`int oldInError;`	404	`int oldInError;`
407		405
408	`if (inError) {`	406	`if (inError) {`
409	`/* fail-safe handler for recursive errors */`	407	`/* fail-safe handler for recursive errors */`
410	`if(inError == 3) {`	408	`if(inError == 3) {`
411	`/* Can REprintf generate an error? If so we should guard for it */`	409	`/* Can REprintf generate an error? If so we should guard for it */`
412	`REprintf("Error during wrapup: ");`	410	`REprintf("Error during wrapup: ");`
413	`/* this does NOT try to print the call since that could`	411	`/* this does NOT try to print the call since that could`
414	`cause a cascade of error calls */`	412	`cause a cascade of error calls */`
415	`Rvsnprintf(errbuf, sizeof(errbuf), format, ap);`	413	`Rvsnprintf(errbuf, sizeof(errbuf), format, ap);`
416	`REprintf("%s\n", errbuf);`	414	`REprintf("%s\n", errbuf);`
417	`}`	415	`}`
418	`if (R_Warnings != R_NilValue) {`	416	`if (R_Warnings != R_NilValue) {`
419	`R_CollectWarnings = 0;`	417	`R_CollectWarnings = 0;`
420	`R_Warnings = R_NilValue;`	418	`R_Warnings = R_NilValue;`
421	`REprintf("Lost warning messages\n");`	419	`REprintf("Lost warning messages\n");`
422	`}`	420	`}`
423	`jump_to_top_ex(FALSE, FALSE, FALSE, FALSE, FALSE);`	421	`jump_to_top_ex(FALSE, FALSE, FALSE, FALSE, FALSE);`
424	`}`	422	`}`
425		423
426	`/* set up a context to restore inError value on exit */`	424	`/* set up a context to restore inError value on exit */`
427	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`	425	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,`
428	`R_NilValue, R_NilValue);`	426	`R_NilValue, R_NilValue);`
429	`cntxt.cend = &restore_inError;`	427	`cntxt.cend = &restore_inError;`
430	`cntxt.cenddata = &oldInError;`	428	`cntxt.cenddata = &oldInError;`
431	`oldInError = inError;`	429	`oldInError = inError;`
432	`inError = 1;`	430	`inError = 1;`
433		431
434	`if(call != R_NilValue) {`	432	`if(call != R_NilValue) {`
435	`char *head = "Error in ";`	433	`char *head = "Error in ";`
436	`char *mid = " : ";`	434	`char *mid = " : ";`
437	`char tail = "\n\t";/ <- TAB */`	435	`char tail = "\n\t";/ <- TAB */`
438	`int len = strlen(head) + strlen(mid) + strlen(tail);`	436	`int len = strlen(head) + strlen(mid) + strlen(tail);`
439		437
440	`dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE, FALSE), 0));`	438	`dcall = CHAR(STRING_ELT(deparse1(call, 0, SIMPLEDEPARSE), 0));`
441	`if (strlen(dcall) + len < BUFSIZE) {`	439	`if (strlen(dcall) + len < BUFSIZE) {`
442	`sprintf(errbuf, "%s%s%s", head, dcall, mid);`	440	`sprintf(errbuf, "%s%s%s", head, dcall, mid);`
443	`if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);`	441	`if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);`
444	`}`	442	`}`
445	`else`	443	`else`
446	`sprintf(errbuf, "Error: ");`	444	`sprintf(errbuf, "Error: ");`
447	`}`	445	`}`
448	`else`	446	`else`
449	`sprintf(errbuf, "Error: ");`	447	`sprintf(errbuf, "Error: ");`
450		448
451	`p = errbuf + strlen(errbuf);`	449	`p = errbuf + strlen(errbuf);`
452	`Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);`	450	`Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);`
453	`p = errbuf + strlen(errbuf) - 1;`	451	`p = errbuf + strlen(errbuf) - 1;`
454	`if(*p != '\n') strcat(errbuf, "\n");`	452	`if(*p != '\n') strcat(errbuf, "\n");`
455	`if (R_ShowErrorMessages) REprintf("%s", errbuf);`	453	`if (R_ShowErrorMessages) REprintf("%s", errbuf);`
456		454
457	`if( R_ShowErrorMessages && R_CollectWarnings ) {`	455	`if( R_ShowErrorMessages && R_CollectWarnings ) {`
458	`REprintf("In addition: ");`	456	`REprintf("In addition: ");`
459	`PrintWarnings();`	457	`PrintWarnings();`
460	`}`	458	`}`
461		459
462	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`	460	`jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE);`
463		461
464	`/* not reached */`	462	`/* not reached */`
465	`endcontext(&cntxt);`	463	`endcontext(&cntxt);`
466	`inError = oldInError;`	464	`inError = oldInError;`
467	`}`	465	`}`
468		466
469	`static void errorcall_dflt(SEXP call, const char *format,...)`	467	`static void errorcall_dflt(SEXP call, const char *format,...)`
470	`{`	468	`{`
471	`va_list(ap);`	469	`va_list(ap);`
472		470
473	`va_start(ap, format);`	471	`va_start(ap, format);`
474	`verrorcall_dflt(call, format, ap);`	472	`verrorcall_dflt(call, format, ap);`
475	`va_end(ap);`	473	`va_end(ap);`
476	`}`	474	`}`
477		475
478	`void errorcall(SEXP call, const char *format,...)`	476	`void errorcall(SEXP call, const char *format,...)`
479	`{`	477	`{`
480	`va_list(ap);`	478	`va_list(ap);`
481		479
482	`#ifdef NEW_CONDITION_HANDLING`	480	`#ifdef NEW_CONDITION_HANDLING`
483	`va_start(ap, format);`	481	`va_start(ap, format);`
484	`vsignalError(call, format, ap);`	482	`vsignalError(call, format, ap);`
485	`va_end(ap);`	483	`va_end(ap);`
486	`#endif`	484	`#endif`
487		485
488	`if (R_ErrorHook != NULL) {`	486	`if (R_ErrorHook != NULL) {`
489	`char buf[BUFSIZE];`	487	`char buf[BUFSIZE];`
490	`void (hook)(SEXP, char ) = R_ErrorHook;`	488	`void (hook)(SEXP, char ) = R_ErrorHook;`
491	`R_ErrorHook = NULL; /* to avoid recursion */`	489	`R_ErrorHook = NULL; /* to avoid recursion */`
492	`va_start(ap, format);`	490	`va_start(ap, format);`
493	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`	491	`Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);`
494	`va_end(ap);`	492	`va_end(ap);`
495	`hook(call, buf);`	493	`hook(call, buf);`
496	`}`	494	`}`
497		495
498	`va_start(ap, format);`	496	`va_start(ap, format);`
499	`verrorcall_dflt(call, format, ap);`	497	`verrorcall_dflt(call, format, ap);`
500	`va_end(ap);`	498	`va_end(ap);`

The R Project SVN R

(root)/branches/djm-source/src/main/errors.c @ 34412 – Rev 29864 → 30691