| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1995--2018 The R Core Team. |
| * |
| * This program is free software; you can redistribute it and/or modify |
| * it under the terms of the GNU General Public License as published by |
| * the Free Software Foundation; either version 2 of the License, or |
| * (at your option) any later version. |
| * |
| * This program is distributed in the hope that it will be useful, |
| * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| * GNU General Public License for more details. |
| * |
| * You should have received a copy of the GNU General Public License |
| * along with this program; if not, a copy is available at |
| * https://www.R-project.org/Licenses/ |
| */ |
| |
| #ifdef HAVE_CONFIG_H |
| #include <config.h> |
| #endif |
| |
| #define R_USE_SIGNALS 1 |
| #include <Defn.h> |
| #include <Internal.h> |
| /* -> Errormsg.h */ |
| #include <Startup.h> /* rather cleanup ..*/ |
| #include <Rconnections.h> |
| #include <Rinterface.h> |
| #include <R_ext/GraphicsEngine.h> /* for GEonExit */ |
| #include <Rmath.h> /* for imax2 */ |
| #include <R_ext/Print.h> |
| #include <stdarg.h> |
| |
| #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 int noBreakWarning = 0; |
| |
| static void try_jump_to_restart(void); |
| // The next is crucial to the use of NORET attributes. |
| static void NORET |
| jump_to_top_ex(Rboolean, Rboolean, Rboolean, Rboolean, Rboolean); |
| static void signalInterrupt(void); |
| static char * R_ConciseTraceback(SEXP call, int skip); |
| |
| /* Interface / Calling Hierarchy : |
| |
| R__stop() -> do_error -> errorcall --> (eventually) jump_to_top_ex |
| / |
| error |
| |
| R__warning()-> do_warning -> warningcall -> if(warn >= 2) errorcall |
| / |
| warning / |
| |
| ErrorMessage()-> errorcall (but with message from ErrorDB[]) |
| |
| WarningMessage()-> warningcall (but with message from WarningDB[]). |
| */ |
| |
| void NORET R_SignalCStackOverflow(intptr_t usage) |
| { |
| /* We do need some stack space to process error recovery, so |
| temporarily raise the limit. We have 5% head room because we |
| reduced R_CStackLimit to 95% of the initial value in |
| setup_Rmainloop. |
| */ |
| if (R_OldCStackLimit == 0) { |
| R_OldCStackLimit = R_CStackLimit; |
| R_CStackLimit = (uintptr_t) (R_CStackLimit / 0.95); |
| } |
| |
| errorcall(R_NilValue, "C stack usage %ld is too close to the limit", |
| usage); |
| /* Do not translate this, to save stack space */ |
| } |
| |
| void (R_CheckStack)(void) |
| { |
| int dummy; |
| intptr_t usage = R_CStackDir * (R_CStackStart - (uintptr_t)&dummy); |
| |
| /* printf("usage %ld\n", usage); */ |
| if(R_CStackLimit != -1 && usage > ((intptr_t) R_CStackLimit)) |
| R_SignalCStackOverflow(usage); |
| } |
| |
| void R_CheckStack2(size_t extra) |
| { |
| int dummy; |
| intptr_t usage = R_CStackDir * (R_CStackStart - (uintptr_t)&dummy); |
| |
| /* do it this way, as some compilers do usage + extra |
| in unsigned arithmetic */ |
| usage += extra; |
| if(R_CStackLimit != -1 && usage > ((intptr_t) R_CStackLimit)) |
| R_SignalCStackOverflow(usage); |
| |
| } |
| |
| void R_CheckUserInterrupt(void) |
| { |
| R_CheckStack(); |
| |
| /* Don't do any processing of interrupts, timing limits, or other |
| asynchronous events if interrupts are suspended. */ |
| if (R_interrupts_suspended) return; |
| |
| /* This is the point where GUI systems need to do enough event |
| processing to determine whether there is a user interrupt event |
| pending. Need to be careful not to do too much event |
| processing though: if event handlers written in R are allowed |
| to run at this point then we end up with concurrent R |
| evaluations and that can cause problems until we have proper |
| concurrency support. LT */ |
| |
| R_ProcessEvents(); /* Also processes timing limits */ |
| if (R_interrupts_pending) onintr(); |
| } |
| |
| static SEXP getInterruptCondition(); |
| |
| static void onintrEx(Rboolean resumeOK) |
| { |
| if (R_interrupts_suspended) { |
| R_interrupts_pending = 1; |
| return; |
| } |
| else R_interrupts_pending = 0; |
| |
| if (resumeOK) { |
| SEXP rho = R_GlobalContext->cloenv; |
| int dbflag = RDEBUG(rho); |
| RCNTXT restartcontext; |
| begincontext(&restartcontext, CTXT_RESTART, R_NilValue, R_GlobalEnv, |
| R_BaseEnv, R_NilValue, R_NilValue); |
| if (SETJMP(restartcontext.cjmpbuf)) { |
| SET_RDEBUG(rho, dbflag); /* in case browser() has messed with it */ |
| R_ReturnedValue = R_NilValue; |
| R_Visible = FALSE; |
| endcontext(&restartcontext); |
| return; |
| } |
| R_InsertRestartHandlers(&restartcontext, "resume"); |
| signalInterrupt(); |
| endcontext(&restartcontext); |
| } |
| else signalInterrupt(); |
| |
| /* Interrupts do not inherit from error, so we should not run the |
| user erro handler. But we have been, so as a transition, |
| continue to use options('error') if options('interrupt') is not |
| set */ |
| Rboolean tryUserError = GetOption1(install("interrupt")) == R_NilValue; |
| |
| REprintf("\n"); |
| /* Attempt to save a traceback, show warnings, and reset console; |
| also stop at restart (try/browser) frames. Not clear this is |
| what we really want, but this preserves current behavior */ |
| jump_to_top_ex(TRUE, tryUserError, TRUE, TRUE, FALSE); |
| } |
| |
| void onintr() { onintrEx(TRUE); } |
| void onintrNoResume() { onintrEx(FALSE); } |
| |
| /* SIGUSR1: save and quit |
| SIGUSR2: save and quit, don't run .Last or on.exit(). |
| |
| These do far more processing than is allowed in a signal handler .... |
| */ |
| |
| 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, R_nwarnings); |
| setAttrib(R_Warnings, R_NamesSymbol, allocVector(STRSXP, R_nwarnings)); |
| } |
| |
| /* Rvsnprintf: like vsnprintf, but guaranteed to null-terminate and not to |
| split multi-byte characters */ |
| #ifdef Win32 |
| int trio_vsnprintf(char *buffer, size_t bufferSize, const char *format, |
| va_list args); |
| |
| static int Rvsnprintf(char *buf, size_t size, const char *format, va_list ap) |
| { |
| int val; |
| val = trio_vsnprintf(buf, size, format, ap); |
| buf[size-1] = '\0'; |
| if (val >= size) |
| mbcsTruncateToValid(buf); |
| return val; |
| } |
| #else |
| 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'; |
| if (val >= size) |
| mbcsTruncateToValid(buf); |
| return val; |
| } |
| #endif |
| |
| /* Rsnprintf: like snprintf, but guaranteed to null-terminate and not to |
| split multi-byte characters */ |
| static int Rsnprintf(char *str, size_t size, const char *format, ...) |
| { |
| int val; |
| va_list ap; |
| |
| va_start(ap, format); |
| val = Rvsnprintf(str, size, format, ap); |
| va_end(ap); |
| |
| return val; |
| } |
| |
| /* Rstrncat: like strncat, but guaranteed not to split multi-byte characters */ |
| static char *Rstrncat(char *dest, const char *src, size_t n) |
| { |
| size_t after; |
| size_t before = strlen(dest); |
| |
| strncat(dest, src, n); |
| |
| after = strlen(dest); |
| if (after - before == n) |
| /* the string may have been truncated, but we cannot know for sure |
| because str may not be null terminated */ |
| mbcsTruncateToValid(dest + before); |
| |
| return dest; |
| } |
| |
| /* Rstrncat: like strncpy, but guaranteed to null-terminate and not to |
| split multi-byte characters */ |
| static char *Rstrncpy(char *dest, const char *src, size_t n) |
| { |
| strncpy(dest, src, n); |
| if (dest[n-1] != '\0') { |
| dest[n-1] = '\0'; |
| mbcsTruncateToValid(dest); |
| } |
| return dest; |
| } |
| |
| #define BUFSIZE 8192 |
| static R_INLINE void RprintTrunc(char *buf, int truncated) |
| { |
| if(R_WarnLength < BUFSIZE - 20 && |
| (truncated || strlen(buf) == R_WarnLength)) { |
| |
| strcat(buf, " "); |
| strcat(buf, _("[... truncated]")); |
| } |
| } |
| |
| static SEXP getCurrentCall() |
| { |
| RCNTXT *c = R_GlobalContext; |
| |
| /* This can be called before R_GlobalContext is defined, so... */ |
| /* If profiling is on, this can be a CTXT_BUILTIN */ |
| |
| if (c && (c->callflag & CTXT_BUILTIN)) c = c->nextcontext; |
| if (c == R_GlobalContext && R_BCIntActive) |
| return R_getBCInterpreterExpression(); |
| else |
| return c ? c->call : R_NilValue; |
| } |
| |
| void warning(const char *format, ...) |
| { |
| char buf[BUFSIZE], *p; |
| |
| va_list(ap); |
| va_start(ap, format); |
| size_t psize; |
| int pval; |
| |
| psize = min(BUFSIZE, R_WarnLength+1); |
| pval = Rvsnprintf(buf, psize, format, ap); |
| va_end(ap); |
| p = buf + strlen(buf) - 1; |
| if(strlen(buf) > 0 && *p == '\n') *p = '\0'; |
| RprintTrunc(buf, pval >= psize); |
| warningcall(getCurrentCall(), "%s", buf); |
| } |
| |
| /* 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 NORET invokeRestart(SEXP, SEXP); |
| |
| static void reset_inWarning(void *data) |
| { |
| inWarning = 0; |
| } |
| |
| #include <rlocale.h> |
| |
| static int wd(const char * buf) |
| { |
| int nc = (int) mbstowcs(NULL, buf, 0), nw; |
| if(nc > 0 && nc < 2000) { |
| wchar_t wc[2000]; |
| mbstowcs(wc, buf, nc + 1); |
| nw = Ri18n_wcswidth(wc, 2147483647); |
| return (nw < 1) ? nc : nw; |
| } |
| return nc; |
| } |
| |
| static void vwarningcall_dflt(SEXP call, const char *format, va_list ap) |
| { |
| int w; |
| SEXP names, s; |
| const char *dcall; |
| char buf[BUFSIZE]; |
| RCNTXT *cptr; |
| RCNTXT cntxt; |
| size_t psize; |
| int pval; |
| |
| if (inWarning) |
| return; |
| |
| s = GetOption1(install("warning.expression")); |
| if( s != R_NilValue ) { |
| if( !isLanguage(s) && ! isExpression(s) ) |
| error(_("invalid option \"warning.expression\"")); |
| cptr = R_GlobalContext; |
| while ( !(cptr->callflag & CTXT_FUNCTION) && cptr->callflag ) |
| cptr = cptr->nextcontext; |
| eval(s, cptr->cloenv); |
| return; |
| } |
| |
| w = asInteger(GetOption1(install("warn"))); |
| |
| if( w == NA_INTEGER ) /* set to a sensible value */ |
| w = 0; |
| |
| if( w <= 0 && immediateWarning ) w = 1; |
| |
| if( w < 0 || inWarning || inError) /* ignore if w<0 or already in here*/ |
| return; |
| |
| /* set up a context which will restore inWarning if there is an exit */ |
| begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, |
| R_NilValue, R_NilValue); |
| cntxt.cend = &reset_inWarning; |
| |
| inWarning = 1; |
| |
| if(w >= 2) { /* make it an error */ |
| psize = min(BUFSIZE, R_WarnLength+1); |
| pval = Rvsnprintf(buf, psize, format, ap); |
| RprintTrunc(buf, pval >= psize); |
| inWarning = 0; /* PR#1570 */ |
| errorcall(call, _("(converted from warning) %s"), buf); |
| } |
| else if(w == 1) { /* print as they happen */ |
| char *tr; |
| if( call != R_NilValue ) { |
| dcall = CHAR(STRING_ELT(deparse1s(call), 0)); |
| } else dcall = ""; |
| psize = min(BUFSIZE, R_WarnLength+1); |
| pval = Rvsnprintf(buf, psize, format, ap); |
| RprintTrunc(buf, pval >= psize); |
| |
| if(dcall[0] == '\0') REprintf(_("Warning:")); |
| else { |
| REprintf(_("Warning in %s :"), dcall); |
| if(!(noBreakWarning || |
| ( mbcslocale && 18 + wd(dcall) + wd(buf) <= LONGWARN) || |
| (!mbcslocale && 18 + strlen(dcall) + strlen(buf) <= LONGWARN))) |
| REprintf("\n "); |
| } |
| REprintf(" %s\n", buf); |
| if(R_ShowWarnCalls && call != R_NilValue) { |
| tr = R_ConciseTraceback(call, 0); |
| if (strlen(tr)) {REprintf(_("Calls:")); REprintf(" %s\n", tr);} |
| } |
| } |
| else if(w == 0) { /* collect them */ |
| if(!R_CollectWarnings) setupwarnings(); |
| if(R_CollectWarnings < R_nwarnings) { |
| SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call); |
| psize = min(BUFSIZE, R_WarnLength+1); |
| pval = Rvsnprintf(buf, psize, format, ap); |
| RprintTrunc(buf, pval >= psize); |
| if(R_ShowWarnCalls && call != R_NilValue) { |
| char *tr = R_ConciseTraceback(call, 0); |
| size_t nc = strlen(tr); |
| if (nc && nc + (int)strlen(buf) + 8 < BUFSIZE) { |
| strcat(buf, "\n"); |
| strcat(buf, _("Calls:")); |
| strcat(buf, " "); |
| strcat(buf, tr); |
| } |
| } |
| names = CAR(ATTRIB(R_Warnings)); |
| SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf)); |
| } |
| } |
| /* else: w <= -1 */ |
| endcontext(&cntxt); |
| inWarning = 0; |
| } |
| |
| static void warningcall_dflt(SEXP call, const char *format,...) |
| { |
| va_list(ap); |
| |
| va_start(ap, format); |
| vwarningcall_dflt(call, format, ap); |
| va_end(ap); |
| } |
| |
| void warningcall(SEXP call, const char *format, ...) |
| { |
| va_list(ap); |
| va_start(ap, format); |
| vsignalWarning(call, format, ap); |
| va_end(ap); |
| } |
| |
| void warningcall_immediate(SEXP call, const char *format, ...) |
| { |
| va_list(ap); |
| |
| immediateWarning = 1; |
| va_start(ap, format); |
| vsignalWarning(call, format, ap); |
| va_end(ap); |
| immediateWarning = 0; |
| } |
| |
| static void cleanup_PrintWarnings(void *data) |
| { |
| if (R_CollectWarnings) { |
| R_CollectWarnings = 0; |
| R_Warnings = R_NilValue; |
| REprintf(_("Lost warning messages\n")); |
| } |
| inPrintWarnings = 0; |
| } |
| |
| attribute_hidden |
| void PrintWarnings(void) |
| { |
| int i; |
| char *header; |
| SEXP names, s, t; |
| RCNTXT cntxt; |
| |
| if (R_CollectWarnings == 0) |
| return; |
| else if (inPrintWarnings) { |
| if (R_CollectWarnings) { |
| R_CollectWarnings = 0; |
| R_Warnings = R_NilValue; |
| REprintf(_("Lost warning messages\n")); |
| } |
| return; |
| } |
| |
| /* set up a context which will restore inPrintWarnings if there is |
| an exit */ |
| begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, |
| R_NilValue, R_NilValue); |
| cntxt.cend = &cleanup_PrintWarnings; |
| |
| inPrintWarnings = 1; |
| header = ngettext("Warning message:", "Warning messages:", |
| R_CollectWarnings); |
| if( R_CollectWarnings == 1 ) { |
| REprintf("%s\n", header); |
| names = CAR(ATTRIB(R_Warnings)); |
| if( VECTOR_ELT(R_Warnings, 0) == R_NilValue ) |
| REprintf("%s \n", CHAR(STRING_ELT(names, 0))); |
| else { |
| const char *dcall, *msg = CHAR(STRING_ELT(names, 0)); |
| dcall = CHAR(STRING_ELT(deparse1s(VECTOR_ELT(R_Warnings, 0)), 0)); |
| REprintf(_("In %s :"), dcall); |
| 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) REprintf("\n "); |
| } else { |
| size_t msgline1 = strlen(msg); |
| char *p = strchr(msg, '\n'); |
| if (p) msgline1 = (int)(p - msg); |
| if (6 + strlen(dcall) + msgline1 > LONGWARN) REprintf("\n "); |
| } |
| REprintf(" %s\n", msg); |
| } |
| } else if( R_CollectWarnings <= 10 ) { |
| REprintf("%s\n", header); |
| names = CAR(ATTRIB(R_Warnings)); |
| for(i = 0; i < R_CollectWarnings; i++) { |
| if( VECTOR_ELT(R_Warnings, i) == R_NilValue ) { |
| REprintf("%d: %s \n", i+1, CHAR(STRING_ELT(names, i))); |
| } else { |
| const char *dcall, *msg = CHAR(STRING_ELT(names, i)); |
| dcall = CHAR(STRING_ELT(deparse1s(VECTOR_ELT(R_Warnings, i)), 0)); |
| REprintf("%d: ", i + 1); |
| REprintf(_("In %s :"), dcall); |
| if (mbcslocale) { |
| int msgline1; |
| char *p = strchr(msg, '\n'); |
| if (p) { |
| *p = '\0'; |
| msgline1 = wd(msg); |
| *p = '\n'; |
| } else msgline1 = wd(msg); |
| if (10 + wd(dcall) + msgline1 > LONGWARN) { |
| REprintf("\n "); |
| } |
| } else { |
| size_t msgline1 = strlen(msg); |
| char *p = strchr(msg, '\n'); |
| if (p) msgline1 = (int)(p - msg); |
| if (10 + strlen(dcall) + msgline1 > LONGWARN) { |
| REprintf("\n "); |
| } |
| } |
| REprintf(" %s\n", msg); |
| } |
| } |
| } else { |
| if (R_CollectWarnings < R_nwarnings) |
| REprintf(ngettext("There was %d warning (use warnings() to see it)", |
| "There were %d warnings (use warnings() to see them)", |
| R_CollectWarnings), |
| R_CollectWarnings); |
| else |
| REprintf(_("There were %d or more warnings (use warnings() to see the first %d)"), |
| R_nwarnings, R_nwarnings); |
| REprintf("\n"); |
| } |
| /* now truncate and install last.warning */ |
| PROTECT(s = allocVector(VECSXP, R_CollectWarnings)); |
| PROTECT(t = allocVector(STRSXP, R_CollectWarnings)); |
| names = CAR(ATTRIB(R_Warnings)); |
| for(i = 0; i < R_CollectWarnings; i++) { |
| SET_VECTOR_ELT(s, i, VECTOR_ELT(R_Warnings, i)); |
| SET_STRING_ELT(t, i, STRING_ELT(names, i)); |
| } |
| setAttrib(s, R_NamesSymbol, t); |
| SET_SYMVALUE(install("last.warning"), s); |
| UNPROTECT(2); |
| |
| endcontext(&cntxt); |
| |
| inPrintWarnings = 0; |
| R_CollectWarnings = 0; |
| R_Warnings = R_NilValue; |
| return; |
| } |
| |
| /* Return a constructed source location (e.g. filename#123) from a srcref. If the srcref |
| is not valid "" will be returned. |
| */ |
| |
| static SEXP GetSrcLoc(SEXP srcref) |
| { |
| SEXP sep, line, result, srcfile; |
| if (TYPEOF(srcref) != INTSXP || length(srcref) < 4) |
| return ScalarString(mkChar("")); |
| |
| PROTECT(srcref); |
| PROTECT(srcfile = R_GetSrcFilename(srcref)); |
| SEXP e2 = PROTECT(lang2( install("basename"), srcfile)); |
| PROTECT(srcfile = eval(e2, R_BaseEnv ) ); |
| PROTECT(sep = ScalarString(mkChar("#"))); |
| PROTECT(line = ScalarInteger(INTEGER(srcref)[0])); |
| SEXP e = PROTECT(lang4( install("paste0"), srcfile, sep, line )); |
| result = eval(e, R_BaseEnv ); |
| UNPROTECT(7); |
| return result; |
| } |
| |
| static char errbuf[BUFSIZE + 1]; /* add 1 to leave room for a null byte */ |
| |
| #define ERRBUFCAT(txt) Rstrncat(errbuf, txt, BUFSIZE - strlen(errbuf)) |
| |
| const char *R_curErrorBuf() { |
| return (const char *)errbuf; |
| } |
| |
| /* 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; |
| } |
| |
| /* Do not check constants on error more than this number of times per one |
| R process lifetime; if so many errors are generated, the performance |
| overhead due to the checks would be too high, and the program is doing |
| something strange anyway (i.e. running no-segfault tests). The constant |
| checks in GC and session exit (or .Call) do not have such limit. */ |
| static int allowedConstsChecks = 1000; |
| |
| static void NORET |
| verrorcall_dflt(SEXP call, const char *format, va_list ap) |
| { |
| if (allowedConstsChecks > 0) { |
| allowedConstsChecks--; |
| R_checkConstants(TRUE); |
| } |
| RCNTXT cntxt; |
| char *p, *tr; |
| 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")); |
| } |
| 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], tmp2[BUFSIZE]; |
| char *head = _("Error in "), *tail = "\n "; |
| SEXP srcloc = R_NilValue; // -Wall |
| size_t len = 0; // indicates if srcloc has been set |
| int protected = 0, skip = NA_INTEGER; |
| SEXP opt = GetOption1(install("show.error.locations")); |
| if (!isNull(opt)) { |
| if (TYPEOF(opt) == STRSXP && length(opt) == 1) { |
| if (pmatch(ScalarString(mkChar("top")), opt, 0)) skip = 0; |
| else if (pmatch(ScalarString(mkChar("bottom")), opt, 0)) skip = -1; |
| } else if (TYPEOF(opt) == LGLSXP) |
| skip = asLogical(opt) == 1 ? 0 : NA_INTEGER; |
| else |
| skip = asInteger(opt); |
| } |
| |
| const char *dcall = CHAR(STRING_ELT(deparse1s(call), 0)); |
| Rsnprintf(tmp2, BUFSIZE, "%s", head); |
| if (skip != NA_INTEGER) { |
| PROTECT(srcloc = GetSrcLoc(R_GetCurrentSrcref(skip))); |
| protected++; |
| len = strlen(CHAR(STRING_ELT(srcloc, 0))); |
| if (len) |
| Rsnprintf(tmp2, BUFSIZE, _("Error in %s (from %s) : "), |
| dcall, CHAR(STRING_ELT(srcloc, 0))); |
| } |
| |
| Rvsnprintf(tmp, min(BUFSIZE, R_WarnLength) - strlen(head), format, ap); |
| if (strlen(tmp2) + strlen(tail) + strlen(tmp) < BUFSIZE) { |
| if(len) Rsnprintf(errbuf, BUFSIZE, |
| _("Error in %s (from %s) : "), |
| dcall, CHAR(STRING_ELT(srcloc, 0))); |
| else Rsnprintf(errbuf, BUFSIZE, _("Error in %s : "), dcall); |
| if (mbcslocale) { |
| int msgline1; |
| char *p = strchr(tmp, '\n'); |
| if (p) { |
| *p = '\0'; |
| msgline1 = wd(tmp); |
| *p = '\n'; |
| } else msgline1 = wd(tmp); |
| // gcc 8 warns here |
| // 'output may be truncated copying between 0 and 8191 bytes from a string of length 8191' |
| // but truncation is intentional. |
| if (14 + wd(dcall) + msgline1 > LONGWARN) |
| ERRBUFCAT(tail); |
| } else { |
| size_t msgline1 = strlen(tmp); |
| char *p = strchr(tmp, '\n'); |
| if (p) msgline1 = (int)(p - tmp); |
| if (14 + strlen(dcall) + msgline1 > LONGWARN) |
| ERRBUFCAT(tail); |
| } |
| ERRBUFCAT(tmp); |
| } else { |
| Rsnprintf(errbuf, BUFSIZE, _("Error: ")); |
| ERRBUFCAT(tmp); // FIXME |
| } |
| UNPROTECT(protected); |
| } |
| else { |
| Rsnprintf(errbuf, BUFSIZE, _("Error: ")); |
| p = errbuf + strlen(errbuf); |
| Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap); |
| } |
| |
| size_t nc = strlen(errbuf); |
| if (nc == BUFSIZE - 1) { |
| errbuf[BUFSIZE - 4] = '.'; |
| errbuf[BUFSIZE - 3] = '.'; |
| errbuf[BUFSIZE - 2] = '.'; |
| errbuf[BUFSIZE - 1] = '\n'; |
| } |
| else { |
| p = errbuf + nc - 1; |
| if(*p != '\n') ERRBUFCAT("\n"); |
| } |
| |
| if(R_ShowErrorCalls && call != R_NilValue) { /* assume we want to avoid deparse */ |
| tr = R_ConciseTraceback(call, 0); |
| size_t nc = strlen(tr); |
| if (nc && nc + strlen(errbuf) + 8 < BUFSIZE) { |
| ERRBUFCAT(_("Calls:")); |
| ERRBUFCAT(" "); |
| ERRBUFCAT(tr); |
| ERRBUFCAT("\n"); |
| } |
| } |
| if (R_ShowErrorMessages) REprintf("%s", errbuf); |
| |
| if( R_ShowErrorMessages && R_CollectWarnings ) { |
| REprintf(_("In addition: ")); |
| PrintWarnings(); |
| } |
| |
| jump_to_top_ex(TRUE, TRUE, TRUE, TRUE, FALSE); |
| |
| /* not reached */ |
| endcontext(&cntxt); |
| inError = oldInError; |
| } |
| |
| static void NORET errorcall_dflt(SEXP call, const char *format,...) |
| { |
| va_list(ap); |
| |
| va_start(ap, format); |
| verrorcall_dflt(call, format, ap); |
| va_end(ap); |
| } |
| |
| void NORET errorcall(SEXP call, const char *format,...) |
| { |
| va_list(ap); |
| |
| if (call == R_CurrentExpression) |
| /* behave like error( */ |
| call = getCurrentCall(); |
| |
| va_start(ap, format); |
| vsignalError(call, format, ap); |
| va_end(ap); |
| |
| 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); |
| } |
| |
| /* Like errorcall, but copies all data for the error message into a buffer |
| before doing anything else. */ |
| attribute_hidden |
| void NORET errorcall_cpy(SEXP call, const char *format, ...) |
| { |
| char buf[BUFSIZE]; |
| |
| va_list(ap); |
| va_start(ap, format); |
| Rvsnprintf(buf, BUFSIZE, format, ap); |
| va_end(ap); |
| |
| errorcall(call, "%s", buf); |
| } |
| |
| // geterrmessage(): Return (the global) 'errbuf' as R string |
| SEXP attribute_hidden do_geterrmessage(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| checkArity(op, args); |
| SEXP res = PROTECT(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); |
| errorcall(getCurrentCall(), "%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; |
| |
| /* don't use options("error") when handling a C stack overflow */ |
| if (R_OldCStackLimit == 0 && tryUserHandler && inError < 3) { |
| if (! inError) |
| inError = 1; |
| |
| /* now see if options("error") is set */ |
| s = GetOption1(install("error")); |
| 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. 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; |
| } |
| } |
| |
| R_jumpctxt(R_ToplevelContext, 0, NULL); |
| } |
| |
| void NORET 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) |
| { |
| checkArity(op, args); |
| #ifdef ENABLE_NLS |
| const char *domain = "", *cfn; |
| char *buf; |
| SEXP ans, string = CADR(args); |
| int i, n = LENGTH(string); |
| |
| checkArity(op, args); |
| if(isNull(string) || !n) return string; |
| |
| if(!isString(string)) error(_("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) { |
| /* stop() etc have internal call to .makeMessage */ |
| cfn = CHAR(STRING_ELT(deparse1s(CAR(cptr->call)), 0)); |
| if(streql(cfn, "stop") || streql(cfn, "warning") |
| || streql(cfn, "message")) continue; |
| rho = cptr->cloenv; |
| } |
| 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)) { |
| size_t len = strlen(domain)+3; |
| R_CheckStack2(len); |
| buf = (char *) alloca(len); |
| Rsnprintf(buf, len, "R-%s", domain); |
| domain = buf; |
| } |
| } else if(isString(CAR(args))) |
| domain = translateChar(STRING_ELT(CAR(args),0)); |
| else if(isLogical(CAR(args)) && LENGTH(CAR(args)) == 1 && LOGICAL(CAR(args))[0] == NA_LOGICAL) ; |
| else error(_("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; |
| R_CheckStack2(strlen(This) + 1); |
| tmp = (char *) alloca(strlen(This) + 1); |
| 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) { |
| R_CheckStack2(ihead + 1); |
| head = (char *) alloca(ihead + 1); |
| Rstrncpy(head, tmp, ihead + 1); |
| tmp += ihead; |
| } |
| if(strlen(tmp)) |
| for(p = tmp+strlen(tmp)-1; |
| p >= tmp && (*p == ' ' || *p == '\t' || *p == '\n'); |
| p--, itail++) ; |
| if(itail > 0) { |
| R_CheckStack2(itail + 1); |
| tail = (char *) alloca(itail + 1); |
| 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); |
| R_CheckStack2(strlen(tr) + ihead + itail + 1); |
| tmp = (char *) alloca(strlen(tr) + ihead + itail + 1); |
| 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 = "", *cfn;; |
| 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 '%s' argument"), "n"); |
| if(!isString(msg1) || LENGTH(msg1) != 1) |
| error(_("'%s' must be a character string"), "msg1"); |
| if(!isString(msg2) || LENGTH(msg2) != 1) |
| error(_("'%s' must be a character string"), "msg2"); |
| |
| #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) { |
| /* stop() etc have internal call to .makeMessage */ |
| cfn = CHAR(STRING_ELT(deparse1s(CAR(cptr->call)), 0)); |
| if(streql(cfn, "stop") || streql(cfn, "warning") |
| || streql(cfn, "message")) continue; |
| rho = cptr->cloenv; |
| } |
| 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)) { |
| size_t len = strlen(domain)+3; |
| R_CheckStack2(len); |
| buf = (char *) alloca(len); |
| Rsnprintf(buf, len, "R-%s", domain); |
| domain = buf; |
| } |
| } else if(isString(sdom)) |
| domain = CHAR(STRING_ELT(sdom,0)); |
| else if(isLogical(sdom) && LENGTH(sdom) == 1 && LOGICAL(sdom)[0] == NA_LOGICAL) ; |
| else error(_("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) |
| error(_("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) |
| error(_("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 NORET 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; |
| checkArity(op, args); |
| |
| 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: */ |
| } |
| |
| SEXP attribute_hidden do_warning(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP c_call; |
| checkArity(op, args); |
| |
| 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(asLogical(CAR(args))) { /* noBreak = TRUE */ |
| noBreakWarning = 1; |
| } else |
| noBreakWarning = 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 */ |
| noBreakWarning = 0; |
| |
| return CAR(args); |
| } |
| |
| /* Error recovery for incorrect argument count error. */ |
| attribute_hidden |
| void NORET WrongArgCount(const char *s) |
| { |
| error(_("incorrect number of arguments to \"%s\""), s); |
| } |
| |
| |
| void NORET 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!)") }, |
| }; |
| |
| |
| attribute_hidden |
| void NORET 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); |
| } |
| |
| attribute_hidden |
| 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++; |
| } |
| |
| /* clang pre-3.9.0 says |
| warning: passing an object that undergoes default argument promotion to |
| 'va_start' has undefined behavior [-Wvarargs] |
| */ |
| va_start(ap, which_warn); |
| Rvsnprintf(buf, BUFSIZE, _(WarningDB[i].format), ap); |
| va_end(ap); |
| warningcall(call, "%s", buf); |
| } |
| |
| #ifdef UNUSED |
| /* temporary hook to allow experimenting with alternate warning mechanisms */ |
| static void (*R_WarningHook)(SEXP, char *) = NULL; |
| |
| 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 NORET 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?")); |
| |
| R_jumpctxt(R_ToplevelContext, CTXT_TOPLEVEL, NULL); |
| } |
| #endif |
| |
| static void R_SetErrmessage(const char *s) |
| { |
| Rstrncpy(errbuf, s, sizeof(errbuf) - 1); |
| } |
| |
| static void R_PrintDeferredWarnings(void) |
| { |
| if( R_ShowErrorMessages && R_CollectWarnings ) { |
| REprintf(_("In addition: ")); |
| PrintWarnings(); |
| } |
| } |
| |
| attribute_hidden |
| 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, deparse1m(c->call, 0, DEFAULTDEPARSE)); |
| if (c->srcref && !isNull(c->srcref)) { |
| SEXP sref; |
| if (c->srcref == R_InBCInterpreter) |
| sref = R_findBCInterpreterSrcref(c); |
| else |
| sref = c->srcref; |
| setAttrib(CAR(t), R_SrcrefSymbol, duplicate(sref)); |
| } |
| t = CDR(t); |
| } |
| } |
| UNPROTECT(1); |
| return s; |
| } |
| |
| SEXP attribute_hidden do_traceback(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int skip; |
| |
| checkArity(op, args); |
| skip = asInteger(CAR(args)); |
| |
| if (skip == NA_INTEGER || skip < 0 ) |
| error(_("invalid '%s' value"), "skip"); |
| |
| return R_GetTraceback(skip); |
| } |
| |
| static char * R_ConciseTraceback(SEXP call, int skip) |
| { |
| static char buf[560]; |
| RCNTXT *c; |
| size_t nl; |
| int 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 && TYPEOF(call) == LANGSXP) { |
| 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 4 |
| |
| static SEXP R_HandlerResultToken = NULL; |
| |
| void attribute_hidden R_FixupExitingHandlerResult(SEXP result) |
| { |
| /* The internal error handling mechanism stores the error message |
| in 'errbuf'. If an on.exit() action is processed while jumping |
| to an exiting handler for such an error, then endcontext() |
| calls R_FixupExitingHandlerResult to save the error message |
| currently in the buffer before processing the on.exit |
| action. This is in case an error occurs in the on.exit action |
| that over-writes the buffer. The allocation should occur in a |
| more favorable stack context than before the jump. The |
| R_HandlerResultToken is used to make sure the result being |
| modified is associated with jumping to an exiting handler. */ |
| if (result != NULL && |
| TYPEOF(result) == VECSXP && |
| XLENGTH(result) == RESULT_SIZE && |
| VECTOR_ELT(result, 0) == R_NilValue && |
| VECTOR_ELT(result, RESULT_SIZE - 1) == R_HandlerResultToken) { |
| SET_VECTOR_ELT(result, 0, mkString(errbuf)); |
| } |
| } |
| |
| 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; |
| |
| if (R_HandlerResultToken == NULL) { |
| R_HandlerResultToken = allocVector(VECSXP, 1); |
| R_PreserveObject(R_HandlerResultToken); |
| } |
| |
| 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)); |
| SET_VECTOR_ELT(result, RESULT_SIZE - 1, R_HandlerResultToken); |
| 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(void) |
| { |
| 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, hcall, qcall, qfun; |
| |
| hooksym = install(".signalSimpleWarning"); |
| if (SYMVALUE(hooksym) != R_UnboundValue && |
| SYMVALUE(R_QuoteSymbol) != R_UnboundValue) { |
| qfun = lang3(R_DoubleColonSymbol, R_BaseSymbol, R_QuoteSymbol); |
| PROTECT(qfun); |
| PROTECT(qcall = LCONS(qfun, LCONS(call, R_NilValue))); |
| PROTECT(hcall = LCONS(qcall, R_NilValue)); |
| Rvsnprintf(buf, BUFSIZE - 1, format, ap); |
| hcall = LCONS(mkString(buf), hcall); |
| PROTECT(hcall = LCONS(hooksym, hcall)); |
| eval(hcall, R_GlobalEnv); |
| UNPROTECT(4); |
| } |
| else vwarningcall_dflt(call, format, ap); |
| } |
| |
| static void NORET 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); |
| Rstrncpy(buf, localbuf, BUFSIZE); |
| /* Rvsnprintf(buf, BUFSIZE - 1, format, ap);*/ |
| if (IS_CALLING_ENTRY(entry)) { |
| if (ENTRY_HANDLER(entry) == R_RestartToken) |
| return; /* go to default error handling; do not reset stack */ |
| else { |
| /* if we are in the process of handling a C stack |
| overflow, treat all calling handlers as failed */ |
| if (R_OldCStackLimit) |
| break; |
| SEXP hooksym, hcall, qcall, qfun; |
| /* protect oldstack here, not outside loop, so handler |
| stack gets unwound in case error is protect stack |
| overflow */ |
| PROTECT(oldstack); |
| hooksym = install(".handleSimpleError"); |
| qfun = lang3(R_DoubleColonSymbol, R_BaseSymbol, |
| R_QuoteSymbol); |
| PROTECT(qcall = LCONS(qfun, |
| LCONS(call, R_NilValue))); |
| PROTECT(hcall = LCONS(qcall, R_NilValue)); |
| hcall = LCONS(mkString(buf), hcall); |
| hcall = LCONS(ENTRY_HANDLER(entry), hcall); |
| PROTECT(hcall = LCONS(hooksym, hcall)); |
| eval(hcall, R_GlobalEnv); |
| UNPROTECT(5); |
| } |
| } |
| 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(void) |
| { |
| 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(void) |
| { |
| /**** 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); |
| |
| SEXP h = GetOption1(install("interrupt")); |
| if (h != R_NilValue) { |
| SEXP call = PROTECT(LCONS(h, R_NilValue)); |
| eval(call, R_GlobalEnv); |
| } |
| } |
| |
| void attribute_hidden |
| R_InsertRestartHandlers(RCNTXT *cptr, const char *cname) |
| { |
| SEXP klass, rho, entry, name; |
| |
| if ((cptr->handlerstack != R_HandlerStack || |
| cptr->restartstack != R_RestartStack)) { |
| 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 = mkString(cname)); |
| PROTECT(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, mkString("restart")); |
| R_RestartStack = CONS(entry, R_RestartStack); |
| UNPROTECT(2); |
| } |
| |
| 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 NORET 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); |
| } |
| |
| |
| /* |
| * 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 = mkString("abort")); |
| PROTECT(entry = allocVector(VECSXP, 2)); |
| SET_VECTOR_ELT(entry, 0, name); |
| SET_VECTOR_ELT(entry, 1, R_NilValue); |
| setAttrib(entry, R_ClassSymbol, mkString("restart")); |
| UNPROTECT(2); |
| 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 NORET 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 NORET do_invokeRestart(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| CHECK_RESTART(CAR(args)); |
| invokeRestart(CAR(args), CADR(args)); |
| } |
| |
| 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)) |
| error(_("not in a try context")); |
| SET_RESTART_BIT_ON(R_GlobalContext->callflag); |
| R_InsertRestartHandlers(R_GlobalContext, "tryRestart"); |
| 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; |
| } |
| |
| SEXP attribute_hidden |
| do_interruptsSuspended(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| int orig_value = R_interrupts_suspended; |
| if (args != R_NilValue) |
| R_interrupts_suspended = asLogical(CAR(args)); |
| return ScalarLogical(orig_value); |
| } |
| |
| void attribute_hidden |
| R_BadValueInRCode(SEXP value, SEXP call, SEXP rho, const char *rawmsg, |
| const char *errmsg, const char *warnmsg, |
| const char *varname, Rboolean warnByDefault) |
| { |
| /* disable GC so that use of this temporary checking code does not |
| introduce new PROTECT errors e.g. in asLogical() use */ |
| R_CHECK_THREAD; |
| int enabled = R_GCEnabled; |
| R_GCEnabled = FALSE; |
| int nprotect = 0; |
| char *check = getenv(varname); |
| const void *vmax = vmaxget(); |
| Rboolean err = check && StringTrue(check); |
| if (!err && check && StringFalse(check)) |
| check = NULL; /* disabled */ |
| Rboolean abort = FALSE; /* R_Suicide/abort */ |
| Rboolean verbose = FALSE; |
| Rboolean warn = FALSE; |
| const char *pkgname = 0; |
| if (!err && check) { |
| const char *pprefix = "package:"; |
| const char *aprefix = "abort"; |
| const char *vprefix = "verbose"; |
| const char *wprefix = "warn"; |
| const char *cpname = "_R_CHECK_PACKAGE_NAME_"; |
| size_t lpprefix = strlen(pprefix); |
| size_t laprefix = strlen(aprefix); |
| size_t lvprefix = strlen(vprefix); |
| size_t lwprefix = strlen(wprefix); |
| size_t lcpname = strlen(cpname); |
| Rboolean ignore = FALSE; |
| |
| SEXP spkg = R_NilValue; |
| for(; rho != R_EmptyEnv; rho = ENCLOS(rho)) |
| if (R_IsPackageEnv(rho)) { |
| PROTECT(spkg = R_PackageEnvName(rho)); |
| nprotect++; |
| break; |
| } else if (R_IsNamespaceEnv(rho)) { |
| PROTECT(spkg = R_NamespaceEnvSpec(rho)); |
| nprotect++; |
| break; |
| } |
| if (spkg != R_NilValue) |
| pkgname = translateChar(STRING_ELT(spkg, 0)); |
| |
| while (check[0] != '\0') { |
| if (!strncmp(pprefix, check, lpprefix)) { |
| /* check starts with "package:" */ |
| check += lpprefix; |
| size_t arglen = 0; |
| const char *sep = strchr(check, ','); |
| if (sep) |
| arglen = sep - check; |
| else |
| arglen = strlen(check); |
| ignore = TRUE; |
| if (pkgname) { |
| if (!strncmp(check, pkgname, arglen) && strlen(pkgname) == arglen) |
| ignore = FALSE; |
| if (!strncmp(check, cpname, arglen) && lcpname == arglen) { |
| /* package name specified in _R_CHECK_PACKAGE_NAME */ |
| const char *envpname = getenv(cpname); |
| if (envpname && !strcmp(envpname, pkgname)) |
| ignore = FALSE; |
| } |
| } |
| check += arglen; |
| } else if (!strncmp(aprefix, check, laprefix)) { |
| /* check starts with "abort" */ |
| check += laprefix; |
| abort = TRUE; |
| } else if (!strncmp(vprefix, check, lvprefix)) { |
| /* check starts with "verbose" */ |
| check += lvprefix; |
| verbose = TRUE; |
| } else if (!strncmp(wprefix, check, lwprefix)) { |
| /* check starts with "warn" */ |
| check += lwprefix; |
| warn = TRUE; |
| } else if (check[0] == ',') { |
| check++; |
| } else |
| error("invalid value of %s", varname); |
| } |
| if (ignore) { |
| abort = FALSE; /* err is FALSE */ |
| verbose = FALSE; |
| warn = FALSE; |
| } else if (!abort && !warn) |
| err = TRUE; |
| } |
| if (verbose) { |
| int oldout = R_OutputCon; |
| R_OutputCon = 2; |
| int olderr = R_ErrorCon; |
| R_ErrorCon = 2; |
| REprintf(" ----------- FAILURE REPORT -------------- \n"); |
| REprintf(" --- failure: %s ---\n", rawmsg); |
| REprintf(" --- srcref --- \n"); |
| SrcrefPrompt("", R_getCurrentSrcref()); |
| REprintf("\n"); |
| if (pkgname) { |
| REprintf(" --- package (from environment) --- \n"); |
| REprintf("%s\n", pkgname); |
| } |
| REprintf(" --- call from context --- \n"); |
| PrintValue(R_GlobalContext->call); |
| REprintf(" --- call from argument --- \n"); |
| PrintValue(call); |
| REprintf(" --- R stacktrace ---\n"); |
| printwhere(); |
| REprintf(" --- value of length: %d type: %s ---\n", |
| length(value), type2char(TYPEOF(value))); |
| PrintValue(value); |
| REprintf(" --- function from context --- \n"); |
| if (R_GlobalContext->callfun != NULL && |
| TYPEOF(R_GlobalContext->callfun) == CLOSXP) |
| PrintValue(R_GlobalContext->callfun); |
| REprintf(" --- function search by body ---\n"); |
| if (R_GlobalContext->callfun != NULL && |
| TYPEOF(R_GlobalContext->callfun) == CLOSXP) |
| findFunctionForBody(R_ClosureExpr(R_GlobalContext->callfun)); |
| REprintf(" ----------- END OF FAILURE REPORT -------------- \n"); |
| R_OutputCon = oldout; |
| R_ErrorCon = olderr; |
| } |
| if (abort) |
| R_Suicide(rawmsg); |
| else if (err) |
| errorcall(call, errmsg); |
| else if (warn || warnByDefault) |
| warningcall(call, warnmsg); |
| vmaxset(vmax); |
| UNPROTECT(nprotect); |
| R_GCEnabled = enabled; |
| } |
| |
| |
| /* These functions are to be used in error messages, and available for others to use in the API |
| GetCurrentSrcref returns the first non-NULL srcref after skipping skip of them. If it |
| doesn't find one it returns NULL. */ |
| |
| SEXP |
| R_GetCurrentSrcref(int skip) |
| { |
| RCNTXT *c = R_GlobalContext; |
| SEXP srcref = R_Srcref; |
| if (skip < 0) { /* to count up from the bottom, we need to count them all first */ |
| while (c) { |
| if (srcref && srcref != R_NilValue) |
| skip++; |
| srcref = c->srcref; |
| c = c->nextcontext; |
| }; |
| if (skip < 0) return R_NilValue; /* not enough there */ |
| c = R_GlobalContext; |
| srcref = R_Srcref; |
| } |
| while (c && (skip || !srcref || srcref == R_NilValue)) { |
| if (srcref && srcref != R_NilValue) |
| skip--; |
| srcref = c->srcref; |
| c = c->nextcontext; |
| } |
| if (skip || !srcref) |
| srcref = R_NilValue; |
| return srcref; |
| } |
| |
| /* Return the filename corresponding to a srcref, or "" if none is found */ |
| |
| SEXP |
| R_GetSrcFilename(SEXP srcref) |
| { |
| SEXP srcfile = getAttrib(srcref, R_SrcfileSymbol); |
| if (TYPEOF(srcfile) != ENVSXP) |
| return ScalarString(mkChar("")); |
| srcfile = findVar(install("filename"), srcfile); |
| if (TYPEOF(srcfile) != STRSXP) |
| return ScalarString(mkChar("")); |
| return srcfile; |
| } |
| |
| |
| /* |
| * C level tryCatch support |
| */ |
| |
| /* There are two functions: |
| |
| R_TryCatchError handles error conditions; |
| |
| R_TryCatch can handle any condition type and allows a |
| finalize action. |
| */ |
| |
| SEXP R_tryCatchError(SEXP (*body)(void *), void *bdata, |
| SEXP (*handler)(SEXP, void *), void *hdata) |
| { |
| SEXP val; |
| SEXP cond = Rf_mkString("error"); |
| |
| PROTECT(cond); |
| val = R_tryCatch(body, bdata, cond, handler, hdata, NULL, NULL); |
| UNPROTECT(1); |
| return val; |
| } |
| |
| /* This implementation uses R's tryCatch via calls from C to R to |
| invoke R's tryCatch, and then back to C to infoke the C |
| body/handler functions via a .Internal helper. This makes the |
| implementation fairly simple but not fast. If performance becomes |
| an issue we can look into a pure C implementation. LT */ |
| |
| typedef struct { |
| SEXP (*body)(void *); |
| void *bdata; |
| SEXP (*handler)(SEXP, void *); |
| void *hdata; |
| void (*finally)(void *); |
| void *fdata; |
| int suspended; |
| } tryCatchData_t; |
| |
| static SEXP default_tryCatch_handler(SEXP cond, void *data) |
| { |
| return R_NilValue; |
| } |
| |
| static void default_tryCatch_finally(void *data) { } |
| |
| static SEXP trycatch_callback = NULL; |
| static const char* trycatch_callback_source = |
| "function(addr, classes, fin) {\n" |
| " handler <- function(cond)\n" |
| " .Internal(C_tryCatchHelper(addr, 1L, cond))\n" |
| " handlers <- rep_len(alist(handler), length(classes))\n" |
| " names(handlers) <- classes\n" |
| " if (fin)\n" |
| " handlers <- c(handlers,\n" |
| " alist(finally = .Internal(C_tryCatchHelper(addr, 2L))))\n" |
| " args <- c(alist(.Internal(C_tryCatchHelper(addr, 0L))), handlers)\n" |
| " do.call('tryCatch', args)\n" |
| "}"; |
| |
| SEXP R_tryCatch(SEXP (*body)(void *), void *bdata, |
| SEXP conds, |
| SEXP (*handler)(SEXP, void *), void *hdata, |
| void (*finally)(void *), void *fdata) |
| { |
| if (body == NULL) error("must supply a body function"); |
| |
| if (trycatch_callback == NULL) { |
| trycatch_callback = R_ParseEvalString(trycatch_callback_source, |
| R_BaseNamespace); |
| R_PreserveObject(trycatch_callback); |
| } |
| |
| tryCatchData_t tcd = { |
| .body = body, |
| .bdata = bdata, |
| .handler = handler != NULL ? handler : default_tryCatch_handler, |
| .hdata = hdata, |
| .finally = finally != NULL ? finally : default_tryCatch_finally, |
| .fdata = fdata, |
| .suspended = R_interrupts_suspended |
| }; |
| |
| /* Interrupts are suspended while in the infrastructure R code and |
| enabled, if they were on entry to R_TryCatch, while calling the |
| body function in do_tryCatchHelper */ |
| |
| R_interrupts_suspended = TRUE; |
| |
| if (conds == NULL) conds = allocVector(STRSXP, 0); |
| PROTECT(conds); |
| SEXP fin = finally != NULL ? R_TrueValue : R_FalseValue; |
| SEXP tcdptr = R_MakeExternalPtr(&tcd, R_NilValue, R_NilValue); |
| SEXP expr = lang4(trycatch_callback, tcdptr, conds, fin); |
| PROTECT(expr); |
| SEXP val = eval(expr, R_GlobalEnv); |
| UNPROTECT(2); /* conds, expr */ |
| R_interrupts_suspended = tcd.suspended; |
| return val; |
| } |
| |
| SEXP do_tryCatchHelper(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP eptr = CAR(args); |
| SEXP sw = CADR(args); |
| SEXP cond = CADDR(args); |
| |
| if (TYPEOF(eptr) != EXTPTRSXP) |
| error("not an external pointer"); |
| |
| tryCatchData_t *ptcd = R_ExternalPtrAddr(CAR(args)); |
| |
| switch (asInteger(sw)) { |
| case 0: |
| if (ptcd->suspended) |
| /* Interrupts were suspended for the call to R_TryCatch, |
| so leave them that way */ |
| return ptcd->body(ptcd->bdata); |
| else { |
| /* Interrupts were not suspended for the call to |
| R_TryCatch, but were suspended for the call through |
| R. So enable them for the body and suspend again on the |
| way out. */ |
| R_interrupts_suspended = FALSE; |
| SEXP val = ptcd->body(ptcd->bdata); |
| R_interrupts_suspended = TRUE; |
| return val; |
| } |
| case 1: |
| if (ptcd->handler != NULL) |
| return ptcd->handler(cond, ptcd->hdata); |
| else return R_NilValue; |
| case 2: |
| if (ptcd->finally != NULL) |
| ptcd->finally(ptcd->fdata); |
| return R_NilValue; |
| default: return R_NilValue; /* should not happen */ |
| } |
| } |