From b72345cc97431bde312e0bd8a6f43c1ff91b2d73 Mon Sep 17 00:00:00 2001
From: Costa Vitor <vitor@quasar-20.(none)>
Date: Tue, 2 Jun 2009 19:46:41 -0500
Subject: [PATCH] handle correctly throws within the scope of a call_cleanup.
 This is implemented by using an extra argument to verify if the catcher is
 the current call_cleanup. If it is, we allow the exception to go forth.

---
 C/exec.c     | 43 +++++++++++++++++++++++++++++++++++++++----
 pl/utils.yap | 28 ++++++++++++++++------------
 2 files changed, 55 insertions(+), 16 deletions(-)

diff --git a/C/exec.c b/C/exec.c
index 062e08a9d..311b7f210 100644
--- a/C/exec.c
+++ b/C/exec.c
@@ -20,6 +20,7 @@ static char     SccsId[] = "@(#)cdmgr.c	1.1 05/02/98";
 
 #include "absmi.h"
 #include "yapio.h"
+#include "attvar.h"
 #ifdef CUT_C
 #include "cut_c.h"
 #endif
@@ -1432,8 +1433,38 @@ p_cut_up_to_next_disjunction(void) {
   return TRUE;
 }
 
+static int
+suspended_on_current_execution(Term t, Term t0)
+{
+  attvar_record *susp = (attvar_record *)VarOfTerm(t);
+  Term t1 = susp->Atts;
+  /* should be prolog(_,Something) */
+  if(IsVarTerm(t1) || !IsApplTerm(t1))
+    return FALSE;
+  t1 = ArgOfTerm(2, t1);
+  /* Something = [Goal] */
+  if (IsVarTerm(t1) || !IsPairTerm(t1))
+    return FALSE;
+  if (TailOfTerm(t1) != TermNil)
+    return FALSE;
+  t1 = HeadOfTerm(t1);
+  /* Goal = $redo_freeze(_,_,Suspended) */
+  if(IsVarTerm(t1) || !IsApplTerm(t1))
+    return FALSE;
+  t1 = ArgOfTerm(3,t1);
+  /* Suspended = Mod:Cod */
+  if(IsVarTerm(t1) || !IsApplTerm(t1))
+    return FALSE;
+  t1 = ArgOfTerm(2,t1);
+  /* Cod = $clean_call(t0,_) */
+  if(IsVarTerm(t1) || !IsApplTerm(t1))
+    return FALSE;
+  /* we found what was on the cp */
+  return t0 == ArgOfTerm(1, t1);
+}
+
 static void
-clean_trail(Term t)
+clean_trail(Term t, Term t0)
 {
   tr_fr_ptr pt1, pbase;
 
@@ -1461,8 +1492,12 @@ clean_trail(Term t)
       } else if (IN_BETWEEN(Yap_GlobalBase, pt, H0)) {
 	CELL val = Deref(*pt);
 	if (IsVarTerm(val)) {
-	  Bind(pt, t);
-	  Yap_WakeUp(pt);
+	  if (suspended_on_current_execution(val, t0)) {
+	    RESET_VARIABLE(&TrailTerm(pt1));
+	  } else {
+	    Bind(pt, t);
+	    Yap_WakeUp(pt);
+	  }
 	}
 	return;
       }
@@ -1546,7 +1581,7 @@ JumpToEnv(Term t) {
      to the emulator */
   B->cp_a3 = t;
   P = (yamop *)FAILCODE;
-  clean_trail(t);
+  clean_trail(t, B->cp_a1);
   if (first_func != NULL) {
     B = first_func;
   }
diff --git a/pl/utils.yap b/pl/utils.yap
index 2edc999b4..219790eec 100644
--- a/pl/utils.yap
+++ b/pl/utils.yap
@@ -67,7 +67,7 @@ setup_call_cleanup(Setup, Goal, Cleanup) :-
 setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
 	yap_hacks:disable_interrupts,
 	'$do_setup'(Setup),
-	catch('$safe_call_cleanup'(Goal,Cleanup,Catcher),
+	catch('$safe_call_cleanup'(Goal,Cleanup,Catcher,Exception),
 	      Exception,
 	      '$cleanup_exception'(Exception,Catcher,Cleanup)).
 
@@ -92,14 +92,14 @@ setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
 
 '$cleanup_exception'(Exception, exception(Exception), Cleanup) :- !,
 	% whatever happens, let exception go through 
-	catch('$clean_call'(Cleanup),_,true),
+	catch('$clean_call'(_,Cleanup),_,true),
 	throw(Exception).
 '$cleanup_exception'(Exception, _, _) :-
 	throw(Exception).
 
-'$safe_call_cleanup'(Goal, Cleanup, Catcher) :-
+'$safe_call_cleanup'(Goal, Cleanup, Catcher, Exception) :-
 	 yap_hacks:current_choice_point(MyCP1),
-	'$freeze_goal'(Catcher, '$clean_call'(Cleanup)),
+	'$freeze_goal'(Catcher, '$clean_call'(Exception, Cleanup)),
 	yap_hacks:trail_suspension_marker(Catcher),
 	(
 	 yap_hacks:enable_interrupts,
@@ -109,22 +109,26 @@ setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
 	 '$true',
 	 yap_hacks:current_choice_point(CPF),
 	 (
-	  CP0 =:= CPF ->
-	  Catcher = exit,
-	  !
+	  CP0 =:= CPF
+	 ->
+	   Catcher = exit,
+	   !
 	 ;
-	  true
+	   true
 	 )
 	;
-	 Catcher = fail,
-	 fail
+	  Catcher = fail,
+	  fail
 	).
 
 '$holds_true'.
 
-'$clean_call'(Cleanup) :-
+% The first argument is used by JumpEnv to verify if a throw
+% is going to be handled by the cleanup catcher. If it is so,
+% clean_call will not be called from JumpToEnv.
+'$clean_call'(_,Cleanup) :-
 	'$execute'(Cleanup), !.
-'$clean_call'(_).
+'$clean_call'(_,_).
 
 op(P,T,V) :-
 	'$check_op'(P,T,V,op(P,T,V)),