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



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)

{
    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];

    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;
}

    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;
 
    PROTECT(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;

		UNPROTECT(1);
		return; /* go to default error handling; do not reset stack */
	    }
	    else {
		SEXP hooksym, quotesym, hcall, qcall;
		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);

    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))))

	    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);

Rev 25523	Rev 25526
Line 191...	Line 191...
191	`static void (R_WarningHook)(SEXP, char ) = NULL;`	191	`static void (R_WarningHook)(SEXP, char ) = NULL;`
192		192
193	`#ifdef NEW_CONDITION_HANDLING`	193	`#ifdef NEW_CONDITION_HANDLING`
194	`/* declarations for internal condition handling */`	194	`/* declarations for internal condition handling */`
195		195
196	`static void vsignalException(SEXP call, const char *format, va_list ap);`	196	`static void vsignalError(SEXP call, const char *format, va_list ap);`
197	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`	197	`static void vsignalWarning(SEXP call, const char *format, va_list ap);`
198	`static void invokeRestart(SEXP, SEXP);`	198	`static void invokeRestart(SEXP, SEXP);`
199	`#endif`	199	`#endif`
200		200
201	`static void reset_inWarning(void *data)`	201	`static void reset_inWarning(void *data)`
Line 476...	Line 476...
476	`{`	476	`{`
477	`va_list(ap);`	477	`va_list(ap);`
478		478
479	`#ifdef NEW_CONDITION_HANDLING`	479	`#ifdef NEW_CONDITION_HANDLING`
480	`va_start(ap, format);`	480	`va_start(ap, format);`
481	`vsignalException(call, format, ap);`	481	`vsignalError(call, format, ap);`
482	`va_end(ap);`	482	`va_end(ap);`
483	`#endif`	483	`#endif`
484		484
485	`if (R_ErrorHook != NULL) {`	485	`if (R_ErrorHook != NULL) {`
486	`char buf[BUFSIZE];`	486	`char buf[BUFSIZE];`
Line 988...	Line 988...
988	`checkArity(op, args);`	988	`checkArity(op, args);`
989	`R_HandlerStack = CAR(args);`	989	`R_HandlerStack = CAR(args);`
990	`return R_NilValue;`	990	`return R_NilValue;`
991	`}`	991	`}`
992		992
993	`static SEXP findSimpleExceptionHandler()`	993	`static SEXP findSimpleErrorHandler()`
994	`{`	994	`{`
995	`SEXP list;`	995	`SEXP list;`
996	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`	996	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`
997	`SEXP entry = CAR(list);`	997	`SEXP entry = CAR(list);`
998	`if (! strcmp(CHAR(ENTRY_CLASS(entry)), "simpleException") \|\|`	998	`if (! strcmp(CHAR(ENTRY_CLASS(entry)), "simpleError") \|\|`
999	`! strcmp(CHAR(ENTRY_CLASS(entry)), "exception") \|\|`	999	`! strcmp(CHAR(ENTRY_CLASS(entry)), "error") \|\|`
1000	`! strcmp(CHAR(ENTRY_CLASS(entry)), "condition"))`	1000	`! strcmp(CHAR(ENTRY_CLASS(entry)), "condition"))`
1001	`return list;`	1001	`return list;`
1002	`}`	1002	`}`
1003	`return R_NilValue;`	1003	`return R_NilValue;`
1004	`}`	1004	`}`
Line 1031...	Line 1031...
1031	`SET_VECTOR_ELT(result, 1, call);`	1031	`SET_VECTOR_ELT(result, 1, call);`
1032	`SET_VECTOR_ELT(result, 2, ENTRY_HANDLER(entry));`	1032	`SET_VECTOR_ELT(result, 2, ENTRY_HANDLER(entry));`
1033	`findcontext(CTXT_FUNCTION, rho, result);`	1033	`findcontext(CTXT_FUNCTION, rho, result);`
1034	`}`	1034	`}`
1035		1035
1036	`static void vsignalException(SEXP call, const char *format, va_list ap)`	1036	`static void vsignalError(SEXP call, const char *format, va_list ap)`
1037	`{`	1037	`{`
1038	`SEXP list, oldstack;`	1038	`SEXP list, oldstack;`
1039		1039
1040	`PROTECT(oldstack = R_HandlerStack);`	1040	`PROTECT(oldstack = R_HandlerStack);`
1041	`while ((list = findSimpleExceptionHandler()) != R_NilValue) {`	1041	`while ((list = findSimpleErrorHandler()) != R_NilValue) {`
1042	`char *buf = errbuf;`	1042	`char *buf = errbuf;`
1043	`SEXP entry = CAR(list);`	1043	`SEXP entry = CAR(list);`
1044	`R_HandlerStack = CDR(list);`	1044	`R_HandlerStack = CDR(list);`
1045	`Rvsnprintf(buf, BUFSIZE - 1, format, ap);`	1045	`Rvsnprintf(buf, BUFSIZE - 1, format, ap);`
1046	`buf[BUFSIZE - 1] = 0;`	1046	`buf[BUFSIZE - 1] = 0;`
Line 1049...	Line 1049...
1049	`UNPROTECT(1);`	1049	`UNPROTECT(1);`
1050	`return; /* go to default error handling; do not reset stack */`	1050	`return; /* go to default error handling; do not reset stack */`
1051	`}`	1051	`}`
1052	`else {`	1052	`else {`
1053	`SEXP hooksym, quotesym, hcall, qcall;`	1053	`SEXP hooksym, quotesym, hcall, qcall;`
1054	`hooksym = install(".handleSimpleException");`	1054	`hooksym = install(".handleSimpleError");`
1055	`quotesym = install("quote");`	1055	`quotesym = install("quote");`
1056	`PROTECT(qcall = LCONS(quotesym, LCONS(call, R_NilValue)));`	1056	`PROTECT(qcall = LCONS(quotesym, LCONS(call, R_NilValue)));`
1057	`PROTECT(hcall = LCONS(qcall, R_NilValue));`	1057	`PROTECT(hcall = LCONS(qcall, R_NilValue));`
1058	`hcall = LCONS(ScalarString(mkChar(buf)), hcall);`	1058	`hcall = LCONS(ScalarString(mkChar(buf)), hcall);`
1059	`hcall = LCONS(ENTRY_HANDLER(entry), hcall);`	1059	`hcall = LCONS(ENTRY_HANDLER(entry), hcall);`
Line 1075...	Line 1075...
1075	`SEXP classes = getAttrib(cond, R_ClassSymbol);`	1075	`SEXP classes = getAttrib(cond, R_ClassSymbol);`
1076		1076
1077	`if (TYPEOF(classes) != STRSXP)`	1077	`if (TYPEOF(classes) != STRSXP)`
1078	`return R_NilValue;`	1078	`return R_NilValue;`
1079		1079
1080	`/**** need some changes here to allow exceptions to be S4 classes */`	1080	`/**** need some changes here to allow conditions to be S4 classes */`
1081	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`	1081	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`
1082	`SEXP entry = CAR(list);`	1082	`SEXP entry = CAR(list);`
1083	`for (i = 0; i < LENGTH(classes); i++)`	1083	`for (i = 0; i < LENGTH(classes); i++)`
1084	`if (! strcmp(CHAR(ENTRY_CLASS(entry)),`	1084	`if (! strcmp(CHAR(ENTRY_CLASS(entry)),`
1085	`CHAR(STRING_ELT(classes, i))))`	1085	`CHAR(STRING_ELT(classes, i))))`
Line 1134...	Line 1134...
1134	`error("handler or restart stack mismatch in old restart");`	1134	`error("handler or restart stack mismatch in old restart");`
1135	`}`	1135	`}`
1136		1136
1137	`/**** need more here to keep recursive errors in browser? */`	1137	`/**** need more here to keep recursive errors in browser? */`
1138	`rho = cptr->cloenv;`	1138	`rho = cptr->cloenv;`
1139	`PROTECT(class = mkChar("exception"));`	1139	`PROTECT(class = mkChar("error"));`
1140	`entry = mkHandlerEntry(class, rho, R_RestartToken, rho, R_NilValue, TRUE);`	1140	`entry = mkHandlerEntry(class, rho, R_RestartToken, rho, R_NilValue, TRUE);`
1141	`R_HandlerStack = CONS(entry, R_HandlerStack);`	1141	`R_HandlerStack = CONS(entry, R_HandlerStack);`
1142	`UNPROTECT(1);`	1142	`UNPROTECT(1);`
1143	`PROTECT(name = ScalarString(mkChar(browser ? "browser" : "tryRestart")));`	1143	`PROTECT(name = ScalarString(mkChar(browser ? "browser" : "tryRestart")));`
1144	`entry = allocVector(VECSXP, 2);`	1144	`entry = allocVector(VECSXP, 2);`

The R Project SVN R

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