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

+{
     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);
     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';
 	/* 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));
+	    PROTECT(s = R_GetTracebackOnly(0));
 	    SET_SYMVALUE(install(".Traceback"), s);
 	    /* should have been defineVar
 	       setVar(install(".Traceback"), s, R_GlobalEnv); */
 	    UNPROTECT(1);
 	    inError = oldInError;
     if( R_ShowErrorMessages && R_CollectWarnings ) {
 	REprintf(_("In addition: "));
 	PrintWarnings();
+    }
+}
+/*
+ * Return the traceback without deparsing the calls
+ */
 attribute_hidden
-SEXP R_GetTraceback(int skip)
+SEXP R_GetTracebackOnly(int skip)
+{
     int nback = 0, ns;
     RCNTXT *c;
     SEXP s, t;
 	 c = c->nextcontext)
 	if (c->callflag & (CTXT_FUNCTION | CTXT_BUILTIN) ) {
 	    if (skip > 0)
 		skip--;
 	    else {
-		SETCAR(t, deparse1m(c->call, 0, DEFAULTDEPARSE));
+		SETCAR(t, duplicate(c->call));
 		if (c->srcref && !isNull(c->srcref)) {
 		    SEXP sref;
 		    if (c->srcref == R_InBCInterpreter)
 			sref = R_findBCInterpreterSrcref(c);
 		    else
+	    }
+	}
     UNPROTECT(1);
     return s;
+}
+/*
+ * Return the traceback with calls deparsed
+ */
+attribute_hidden
+SEXP R_GetTraceback(int skip)
+{
+    int nback = 0;
+    SEXP s, t, u, v;
+    s = PROTECT(R_GetTracebackOnly(skip));
+    for(t = s; t != R_NilValue; t = CDR(t)) nback++;
+    u = v = PROTECT(allocList(nback));
+    for(t = s; t != R_NilValue; t = CDR(t), v=CDR(v)) {
+        SETCAR(v, PROTECT(deparse1m(CAR(t), 0, DEFAULTDEPARSE)));
+        UNPROTECT(1);
+    }
+    UNPROTECT(2);
+    return u;
+}
 SEXP attribute_hidden do_traceback(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
     int skip;

The R Project SVN R

(root)/trunk/src/main/errors.c @ 77458 – Rev 76844 → 76872