The R Project SVN – R – Diff – /trunk/src/main/errors.c

+}
 /* 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 vsignalException(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;
+}
-void warningcall(SEXP call, const char *format, ...)
+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;
-    if (R_WarningHook != NULL) {
-	va_list(ap);
-	va_start(ap, format);
-	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
-	va_end(ap);
-	R_WarningHook(call, buf);
-	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;
     cntxt.cend = &reset_inWarning;
     inWarning = 1;
     if(w >= 2) { /* make it an error */
-	va_list(ap);
-	va_start(ap, format);
 	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
-	va_end(ap);
 	inWarning = 0; /* PR#1570 */
 	errorcall(call, "(converted from warning) %s", buf);
+    }
     else if(w == 1) {	/* print as they happen */
-	va_list(ap);
 	if( call != R_NilValue ) {
 	    dcall = CHAR(STRING_ELT(deparse1(call, 0), 0));
 	    REprintf("Warning in %s : ", dcall);
 	    if (strlen(dcall) > LONGCALL) REprintf("\n	 ");
+	}
 	else
 	    REprintf("Warning: ");
-	va_start(ap, format);
 	Rvsnprintf(buf, min(BUFSIZE, R_WarnLength), format, ap);
-	va_end(ap);
 	REprintf("%s\n", buf);
+    }
     else if(w == 0) {	/* collect them */
-	va_list(ap);
-	va_start(ap, format);
 	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);
-	va_end(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;
+{
     int *poldval = data;
     inError = *poldval;
+}
-void errorcall(SEXP call, const char *format,...)
+static void verrorcall_dflt(SEXP call, const char *format, va_list ap)
+{
     RCNTXT cntxt;
     char *p, *dcall;
     int oldInError;
-    va_list(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);
-    }
     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 */
-	    va_start(ap, format);
 	    Rvsnprintf(errbuf, sizeof(errbuf), format, ap);
-	    va_end(ap);
 	    REprintf("%s\n", errbuf);
+	}
 	if (R_Warnings != R_NilValue) {
 	    R_CollectWarnings = 0;
 	    R_Warnings = R_NilValue;
+    }
     else
 	sprintf(errbuf, "Error: ");
     p = errbuf + strlen(errbuf);
-    va_start(ap, format);
     Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);
-    va_end(ap);
     p = errbuf + strlen(errbuf) - 1;
     if(*p != '\n') strcat(errbuf, "\n");
     if (R_ShowErrorMessages) REprintf("%s", errbuf);
     if( R_ShowErrorMessages && R_CollectWarnings ) {
     /* 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);
+    vsignalException(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);
 	      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 */
 	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)
         REprintf("In addition: ");
         PrintWarnings();
+    }
+}
-/* doesn't stop at TOPLEVEL--should once browser is changed to use RESTART */
 SEXP R_GetTraceback(int skip)
+{
     int nback = 0, ns;
     RCNTXT *c;
     SEXP s, 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 findSimpleExceptionHandler()
+{
+    SEXP list;
+    for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {
+	SEXP entry = CAR(list);
+	if (! strcmp(CHAR(ENTRY_CLASS(entry)), "simpleException") ||
+	    ! strcmp(CHAR(ENTRY_CLASS(entry)), "exception") ||
+	    ! 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 vsignalException(SEXP call, const char *format, va_list ap)
+{
+    SEXP list, oldstack;
+    PROTECT(oldstack = R_HandlerStack);
+    while ((list = findSimpleExceptionHandler()) != 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) {
+		UNPROTECT(1);
+		return; /* go to default error handling; do not reset stack */
+	    }
+	    else {
+		SEXP hooksym, quotesym, hcall, qcall;
+		hooksym = install(".handleSimpleException");
+		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(3);
+	    }
+	}
+	else gotoExitingHandler(R_NilValue, call, entry);
+    }
+    R_HandlerStack = oldstack;
+    UNPROTECT(1);
+}
+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 exceptions 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;
+    checkArity(op, args);
+    cond = CAR(args);
+    msg = CADR(args);
+    ecall = CADDR(args);
+    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, call, entry);
+    }
+    return R_NilValue;
+}
+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("exception"));
+    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;
+}

The R Project SVN R

(root)/trunk/src/main/errors.c @ 28362 – Rev 25517 → 25523