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



       pending.  Need to be careful not to do too much event
       processing though: if event handlers written in R are allowed
       to run at this point then we end up with concurrent R
       evaluations and that can cause problems until we have proper
       concurrency support. LT */
#if  ( defined(HAVE_AQUA) || defined(Win32) )
    R_ProcessEvents();
#else
    if (R_interrupts_pending)
	onintr();
#endif /* Win32 */

    if (R_interrupts_suspended) {
	/**** ought to save signal and handle after suspend */
	REprintf("interrupts suspended; signal ignored");
	return;
    }
 
    inError = 1;
 
    if( R_CollectWarnings )
	PrintWarnings();
 

    if (R_interrupts_suspended) {
	/**** ought to save signal and handle after suspend */
	REprintf("interrupts suspended; signal ignored");
	return;
    }
 
    if( R_CollectWarnings )
	PrintWarnings();
 
    R_ResetConsole();
    R_FlushConsole();

    RCNTXT *cptr;
    RCNTXT cntxt;
 
    if (inWarning)
	return;
 
    s = GetOption(install("warning.expression"), R_NilValue);
    if( s!= R_NilValue ) {
	if( !isLanguage(s) &&  ! isExpression(s) )
	    error("invalid option \"warning.expression\"");
	cptr = R_GlobalContext;

	inWarning = 0; /* PR#1570 */
	errorcall(call, "(converted from warning) %s", buf);
    }
    else if(w == 1) {	/* print as they happen */
	if( call != R_NilValue ) {
	    dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE), 0));
	    REprintf("Warning in %s : ", dcall);
	    if (strlen(dcall) > LONGCALL) REprintf("\n	 ");
	}
	else
	    REprintf("Warning: ");

	names = CAR(ATTRIB(R_Warnings));
	if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )
	   REprintf("%s \n", CHAR(STRING_ELT(names, 0)));
	else
	   REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),
		CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0), 0, TRUE), 0)));
    }
    else if( R_CollectWarnings <= 10 ) {
	REprintf("Warning messages: \n");
	names = CAR(ATTRIB(R_Warnings));
	for(i=0; i<R_CollectWarnings; i++) {
	    if( STRING_ELT(R_Warnings, i) == R_NilValue )
	       REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));
	    else
	       REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),
		   CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0, TRUE), 0)));
	}
    }
    else {
	if (R_CollectWarnings < 50)
	    REprintf("There were %d warnings (use warnings() to see them)\n",

	char *head = "Error in ";
	char *mid = " : ";
	char *tail = "\n\t";/* <- TAB */
	int len = strlen(head) + strlen(mid) + strlen(tail);
 
	dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE), 0));
	if (strlen(dcall) + len < BUFSIZE) {
	    sprintf(errbuf, "%s%s%s", head, dcall, mid);
	    if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);
	}
	else

	 cptr = cptr->nextcontext)
	if (cptr->callflag & CTXT_FUNCTION)
	    return cptr->call;
    return R_NilValue;
}
 
SEXP do_stop(SEXP call, SEXP op, SEXP args, SEXP rho)
{
/* error(.) : really doesn't return anything; but all do_foo() must be SEXP */
    SEXP c_call;
 

{
    if( R_ShowErrorMessages && R_CollectWarnings ) {
        REprintf("In addition: ");
        PrintWarnings();
    }
}
 
SEXP R_GetTraceback(int skip)
{
    int nback = 0, ns;
    RCNTXT *c;

	 c = c->nextcontext)
	if (c->callflag & CTXT_FUNCTION ) {
	    if (skip > 0)
		skip--;
	    else {
		SETCAR(t, deparse1(c->call, 0, TRUE));
		t = CDR(t);
	    }
	}
    UNPROTECT(1);
    return s;

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

Rev 27000	Rev 29340
Line 75...	Line 75...
75	`pending. Need to be careful not to do too much event`	75	`pending. Need to be careful not to do too much event`
76	`processing though: if event handlers written in R are allowed`	76	`processing though: if event handlers written in R are allowed`
77	`to run at this point then we end up with concurrent R`	77	`to run at this point then we end up with concurrent R`
78	`evaluations and that can cause problems until we have proper`	78	`evaluations and that can cause problems until we have proper`
79	`concurrency support. LT */`	79	`concurrency support. LT */`
80	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`	80	`#if ( defined(HAVE_AQUA) \|\| defined(Win32) )`
81	`R_ProcessEvents();`	81	`R_ProcessEvents();`
82	`#else`	82	`#else`
83	`if (R_interrupts_pending)`	83	`if (R_interrupts_pending)`
84	`onintr();`	84	`onintr();`
85	`#endif /* Win32 */`	85	`#endif /* Win32 */`
Line 112...	Line 112...
112	`if (R_interrupts_suspended) {`	112	`if (R_interrupts_suspended) {`
113	`/**** ought to save signal and handle after suspend */`	113	`/**** ought to save signal and handle after suspend */`
114	`REprintf("interrupts suspended; signal ignored");`	114	`REprintf("interrupts suspended; signal ignored");`
115	`return;`	115	`return;`
116	`}`	116	`}`
117		117
118	`inError = 1;`	118	`inError = 1;`
119		119
120	`if( R_CollectWarnings )`	120	`if( R_CollectWarnings )`
121	`PrintWarnings();`	121	`PrintWarnings();`
122		122
Line 147...	Line 147...
147	`if (R_interrupts_suspended) {`	147	`if (R_interrupts_suspended) {`
148	`/**** ought to save signal and handle after suspend */`	148	`/**** ought to save signal and handle after suspend */`
149	`REprintf("interrupts suspended; signal ignored");`	149	`REprintf("interrupts suspended; signal ignored");`
150	`return;`	150	`return;`
151	`}`	151	`}`
152		152
153	`if( R_CollectWarnings )`	153	`if( R_CollectWarnings )`
154	`PrintWarnings();`	154	`PrintWarnings();`
155		155
156	`R_ResetConsole();`	156	`R_ResetConsole();`
157	`R_FlushConsole();`	157	`R_FlushConsole();`
Line 214...	Line 214...
214	`RCNTXT *cptr;`	214	`RCNTXT *cptr;`
215	`RCNTXT cntxt;`	215	`RCNTXT cntxt;`
216		216
217	`if (inWarning)`	217	`if (inWarning)`
218	`return;`	218	`return;`
219		219
220	`s = GetOption(install("warning.expression"), R_NilValue);`	220	`s = GetOption(install("warning.expression"), R_NilValue);`
221	`if( s!= R_NilValue ) {`	221	`if( s!= R_NilValue ) {`
222	`if( !isLanguage(s) && ! isExpression(s) )`	222	`if( !isLanguage(s) && ! isExpression(s) )`
223	`error("invalid option \"warning.expression\"");`	223	`error("invalid option \"warning.expression\"");`
224	`cptr = R_GlobalContext;`	224	`cptr = R_GlobalContext;`
Line 249...	Line 249...
249	`inWarning = 0; /* PR#1570 */`	249	`inWarning = 0; /* PR#1570 */`
250	`errorcall(call, "(converted from warning) %s", buf);`	250	`errorcall(call, "(converted from warning) %s", buf);`
251	`}`	251	`}`
252	`else if(w == 1) { /* print as they happen */`	252	`else if(w == 1) { /* print as they happen */`
253	`if( call != R_NilValue ) {`	253	`if( call != R_NilValue ) {`
254	`dcall = CHAR(STRING_ELT(deparse1(call, 0), 0));`	254	`dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE), 0));`
255	`REprintf("Warning in %s : ", dcall);`	255	`REprintf("Warning in %s : ", dcall);`
256	`if (strlen(dcall) > LONGCALL) REprintf("\n ");`	256	`if (strlen(dcall) > LONGCALL) REprintf("\n ");`
257	`}`	257	`}`
258	`else`	258	`else`
259	`REprintf("Warning: ");`	259	`REprintf("Warning: ");`
Line 346...	Line 346...
346	`names = CAR(ATTRIB(R_Warnings));`	346	`names = CAR(ATTRIB(R_Warnings));`
347	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`	347	`if( VECTOR_ELT(R_Warnings, 0) == R_NilValue )`
348	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`	348	`REprintf("%s \n", CHAR(STRING_ELT(names, 0)));`
349	`else`	349	`else`
350	`REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),`	350	`REprintf("%s in: %s \n", CHAR(STRING_ELT(names, 0)),`
351	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0),0), 0)));`	351	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings, 0), 0, TRUE), 0)));`
352	`}`	352	`}`
353	`else if( R_CollectWarnings <= 10 ) {`	353	`else if( R_CollectWarnings <= 10 ) {`
354	`REprintf("Warning messages: \n");`	354	`REprintf("Warning messages: \n");`
355	`names = CAR(ATTRIB(R_Warnings));`	355	`names = CAR(ATTRIB(R_Warnings));`
356	`for(i=0; i<R_CollectWarnings; i++) {`	356	`for(i=0; i<R_CollectWarnings; i++) {`
357	`if( STRING_ELT(R_Warnings, i) == R_NilValue )`	357	`if( STRING_ELT(R_Warnings, i) == R_NilValue )`
358	`REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));`	358	`REprintf("%d: %s \n",i+1, CHAR(STRING_ELT(names, i)));`
359	`else`	359	`else`
360	`REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),`	360	`REprintf("%d: %s in: %s \n", i+1, CHAR(STRING_ELT(names, i)),`
361	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0), 0)));`	361	`CHAR(STRING_ELT(deparse1(VECTOR_ELT(R_Warnings,i), 0, TRUE), 0)));`
362	`}`	362	`}`
363	`}`	363	`}`
364	`else {`	364	`else {`
365	`if (R_CollectWarnings < 50)`	365	`if (R_CollectWarnings < 50)`
366	`REprintf("There were %d warnings (use warnings() to see them)\n",`	366	`REprintf("There were %d warnings (use warnings() to see them)\n",`
Line 435...	Line 435...
435	`char *head = "Error in ";`	435	`char *head = "Error in ";`
436	`char *mid = " : ";`	436	`char *mid = " : ";`
437	`char tail = "\n\t";/ <- TAB */`	437	`char tail = "\n\t";/ <- TAB */`
438	`int len = strlen(head) + strlen(mid) + strlen(tail);`	438	`int len = strlen(head) + strlen(mid) + strlen(tail);`
439		439
440	`dcall = CHAR(STRING_ELT(deparse1(call, 0), 0));`	440	`dcall = CHAR(STRING_ELT(deparse1(call, 0, TRUE), 0));`
441	`if (strlen(dcall) + len < BUFSIZE) {`	441	`if (strlen(dcall) + len < BUFSIZE) {`
442	`sprintf(errbuf, "%s%s%s", head, dcall, mid);`	442	`sprintf(errbuf, "%s%s%s", head, dcall, mid);`
443	`if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);`	443	`if (strlen(dcall) > LONGCALL) strcat(errbuf, tail);`
444	`}`	444	`}`
445	`else`	445	`else`
Line 692...	Line 692...
692	`cptr = cptr->nextcontext)`	692	`cptr = cptr->nextcontext)`
693	`if (cptr->callflag & CTXT_FUNCTION)`	693	`if (cptr->callflag & CTXT_FUNCTION)`
694	`return cptr->call;`	694	`return cptr->call;`
695	`return R_NilValue;`	695	`return R_NilValue;`
696	`}`	696	`}`
697		697
698	`SEXP do_stop(SEXP call, SEXP op, SEXP args, SEXP rho)`	698	`SEXP do_stop(SEXP call, SEXP op, SEXP args, SEXP rho)`
699	`{`	699	`{`
700	`/* error(.) : really doesn't return anything; but all do_foo() must be SEXP */`	700	`/* error(.) : really doesn't return anything; but all do_foo() must be SEXP */`
701	`SEXP c_call;`	701	`SEXP c_call;`
702		702
Line 894...	Line 894...
894	`{`	894	`{`
895	`if( R_ShowErrorMessages && R_CollectWarnings ) {`	895	`if( R_ShowErrorMessages && R_CollectWarnings ) {`
896	`REprintf("In addition: ");`	896	`REprintf("In addition: ");`
897	`PrintWarnings();`	897	`PrintWarnings();`
898	`}`	898	`}`
899	`}`	899	`}`
900		900
901	`SEXP R_GetTraceback(int skip)`	901	`SEXP R_GetTraceback(int skip)`
902	`{`	902	`{`
903	`int nback = 0, ns;`	903	`int nback = 0, ns;`
904	`RCNTXT *c;`	904	`RCNTXT *c;`
Line 921...	Line 921...
921	`c = c->nextcontext)`	921	`c = c->nextcontext)`
922	`if (c->callflag & CTXT_FUNCTION ) {`	922	`if (c->callflag & CTXT_FUNCTION ) {`
923	`if (skip > 0)`	923	`if (skip > 0)`
924	`skip--;`	924	`skip--;`
925	`else {`	925	`else {`
926	`SETCAR(t, deparse1(c->call, 0));`	926	`SETCAR(t, deparse1(c->call, 0, TRUE));`
927	`t = CDR(t);`	927	`t = CDR(t);`
928	`}`	928	`}`
929	`}`	929	`}`
930	`UNPROTECT(1);`	930	`UNPROTECT(1);`
931	`return s;`	931	`return s;`
Line 1088...	Line 1088...
1088	`SEXP list;`	1088	`SEXP list;`
1089	`SEXP classes = getAttrib(cond, R_ClassSymbol);`	1089	`SEXP classes = getAttrib(cond, R_ClassSymbol);`
1090		1090
1091	`if (TYPEOF(classes) != STRSXP)`	1091	`if (TYPEOF(classes) != STRSXP)`
1092	`return R_NilValue;`	1092	`return R_NilValue;`
1093		1093
1094	`/**** need some changes here to allow conditions to be S4 classes */`	1094	`/**** need some changes here to allow conditions to be S4 classes */`
1095	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`	1095	`for (list = R_HandlerStack; list != R_NilValue; list = CDR(list)) {`
1096	`SEXP entry = CAR(list);`	1096	`SEXP entry = CAR(list);`
1097	`for (i = 0; i < LENGTH(classes); i++)`	1097	`for (i = 0; i < LENGTH(classes); i++)`
1098	`if (! strcmp(CHAR(ENTRY_CLASS(entry)),`	1098	`if (! strcmp(CHAR(ENTRY_CLASS(entry)),`

The R Project SVN R

(root)/trunk/src/main/errors.c @ 28362 – Rev 27000 → 29340