Multiple on.exit expressions are now all run even if one signals an e…

…rror. git-svn-id: https://svn.r-project.org/R/trunk@73181 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Sep 1, 2017 · 688eaeb · 688eaeb
1 parent a769643
commit 688eaeb
Show file tree

Hide file tree

Showing 5 changed files with 52 additions and 23 deletions.
diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd
@@ -134,6 +134,10 @@
       \R run in a terminal using a recent \code{readline} library will
       set the \code{width} option when the terminal is
       resized. Suggested by Ralf Goertz.}
+
+    \item{If multiple \code{on.exit} epressions are set using
+      \code{add = TRUE} then all expressions will now be run even if one
+      signals an error.}
     }
   }
 

diff --git a/src/library/base/man/on.exit.Rd b/src/library/base/man/on.exit.Rd
@@ -34,6 +34,9 @@ on.exit(expr = NULL, add = FALSE)
   the time of exit: to capture the current value in \code{expr} use
   \code{\link{substitute}} or similar.
 
+  If multiple \code{on.exit} epressions are set using \code{add = TRUE}
+  then all expressions will be run even if one signals an error.
+
   This is a \sQuote{special} \link{primitive} function: it only
   evaluates the argument \code{add}.
 }

diff --git a/src/main/builtin.c b/src/main/builtin.c
@@ -132,7 +132,7 @@ SEXP attribute_hidden do_makelazy(SEXP call, SEXP op, SEXP args, SEXP rho)
 SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
     RCNTXT *ctxt;
-    SEXP code, oldcode, tmp, argList;
+    SEXP code, oldcode, argList;
     int addit = 0;
     static SEXP do_onexit_formals = NULL;
 
@@ -159,27 +159,19 @@ SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
 	ctxt = ctxt->nextcontext;
     if (ctxt->callflag & CTXT_FUNCTION)
     {
-	if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
-	    if ( CAR(oldcode) != R_BraceSymbol )
-	    {
-		PROTECT(tmp = allocList(3));
-		SETCAR(tmp, R_BraceSymbol);
-		SETCADR(tmp, oldcode);
-		SETCADDR(tmp, code);
-		SET_TYPEOF(tmp, LANGSXP);
-		ctxt->conexit = tmp;
-		UNPROTECT(1);
-	    }
-	    else
-	    {
-		PROTECT(tmp = allocList(1));
-		SETCAR(tmp, code);
-		ctxt->conexit = listAppend(duplicate(oldcode),tmp);
+	if (code == R_NilValue && ! addit)
+	    ctxt->conexit = R_NilValue;
+	else {
+	    SEXP codelist = LCONS(code, R_NilValue);
+	    oldcode = ctxt->conexit;
+	    if (oldcode == R_NilValue || ! addit)
+		ctxt->conexit = codelist;
+	    else {
+		PROTECT(codelist);
+		ctxt->conexit = listAppend(duplicate(oldcode), codelist);
 		UNPROTECT(1);
 	    }
 	}
-	else
-	    ctxt->conexit = code;
     }
     UNPROTECT(1);
     return R_NilValue;

diff --git a/src/main/context.c b/src/main/context.c
@@ -150,7 +150,10 @@ void attribute_hidden R_run_onexits(RCNTXT *cptr)
 	       R_CheckStack. LT */
 	    R_Expressions = R_Expressions_keep + 500;
 	    R_CheckStack();
-	    eval(s, c->cloenv);
+	    for (; s != R_NilValue; s = CDR(s)) {
+		c->conexit = CDR(s);
+		eval(CAR(s), c->cloenv);
+	    }
 	    UNPROTECT(1);
 	    R_ExitContext = savecontext;
 	}
@@ -297,7 +300,10 @@ void endcontext(RCNTXT * cptr)
 	cptr->jumptarget = NULL; /* in case on.exit expr calls return() */
 	PROTECT(saveretval);
 	PROTECT(s);
-	eval(s, cptr->cloenv);
+	for (; s != R_NilValue; s = CDR(s)) {
+	    cptr->conexit = CDR(s);
+	    eval(CAR(s), cptr->cloenv);
+	}
 	R_ReturnedValue = saveretval;
 	UNPROTECT(2);
 	R_ExitContext = savecontext;
@@ -666,8 +672,15 @@ SEXP attribute_hidden do_sys(SEXP call, SEXP op, SEXP args, SEXP rho)
 	UNPROTECT(1);
 	return rval;
     case 7: /* sys.on.exit */
-	if( R_GlobalContext->nextcontext != NULL)
-	    return R_GlobalContext->nextcontext->conexit;
+	if( R_GlobalContext->nextcontext != NULL) {
+	    SEXP conexit = R_GlobalContext->nextcontext->conexit;
+	    if (conexit == R_NilValue)
+		return R_NilValue;
+	    else if (CDR(conexit) == R_NilValue)
+		return CAR(conexit);
+	    else
+		return LCONS(R_BraceSymbol, conexit);
+	}
 	else
 	    return R_NilValue;
     case 8: /* sys.parents */

diff --git a/tests/reg-tests-1d.R b/tests/reg-tests-1d.R
@@ -1198,6 +1198,23 @@ stopifnot(identical(a, matrix(character(), 1,2)), is.na(a))
 
 
 
+## chaining on.exit handlers with return statements
+
+x <- 0
+fret1 <- NULL
+fret2 <- NULL
+f <- function() {
+  on.exit(return(4))
+  on.exit({fret1 <<- returnValue(); return(5)}, add = T)
+  on.exit({fret2 <<- returnValue(); x <<- 2}, add = T)
+  3
+}
+res <- f()
+stopifnot(identical(res, 5))
+stopifnot(identical(x, 2))
+stopifnot(identical(fret1, 4))
+stopifnot(identical(fret2, 5))
+
 ## keep at end
 rbind(last =  proc.time() - .pt,
       total = proc.time())