>From 23617ddd827bbddeb4ac5bbcf63fb8b0dc8c0109 Mon Sep 17 00:00:00 2001
From: Matt Lilley <address@hidden>
Date: Thu, 1 Mar 2012 11:55:34 +1300
Subject: [PATCH] Fixed: Do not call cleanup when backtracking in to the goal,
 only when backtracking out of it due to failure

---
 src/gnu/prolog/vm/Interpreter.java                 |    5 ++-
 .../meta/Predicate_setup_call_catcher_cleanup.java |   22 ++++++++++++++++---
 test/inriasuite/extra/setup_call_catcher_cleanup   |   11 +++++++++-
 3 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/src/gnu/prolog/vm/Interpreter.java b/src/gnu/prolog/vm/Interpreter.java
index 082a593..f7f8997 100644
--- a/src/gnu/prolog/vm/Interpreter.java
+++ b/src/gnu/prolog/vm/Interpreter.java
@@ -142,9 +142,10 @@ public final class Interpreter implements HasEnvironment
 	public BacktrackInfo popBacktrackInfo()
 	{
 		BacktrackInfo rc = backtrackInfoStack[--backtrackInfoAmount];
-		if (rc instanceof BacktrackInfoWithCleanup)
+		while (rc instanceof BacktrackInfoWithCleanup)
 		{
-			((BacktrackInfoWithCleanup) rc).cleanup(this);
+			backtrackInfoStack[backtrackInfoAmount] = null;
+			rc = backtrackInfoStack[--backtrackInfoAmount];
 		}
 		backtrackInfoStack[backtrackInfoAmount] = null;
 		return rc;
diff --git a/src/gnu/prolog/vm/buildins/meta/Predicate_setup_call_catcher_cleanup.java b/src/gnu/prolog/vm/buildins/meta/Predicate_setup_call_catcher_cleanup.java
index 2a593c2..4c2a228 100644
--- a/src/gnu/prolog/vm/buildins/meta/Predicate_setup_call_catcher_cleanup.java
+++ b/src/gnu/prolog/vm/buildins/meta/Predicate_setup_call_catcher_cleanup.java
@@ -27,6 +27,7 @@ import gnu.prolog.vm.BacktrackInfoWithCleanup;
 import gnu.prolog.vm.ExecuteOnlyCode;
 import gnu.prolog.vm.Interpreter;
 import gnu.prolog.vm.PrologException;
+import gnu.prolog.vm.BacktrackInfo;
 import gnu.prolog.vm.interpreter.Predicate_call;
 
 /**
@@ -74,17 +75,30 @@ public class Predicate_setup_call_catcher_cleanup extends ExecuteOnlyCode
 			{
 				// Call cleanup if the 2nd arg fails, has an exception or is finished
 				// But first, unify the port with catcher
+				RC unifyRC = RC.SUCCESS_LAST;
 				if (rc == RC.FAIL)
 				{
-					rc = interpreter.unify(catcher, AtomTerm.get("fail"));
+					unifyRC = interpreter.unify(catcher, AtomTerm.get("fail"));
 				}
 				else if (rc == RC.SUCCESS_LAST)
 				{
-					rc = interpreter.unify(catcher, AtomTerm.get("exit"));
+					unifyRC = interpreter.unify(catcher, AtomTerm.get("exit"));
 				}
-				if (rc == RC.SUCCESS || rc == RC.SUCCESS_LAST)
+				if (unifyRC == RC.SUCCESS || unifyRC == RC.SUCCESS_LAST)
 				{
-					return Predicate_call.staticExecute(interpreter, false, cleanup);
+					RC cleanupRC = RC.SUCCESS;
+					// Save state so the cleanup leaves no choicepoints
+					BacktrackInfo bi = interpreter.peekBacktrackInfo();
+					cleanupRC = Predicate_call.staticExecute(interpreter, false, cleanup);
+					interpreter.popBacktrackInfoUntil(bi);
+					if (cleanupRC == RC.SUCCESS || cleanupRC == RC.SUCCESS_LAST)
+					{
+						return rc;
+					}
+					else
+					{
+						return cleanupRC;
+					}
 				}
 				else
 				{
diff --git a/test/inriasuite/extra/setup_call_catcher_cleanup b/test/inriasuite/extra/setup_call_catcher_cleanup
index 668eccb..35b0b99 100644
--- a/test/inriasuite/extra/setup_call_catcher_cleanup
+++ b/test/inriasuite/extra/setup_call_catcher_cleanup
@@ -6,7 +6,11 @@
 
 [(setup_call_catcher_cleanup(true, member(A, [a,b]), Catcher, true), !),  [[A <-- a, Catcher <-- !]]].
 
-[setup_call_catcher_cleanup(true, fail, Catcher, true), [[Catcher <-- fail]]].
+[setup_call_catcher_cleanup(true, fail, Catcher, true), failure].
+
+% Unfortunately I dont think it is possible to test for this case, since errors raised in the cleanup are ignored
+% and we expect the goal to fail, so setup_call_catcher_cleanup exits without binding Catcher after the cleanup is run
+% [setup_call_catcher_cleanup(true, fail, Catcher, (Catcher == fail, throw(was_fail))), [unexpected_ball(was_fail)]].
 
 [setup_call_catcher_cleanup(true, throw(egg), Catcher, true), [[Catcher <-- exception(egg)]]].
 
@@ -20,4 +24,9 @@
 
 [setup_call_catcher_cleanup(true, true, Catcher, throw(egg)), unexpected_ball(egg)].
 
+[(setup_call_catcher_cleanup(true, member(A, [a,b,c]), Catcher, true), A == b),  [[A <-- b]]].
+
+[(setup_call_catcher_cleanup(true, member(A, [a,b,c]), Catcher, true), A == b, !),  [[A <-- b, Catcher <-- !]]].
+
+
 /* end of file setup_call_catcher_cleanup  */
-- 
1.7.8