The R Project SVN – R – Diff – /branches/R-classInheritance/src/main/errors.c



 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 */
 
/* <UTF8> char here is either ASCII or handled as a whole
   Domain names could be non-native, but the message translation
   systen is native.
*/
 
#ifdef HAVE_CONFIG_H

	R_CStackLimit += 0.05*R_CStackLimit;
	begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
		     R_NilValue, R_NilValue);
	cntxt.cend = &reset_stack_limit;
	cntxt.cenddata = &stacklimit;
 
	errorcall(R_NilValue, "C stack usage is too close to the limit");
	/* Do not translate this, to save stack space */
    }
}
 
void R_CheckUserInterrupt(void)

    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

    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)

	    tr = R_ConciseTraceback(call, 0);
	    if (strlen(tr)) REprintf("Calls: %s\n", tr);
	}
    }
    else if(w == 0) {	/* collect them */
	char *tr; int nc;
	if(!R_CollectWarnings)
	    setupwarnings();
	if( R_CollectWarnings > 49 )
	    return;
	SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);

	if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)
	    strcat(buf, " [... truncated]");
	if(R_ShowWarnCalls && call != R_NilValue) {
	    tr =  R_ConciseTraceback(call, 0); nc = strlen(tr);
	    if (nc && nc + strlen(buf) + 8 < BUFSIZE) {
		strcat(buf, "\nCalls: ");
		strcat(buf, tr);
	    }
	}
	names = CAR(ATTRIB(R_Warnings));
	SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));

	/* 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;

    else {
	sprintf(errbuf, _("Error: "));
	p = errbuf + strlen(errbuf);
	Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);
    }
 
    p = errbuf + strlen(errbuf) - 1;
    if(*p != '\n') strcat(errbuf, "\n");
 
    if(R_ShowErrorCalls && call != R_NilValue) {  /* assume we want to avoid deparse */
	tr = R_ConciseTraceback(call, 0); nc = strlen(tr);

	R_ResetConsole();
	R_FlushConsole();
	R_ClearerrConsole();
	R_ParseError = 0;
	R_ParseErrorFile = NULL;
	R_ParseErrorMsg[0] = '\0';
    }
 
    /*
     * Reset graphics state
     */

#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)) errorcall(call, _("invalid '%s' value"), "string");
 

	    const char * This = translateChar(STRING_ELT(string, i));
	    char *tmp, *head = NULL, *tail = NULL, *p, *tr;
	    tmp = (char *) alloca(strlen(This) + 1);
	    R_CheckStack();
	    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) {
		head = (char *) alloca(ihead + 1);
		R_CheckStack();
		strncpy(head, tmp, ihead);
		head[ihead] = '\0';
		tmp += ihead;
		}
	    if(strlen(tmp))
		for(p = tmp+strlen(tmp)-1;
		    p >= tmp && (*p == ' ' || *p == '\t' || *p == '\n');
		    p--, itail++) ;
	    if(itail > 0) {
		tail = (char *) alloca(itail + 1);
		R_CheckStack();

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

    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' arguemnt"), "n");
    if(!isString(msg1) || LENGTH(msg1) != 1)
	error(_("'msg1' must be a character string"));
    if(!isString(msg2) || LENGTH(msg2) != 1)

/* 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)
	errorcall(call, _("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)
	    errorcall(call, _("invalid '%s' value"), "dirname");
	res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)),
			     translateChar(STRING_ELT(CADR(args),0)));
    }
    if(res) return mkString(res);

    SEXP c_call;
 
    if(asLogical(CAR(args))) /* find context -> "Error in ..:" */
	c_call = findCall();
    else
	c_call = R_NilValue;
 
    args = CDR(args);
 
    if (CAR(args) != R_NilValue) { /* message */
      SETCAR(args, coerceVector(CAR(args), STRSXP));
      if(!isValidString(CAR(args)))

	c_call = R_NilValue;
 
    args = CDR(args);
    if(asLogical(CAR(args))) { /* immediate = TRUE */
	immediateWarning = 1;
    } else
	immediateWarning = 0;
    args = CDR(args);
    if (CAR(args) != R_NilValue) {
	SETCAR(args, coerceVector(CAR(args), STRSXP));
	if(!isValidString(CAR(args)))

}
 
void R_PrintDeferredWarnings(void)
{
    if( R_ShowErrorMessages && R_CollectWarnings ) {
	REprintf(_("In addition: "));
	PrintWarnings();
    }
}
 
SEXP R_GetTraceback(int skip)
{

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

Rev 45074	Rev 45446
Line 16...	Line 16...
16	`* You should have received a copy of the GNU General Public License`	16	`* You should have received a copy of the GNU General Public License`
17	`* along with this program; if not, a copy is available at`	17	`* along with this program; if not, a copy is available at`
18	`* http://www.r-project.org/Licenses/`	18	`* http://www.r-project.org/Licenses/`
19	`*/`	19	`*/`
20		20
21	`/* <UTF8> char here is either ASCII or handled as a whole`	21	`/* <UTF8> char here is either ASCII or handled as a whole`
22	`Domain names could be non-native, but the message translation`	22	`Domain names could be non-native, but the message translation`
23	`systen is native.`	23	`systen is native.`
24	`*/`	24	`*/`
25		25
26	`#ifdef HAVE_CONFIG_H`	26	`#ifdef HAVE_CONFIG_H`
Line 101...	Line 101...
101	`R_CStackLimit += 0.05*R_CStackLimit;`	101	`R_CStackLimit += 0.05*R_CStackLimit;`
102	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`	102	`begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,`
103	`R_NilValue, R_NilValue);`	103	`R_NilValue, R_NilValue);`
104	`cntxt.cend = &reset_stack_limit;`	104	`cntxt.cend = &reset_stack_limit;`
105	`cntxt.cenddata = &stacklimit;`	105	`cntxt.cenddata = &stacklimit;`
106		106
107	`errorcall(R_NilValue, "C stack usage is too close to the limit");`	107	`errorcall(R_NilValue, "C stack usage is too close to the limit");`
108	`/* Do not translate this, to save stack space */`	108	`/* Do not translate this, to save stack space */`
109	`}`	109	`}`
110	`}`	110	`}`
111		111
112	`void R_CheckUserInterrupt(void)`	112	`void R_CheckUserInterrupt(void)`
Line 187...	Line 187...
187	`if(R_CollectWarnings) PrintWarnings();`	187	`if(R_CollectWarnings) PrintWarnings();`
188		188
189	`R_ResetConsole();`	189	`R_ResetConsole();`
190	`R_FlushConsole();`	190	`R_FlushConsole();`
191	`R_ClearerrConsole();`	191	`R_ClearerrConsole();`
192	`R_ParseError = 0;`	192	`R_ParseError = 0;`
193	`R_ParseErrorFile = NULL;`	193	`R_ParseErrorFile = NULL;`
194	`R_ParseErrorMsg[0] = '\0';`	194	`R_ParseErrorMsg[0] = '\0';`
195		195
196	`/* Bail out if there is a browser/try on the stack--do we really`	196	`/* Bail out if there is a browser/try on the stack--do we really`
197	`want this? No, as from R 2.4.0`	197	`want this? No, as from R 2.4.0`
Line 224...	Line 224...
224	`R_ResetConsole();`	224	`R_ResetConsole();`
225	`R_FlushConsole();`	225	`R_FlushConsole();`
226	`R_ClearerrConsole();`	226	`R_ClearerrConsole();`
227	`R_ParseError = 0;`	227	`R_ParseError = 0;`
228	`R_ParseErrorFile = NULL;`	228	`R_ParseErrorFile = NULL;`
229	`R_ParseErrorMsg[0] = '\0';`	229	`R_ParseErrorMsg[0] = '\0';`
230	`R_CleanUp(SA_SAVE, 0, 0);`	230	`R_CleanUp(SA_SAVE, 0, 0);`
231	`}`	231	`}`
232		232
233		233
234	`static void setupwarnings(void)`	234	`static void setupwarnings(void)`
Line 364...	Line 364...
364	`tr = R_ConciseTraceback(call, 0);`	364	`tr = R_ConciseTraceback(call, 0);`
365	`if (strlen(tr)) REprintf("Calls: %s\n", tr);`	365	`if (strlen(tr)) REprintf("Calls: %s\n", tr);`
366	`}`	366	`}`
367	`}`	367	`}`
368	`else if(w == 0) { /* collect them */`	368	`else if(w == 0) { /* collect them */`
369	`char *tr; int nc;`	369	`char *tr; int nc;`
370	`if(!R_CollectWarnings)`	370	`if(!R_CollectWarnings)`
371	`setupwarnings();`	371	`setupwarnings();`
372	`if( R_CollectWarnings > 49 )`	372	`if( R_CollectWarnings > 49 )`
373	`return;`	373	`return;`
374	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`	374	`SET_VECTOR_ELT(R_Warnings, R_CollectWarnings, call);`
Line 376...	Line 376...
376	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`	376	`if(R_WarnLength < BUFSIZE - 20 && strlen(buf) == R_WarnLength)`
377	`strcat(buf, " [... truncated]");`	377	`strcat(buf, " [... truncated]");`
378	`if(R_ShowWarnCalls && call != R_NilValue) {`	378	`if(R_ShowWarnCalls && call != R_NilValue) {`
379	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`	379	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`
380	`if (nc && nc + strlen(buf) + 8 < BUFSIZE) {`	380	`if (nc && nc + strlen(buf) + 8 < BUFSIZE) {`
381	`strcat(buf, "\nCalls: ");`	381	`strcat(buf, "\nCalls: ");`
382	`strcat(buf, tr);`	382	`strcat(buf, tr);`
383	`}`	383	`}`
384	`}`	384	`}`
385	`names = CAR(ATTRIB(R_Warnings));`	385	`names = CAR(ATTRIB(R_Warnings));`
386	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`	386	`SET_STRING_ELT(names, R_CollectWarnings++, mkChar(buf));`
Line 562...	Line 562...
562	`/* fail-safe handler for recursive errors */`	562	`/* fail-safe handler for recursive errors */`
563	`if(inError == 3) {`	563	`if(inError == 3) {`
564	`/* Can REprintf generate an error? If so we should guard for it */`	564	`/* Can REprintf generate an error? If so we should guard for it */`
565	`REprintf(_("Error during wrapup: "));`	565	`REprintf(_("Error during wrapup: "));`
566	`/* this does NOT try to print the call since that could`	566	`/* this does NOT try to print the call since that could`
567	`cause a cascade of error calls */`	567	`cause a cascade of error calls */`
568	`Rvsnprintf(errbuf, sizeof(errbuf), format, ap);`	568	`Rvsnprintf(errbuf, sizeof(errbuf), format, ap);`
569	`REprintf("%s\n", errbuf);`	569	`REprintf("%s\n", errbuf);`
570	`}`	570	`}`
571	`if (R_Warnings != R_NilValue) {`	571	`if (R_Warnings != R_NilValue) {`
572	`R_CollectWarnings = 0;`	572	`R_CollectWarnings = 0;`
Line 622...	Line 622...
622	`else {`	622	`else {`
623	`sprintf(errbuf, _("Error: "));`	623	`sprintf(errbuf, _("Error: "));`
624	`p = errbuf + strlen(errbuf);`	624	`p = errbuf + strlen(errbuf);`
625	`Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);`	625	`Rvsnprintf(p, min(BUFSIZE, R_WarnLength) - strlen(errbuf), format, ap);`
626	`}`	626	`}`
627		627
628	`p = errbuf + strlen(errbuf) - 1;`	628	`p = errbuf + strlen(errbuf) - 1;`
629	`if(*p != '\n') strcat(errbuf, "\n");`	629	`if(*p != '\n') strcat(errbuf, "\n");`
630		630
631	`if(R_ShowErrorCalls && call != R_NilValue) { /* assume we want to avoid deparse */`	631	`if(R_ShowErrorCalls && call != R_NilValue) { /* assume we want to avoid deparse */`
632	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`	632	`tr = R_ConciseTraceback(call, 0); nc = strlen(tr);`
Line 786...	Line 786...
786	`R_ResetConsole();`	786	`R_ResetConsole();`
787	`R_FlushConsole();`	787	`R_FlushConsole();`
788	`R_ClearerrConsole();`	788	`R_ClearerrConsole();`
789	`R_ParseError = 0;`	789	`R_ParseError = 0;`
790	`R_ParseErrorFile = NULL;`	790	`R_ParseErrorFile = NULL;`
791	`R_ParseErrorMsg[0] = '\0';`	791	`R_ParseErrorMsg[0] = '\0';`
792	`}`	792	`}`
793		793
794	`/*`	794	`/*`
795	`* Reset graphics state`	795	`* Reset graphics state`
796	`*/`	796	`*/`
Line 870...	Line 870...
870	`#ifdef ENABLE_NLS`	870	`#ifdef ENABLE_NLS`
871	`const char domain = "", cfn;`	871	`const char domain = "", cfn;`
872	`char *buf;`	872	`char *buf;`
873	`SEXP ans, string = CADR(args);`	873	`SEXP ans, string = CADR(args);`
874	`int i, n = LENGTH(string);`	874	`int i, n = LENGTH(string);`
875		875
876	`checkArity(op, args);`	876	`checkArity(op, args);`
877	`if(isNull(string) \|\| !n) return string;`	877	`if(isNull(string) \|\| !n) return string;`
878		878
879	`if(!isString(string)) errorcall(call, _("invalid '%s' value"), "string");`	879	`if(!isString(string)) errorcall(call, _("invalid '%s' value"), "string");`
880		880
Line 916...	Line 916...
916	`const char * This = translateChar(STRING_ELT(string, i));`	916	`const char * This = translateChar(STRING_ELT(string, i));`
917	`char tmp, head = NULL, tail = NULL, p, *tr;`	917	`char tmp, head = NULL, tail = NULL, p, *tr;`
918	`tmp = (char *) alloca(strlen(This) + 1);`	918	`tmp = (char *) alloca(strlen(This) + 1);`
919	`R_CheckStack();`	919	`R_CheckStack();`
920	`strcpy(tmp, This);`	920	`strcpy(tmp, This);`
921	`/* strip leading and trailing white spaces and`	921	`/* strip leading and trailing white spaces and`
922	`add back after translation */`	922	`add back after translation */`
923	`for(p = tmp;`	923	`for(p = tmp;`
924	`p && (p == ' ' \|\| p == '\t' \|\| p == '\n');`	924	`p && (p == ' ' \|\| p == '\t' \|\| p == '\n');`
925	`p++, ihead++) ;`	925	`p++, ihead++) ;`
926	`if(ihead > 0) {`	926	`if(ihead > 0) {`
927	`head = (char *) alloca(ihead + 1);`	927	`head = (char *) alloca(ihead + 1);`
928	`R_CheckStack();`	928	`R_CheckStack();`
929	`strncpy(head, tmp, ihead);`	929	`strncpy(head, tmp, ihead);`
930	`head[ihead] = '\0';`	930	`head[ihead] = '\0';`
931	`tmp += ihead;`	931	`tmp += ihead;`
932	`}`	932	`}`
933	`if(strlen(tmp))`	933	`if(strlen(tmp))`
934	`for(p = tmp+strlen(tmp)-1;`	934	`for(p = tmp+strlen(tmp)-1;`
935	`p >= tmp && (p == ' ' \|\| p == '\t' \|\| *p == '\n');`	935	`p >= tmp && (p == ' ' \|\| p == '\t' \|\| *p == '\n');`
936	`p--, itail++) ;`	936	`p--, itail++) ;`
937	`if(itail > 0) {`	937	`if(itail > 0) {`
938	`tail = (char *) alloca(itail + 1);`	938	`tail = (char *) alloca(itail + 1);`
939	`R_CheckStack();`	939	`R_CheckStack();`
Line 950...	Line 950...
950	`tmp[0] ='\0';`	950	`tmp[0] ='\0';`
951	`if(ihead > 0) strcat(tmp, head);`	951	`if(ihead > 0) strcat(tmp, head);`
952	`strcat(tmp, tr);`	952	`strcat(tmp, tr);`
953	`if(itail > 0) strcat(tmp, tail);`	953	`if(itail > 0) strcat(tmp, tail);`
954	`SET_STRING_ELT(ans, i, mkChar(tmp));`	954	`SET_STRING_ELT(ans, i, mkChar(tmp));`
955	`} else`	955	`} else`
956	`SET_STRING_ELT(ans, i, mkChar(This));`	956	`SET_STRING_ELT(ans, i, mkChar(This));`
957	`}`	957	`}`
958	`UNPROTECT(1);`	958	`UNPROTECT(1);`
959	`return ans;`	959	`return ans;`
960	`} else return CADR(args);`	960	`} else return CADR(args);`
Line 971...	Line 971...
971	`char *buf;`	971	`char *buf;`
972	`SEXP ans, sdom = CADDDR(args);`	972	`SEXP ans, sdom = CADDDR(args);`
973	`#endif`	973	`#endif`
974	`SEXP msg1 = CADR(args), msg2 = CADDR(args);`	974	`SEXP msg1 = CADR(args), msg2 = CADDR(args);`
975	`int n = asInteger(CAR(args));`	975	`int n = asInteger(CAR(args));`
976		976
977	`checkArity(op, args);`	977	`checkArity(op, args);`
978	`if(n == NA_INTEGER \|\| n < 0) error(_("invalid '%s' arguemnt"), "n");`	978	`if(n == NA_INTEGER \|\| n < 0) error(_("invalid '%s' arguemnt"), "n");`
979	`if(!isString(msg1) \|\| LENGTH(msg1) != 1)`	979	`if(!isString(msg1) \|\| LENGTH(msg1) != 1)`
980	`error(_("'msg1' must be a character string"));`	980	`error(_("'msg1' must be a character string"));`
981	`if(!isString(msg2) \|\| LENGTH(msg2) != 1)`	981	`if(!isString(msg2) \|\| LENGTH(msg2) != 1)`
Line 1028...	Line 1028...
1028	`/* bindtextdomain(domain, dirname) */`	1028	`/* bindtextdomain(domain, dirname) */`
1029	`SEXP attribute_hidden do_bindtextdomain(SEXP call, SEXP op, SEXP args, SEXP rho)`	1029	`SEXP attribute_hidden do_bindtextdomain(SEXP call, SEXP op, SEXP args, SEXP rho)`
1030	`{`	1030	`{`
1031	`#ifdef ENABLE_NLS`	1031	`#ifdef ENABLE_NLS`
1032	`char *res;`	1032	`char *res;`
1033		1033
1034	`checkArity(op, args);`	1034	`checkArity(op, args);`
1035	`if(!isString(CAR(args)) \|\| LENGTH(CAR(args)) != 1)`	1035	`if(!isString(CAR(args)) \|\| LENGTH(CAR(args)) != 1)`
1036	`errorcall(call, _("invalid '%s' value"), "domain");`	1036	`errorcall(call, _("invalid '%s' value"), "domain");`
1037	`if(isNull(CADR(args))) {`	1037	`if(isNull(CADR(args))) {`
1038	`res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)), NULL);`	1038	`res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)), NULL);`
1039	`} else {`	1039	`} else {`
1040	`if(!isString(CADR(args)) \|\| LENGTH(CADR(args)) != 1)`	1040	`if(!isString(CADR(args)) \|\| LENGTH(CADR(args)) != 1)`
1041	`errorcall(call, _("invalid '%s' value"), "dirname");`	1041	`errorcall(call, _("invalid '%s' value"), "dirname");`
1042	`res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)),`	1042	`res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)),`
1043	`translateChar(STRING_ELT(CADR(args),0)));`	1043	`translateChar(STRING_ELT(CADR(args),0)));`
1044	`}`	1044	`}`
1045	`if(res) return mkString(res);`	1045	`if(res) return mkString(res);`
Line 1065...	Line 1065...
1065	`SEXP c_call;`	1065	`SEXP c_call;`
1066		1066
1067	`if(asLogical(CAR(args))) /* find context -> "Error in ..:" */`	1067	`if(asLogical(CAR(args))) /* find context -> "Error in ..:" */`
1068	`c_call = findCall();`	1068	`c_call = findCall();`
1069	`else`	1069	`else`
1070	`c_call = R_NilValue;`	1070	`c_call = R_NilValue;`
1071		1071
1072	`args = CDR(args);`	1072	`args = CDR(args);`
1073		1073
1074	`if (CAR(args) != R_NilValue) { /* message */`	1074	`if (CAR(args) != R_NilValue) { /* message */`
1075	`SETCAR(args, coerceVector(CAR(args), STRSXP));`	1075	`SETCAR(args, coerceVector(CAR(args), STRSXP));`
1076	`if(!isValidString(CAR(args)))`	1076	`if(!isValidString(CAR(args)))`
Line 1092...	Line 1092...
1092	`c_call = R_NilValue;`	1092	`c_call = R_NilValue;`
1093		1093
1094	`args = CDR(args);`	1094	`args = CDR(args);`
1095	`if(asLogical(CAR(args))) { /* immediate = TRUE */`	1095	`if(asLogical(CAR(args))) { /* immediate = TRUE */`
1096	`immediateWarning = 1;`	1096	`immediateWarning = 1;`
1097	`} else`	1097	`} else`
1098	`immediateWarning = 0;`	1098	`immediateWarning = 0;`
1099	`args = CDR(args);`	1099	`args = CDR(args);`
1100	`if (CAR(args) != R_NilValue) {`	1100	`if (CAR(args) != R_NilValue) {`
1101	`SETCAR(args, coerceVector(CAR(args), STRSXP));`	1101	`SETCAR(args, coerceVector(CAR(args), STRSXP));`
1102	`if(!isValidString(CAR(args)))`	1102	`if(!isValidString(CAR(args)))`
Line 1260...	Line 1260...
1260	`}`	1260	`}`
1261		1261
1262	`void R_PrintDeferredWarnings(void)`	1262	`void R_PrintDeferredWarnings(void)`
1263	`{`	1263	`{`
1264	`if( R_ShowErrorMessages && R_CollectWarnings ) {`	1264	`if( R_ShowErrorMessages && R_CollectWarnings ) {`
1265	`REprintf(_("In addition: "));`	1265	`REprintf(_("In addition: "));`
1266	`PrintWarnings();`	1266	`PrintWarnings();`
1267	`}`	1267	`}`
1268	`}`	1268	`}`
1269		1269
1270	`SEXP R_GetTraceback(int skip)`	1270	`SEXP R_GetTraceback(int skip)`
1271	`{`	1271	`{`
Line 1317...	Line 1317...
1317	`skip--;`	1317	`skip--;`
1318	`else {`	1318	`else {`
1319	`SEXP fun = CAR(c->call);`	1319	`SEXP fun = CAR(c->call);`
1320	`const char *this = (TYPEOF(fun) == SYMSXP) ?`	1320	`const char *this = (TYPEOF(fun) == SYMSXP) ?`
1321	`CHAR(PRINTNAME(fun)) : "<Anonymous>";`	1321	`CHAR(PRINTNAME(fun)) : "<Anonymous>";`
1322	`if(streql(this, "stop") \|\|`	1322	`if(streql(this, "stop") \|\|`
1323	`streql(this, "warning") \|\|`	1323	`streql(this, "warning") \|\|`
1324	`streql(this, "suppressWarnings") \|\|`	1324	`streql(this, "suppressWarnings") \|\|`
1325	`streql(this, ".signalSimpleWarning")) {`	1325	`streql(this, ".signalSimpleWarning")) {`
1326	`buf[0] = '\0'; ncalls = 0; too_many = FALSE;`	1326	`buf[0] = '\0'; ncalls = 0; too_many = FALSE;`
1327	`} else {`	1327	`} else {`
1328	`ncalls++;`	1328	`ncalls++;`
1329	`if(too_many) {`	1329	`if(too_many) {`

The R Project SVN R

(root)/branches/R-classInheritance/src/main/errors.c @ 63243 – Rev 45074 → 45446