diff --git a/C/c_interface.c b/C/c_interface.c index 8f9ae15fa..676b6c399 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -1940,6 +1940,7 @@ YAP_GoalHasException(Term *t) X_API void YAP_ClearExceptions(void) { + Yap_DeleteGlobal(AtomCatch); EX = 0L; UncaughtThrow = FALSE; } diff --git a/C/exec.c b/C/exec.c index 89ea9d0b3..d496259f0 100644 --- a/C/exec.c +++ b/C/exec.c @@ -1428,227 +1428,116 @@ p_cut_up_to_next_disjunction(void) { return TRUE; } -static int -suspended_on_current_execution(Term t, Term t0) +static int is_cleanup_cp(choiceptr cp_b) { - attvar_record *susp = (attvar_record *)VarOfTerm(t); - Term t1 = susp->Atts; - /* should be prolog(_,Something) */ - if(IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FunctorPrologConstraint) + PredEntry *pe; + + if (cp_b->cp_ap->opc != ORLAST_OPCODE) 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) || FunctorOfTerm(t1) != FunctorRedoFreeze) - return FALSE; - t1 = ArgOfTerm(3,t1); - /* Suspended = Mod:Cod */ - if(IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FunctorModule) - return FALSE; - t1 = ArgOfTerm(2,t1); - /* Cod = $clean_call(t0,_) */ - if(IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FunctorCleanCall) - return FALSE; - /* we found what was on the cp */ - return t0 == ArgOfTerm(1, t1); -} - -static Term -build_error(void) -{ - Term ti[1], nt[2]; - ti[0] = MkAtomTerm(AtomStack); - nt[0] = Yap_MkApplTerm(FunctorResourceError, 1, ti); - nt[1] = MkAtomTerm(AtomInStackExpansion); - return Yap_MkApplTerm(FunctorError, 2, nt); -} - - -static Term -get_term(DBTerm *dbt, Term t) -{ - if (dbt) { - while (!(t = Yap_PopTermFromDB(dbt))) { - if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) { - Yap_Error_TYPE = YAP_NO_ERROR; - if (!Yap_growglobal(NULL)) { - t = build_error(); - break; - } - } else { - Yap_Error_TYPE = YAP_NO_ERROR; - if (!Yap_growstack(dbt->NOfCells*CellSize)) { - t = build_error(); - break; - } - } - } - if (t) { - B->cp_h = H; - } - } - return t; -} - - -static Term -clean_trail(Term t, DBTerm *dbt, Term t0) -{ - tr_fr_ptr pt1, pbase; - -#ifdef SHADOW_HB - register CELL *HBREG = HB; -#endif /* SHADOW_HB */ - - pbase = B->cp_tr; - pt1 = TR - 1; - while (pt1 >= pbase) { - Term d1 = TrailTerm(pt1); - if (IsVarTerm(d1)) { -#if defined(SBA) && defined(YAPOR) - /* clean up the trail when we backtrack */ - if (Unsigned((Int)(d1)-(Int)(H_FZ)) > - Unsigned((Int)(B_FZ)-(Int)(H_FZ))) { - RESET_VARIABLE(STACK_TO_SBA(d1)); - } else -#endif - /* normal variable */ - RESET_VARIABLE(d1); - RESET_VARIABLE(&TrailTerm(pt1)); - pt1--; - } else if (IsPairTerm(d1)) { - CELL *pt = RepPair(d1); - if ((ADDR) pt >= Yap_TrailBase && (ADDR)pt < Yap_TrailTop) { - /* skip, this is a problem because we lose information, - namely active references */ - pt1 = (tr_fr_ptr)pt; - } else if (IN_BETWEEN(Yap_GlobalBase, pt, H0)) { - CELL val = Deref(*pt); - if (IsVarTerm(val)) { - if (suspended_on_current_execution(val, t0)) { - RESET_VARIABLE(&TrailTerm(pt1)); - } else { - TR = pt1+1; - t = get_term(dbt, t); - Bind(pt, t); - Yap_WakeUp(pt); - return t; - } - } - } - pt1--; - } else if (IsApplTerm(d1)) { - CELL *pt = RepAppl(d1); - /* AbsAppl means */ - /* multi-assignment variable */ - /* so the next cell is the old value */ -#ifdef FROZEN_STACKS - RESET_VARIABLE(&TrailTerm(pt1)); - --pt1; - pt[0] = TrailVal(pt1); - RESET_VARIABLE(&TrailTerm(pt1)); - --pt1; +#ifdef YAPOR + pe = cp_b->cp_ap->u.Osblp.p; #else - pt[0] = TrailTerm(pt1-1); - RESET_VARIABLE(&TrailTerm(pt1)); - RESET_VARIABLE(&TrailTerm(pt1-1)); - RESET_VARIABLE(&TrailTerm(pt1-2)); - pt1 -= 3; -#endif /* FROZEN_STACKS */ - } - } - TR = pt1+1; - t = get_term(dbt, t); - return t; + pe = cp_b->cp_ap->u.p.p; +#endif /* YAPOR */ + return (pe == PredSafeCallCleanup); } - static Int JumpToEnv(Term t) { yamop *pos = NEXTOP(PredDollarCatch->cs.p_code.TrueCodeOfPred,l), *catchpos = NEXTOP(PredHandleThrow->cs.p_code.TrueCodeOfPred,l); - CELL *env; - choiceptr first_func = NULL, B0 = B; - DBTerm *dbt; + CELL *env, *env1; + choiceptr handler, previous = NULL; - if (!(dbt = Yap_StoreTermInDB(t, -1))) { - if (!(t = Yap_SaveTerm(t))) - return FALSE; + /* throws cannot interrupt throws */ + if (EX) + return FALSE; + /* just keep the throwed object away, we don't need to care about it */ + if (!(t = Yap_SetGlobalVal(AtomCatch, t))) { + /* fat chance */ + siglongjmp(Yap_RestartEnv,1); } + /* careful, previous step may have caused a stack shift, + so get pointers here */ + handler = B; + env1 = ENV; do { /* find the first choicepoint that may be a catch */ - while (B != NULL && B->cp_ap != pos) { + while (handler != NULL && handler->cp_ap != pos) { /* we are already doing a catch */ - if (B->cp_ap == catchpos) { + if (handler->cp_ap == catchpos) { P = (yamop *)FAILCODE; - if (first_func != NULL) { - B = first_func; - } - return(FALSE); + return TRUE; } - if (B->cp_ap == NOCODE) { + /* we have a cleanup handler in the middle */ + if (is_cleanup_cp(handler)) { + /* keep it around */ + if (previous == NULL) + B = handler; + else + previous->cp_b = handler; + previous = handler; +#ifdef TABLING + } else { + abolish_incomplete_subgoals(handler); +#endif /* TABLING */ + } + /* we reached C-Code */ + if (handler->cp_ap == NOCODE) { /* up to the C-code to deal with this! */ UncaughtThrow = TRUE; - B->cp_h = H; + if (previous == NULL) + B = handler; + else + previous->cp_b = handler; EX = t; - return FALSE; + P = (yamop *)FAILCODE; + HB = B->cp_h; + return TRUE; } - B = B->cp_b; + handler = handler->cp_b; } /* uncaught throw */ - if (B == NULL) { + if (handler == NULL) { UncaughtThrow = TRUE; - B = B0; #if PUSH_REGS restore_absmi_regs(&Yap_standard_regs); #endif siglongjmp(Yap_RestartEnv,1); } /* is it a continuation? */ - env = B->cp_env; - while (env > ENV) { - ENV = ENV_Parent(ENV); + env = handler->cp_env; + while (env > env1) { + env1 = ENV_Parent(env1); } /* yes, we found it ! */ // while (env < ENV) // env = ENV_Parent(env); - if (env == ENV) { + if (env == env1) { break; } /* oops, try next */ - B = B->cp_b; + handler = handler->cp_b; } while (TRUE); /* step one environment above, otherwise we'll redo the original goal */ - B->cp_cp = (yamop *)env[E_CP]; - B->cp_env = (CELL *)env[E_E]; - B->cp_ap = NEXTOP(PredHandleThrow->CodeOfPred,l); + if (previous == NULL) { + B = handler; + } else { + // EX = t; + previous->cp_b = handler; + } + handler->cp_cp = (yamop *)env[E_CP]; + handler->cp_env = (CELL *)env[E_E]; + handler->cp_ap = NEXTOP(PredHandleThrow->CodeOfPred,l); /* can recover Heap thanks to copy term :-( */ /* B->cp_h = H; */ /* I could backtrack here, but it is easier to leave the unwinding to the emulator */ P = (yamop *)FAILCODE; + HB = B->cp_h; /* try to recover space */ /* can only do that when we recover space */ - /* H = B->cp_h; */ - t = clean_trail(t, dbt, B->cp_a1); - B->cp_a3 = t; - B->cp_tr = TR; - if (first_func != NULL) { - B = first_func; - } -#ifdef TABLING - if (B != B0) { - while (B0->cp_b < B) { - B0 = B0->cp_b; - } - abolish_incomplete_subgoals(B0); - } -#endif /* TABLING */ + /* first, simulate backtracking */ /* so that I will execute op_fail */ return TRUE; } @@ -1694,6 +1583,7 @@ Yap_InitYaamRegs(void) Yap_regp = &Yap_standard_regs; #endif #endif /* PUSH_REGS */ + Yap_DeleteGlobal (AtomCatch); Yap_PutValue (AtomBreak, MkIntTerm (0)); TR = (tr_fr_ptr)Yap_TrailBase; if (Yap_AttsSize > (Yap_LocalBase-Yap_GlobalBase)/8) @@ -1795,6 +1685,13 @@ p_debug_on(void) return TRUE; } +static Int +p_reset_exception(void) +{ + EX = 0L; + return TRUE; +} + void Yap_InitExecFs(void) { @@ -1848,6 +1745,7 @@ Yap_InitExecFs(void) Yap_InitCPred("$creep_allowed", 0, p_creep_allowed, HiddenPredFlag); Yap_InitCPred("$generate_pred_info", 4, p_generate_pred_info, HiddenPredFlag); Yap_InitCPred("$uncaught_throw", 0, p_uncaught_throw, HiddenPredFlag); + Yap_InitCPred("$reset_exception", 0, p_reset_exception, HiddenPredFlag); } diff --git a/C/globals.c b/C/globals.c index 314d556f4..f1c79ccdc 100644 --- a/C/globals.c +++ b/C/globals.c @@ -1300,22 +1300,15 @@ p_nb_getval(void) return Yap_unify(ARG2, to); } -static Int -p_nb_delete(void) + +static Int +nbdelete(Atom at) { - Term t = Deref(ARG1); GlobalEntry *ge, *g; AtomEntry *ae; Prop gp, g0; - if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR,t,"nb_delete"); - return FALSE; - } else if (!IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t,"nb_delete"); - return FALSE; - } - ge = FindGlobalEntry(AtomOfTerm(t)); + ge = FindGlobalEntry(at); if (!ge) return FALSE; WRITE_LOCK(ge->GRWLock); @@ -1344,6 +1337,27 @@ p_nb_delete(void) return TRUE; } +Int +Yap_DeleteGlobal(Atom at) +{ + return nbdelete(at); +} + +static Int +p_nb_delete(void) +{ + Term t = Deref(ARG1); + + if (IsVarTerm(t)) { + Yap_Error(INSTANTIATION_ERROR,t,"nb_delete"); + return FALSE; + } else if (!IsAtomTerm(t)) { + Yap_Error(TYPE_ERROR_ATOM,t,"nb_delete"); + return FALSE; + } + return nbdelete(AtomOfTerm(t)); +} + static Int p_nb_create(void) { diff --git a/C/tracer.c b/C/tracer.c index 54e333105..7a5e6d9bc 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -269,7 +269,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) printf("\n"); } #endif - fprintf(Yap_stderr,"%lld ",vsc_count); + fprintf(Yap_stderr,"%lld %p ", vsc_count, TR); #if defined(THREADS) || defined(YAPOR) fprintf(Yap_stderr,"(%d)", worker_id); #endif diff --git a/H/Yapproto.h b/H/Yapproto.h index 0bb713331..7fb11b88e 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -192,6 +192,7 @@ Term STD_PROTO(Yap_NewArena,(UInt,CELL *)); void STD_PROTO(Yap_InitGlobals,(void)); Term STD_PROTO(Yap_SaveTerm, (Term)); Term STD_PROTO(Yap_SetGlobalVal, (Atom, Term)); +Int STD_PROTO(Yap_DeleteGlobal, (Atom)); void STD_PROTO(Yap_AllocateDefaultArena, (Int, Int)); /* grow.c */ diff --git a/H/dhstruct.h b/H/dhstruct.h index c3e7d4c8a..adf7c6ec0 100644 --- a/H/dhstruct.h +++ b/H/dhstruct.h @@ -85,6 +85,7 @@ #define FAIL_OPCODE Yap_heap_regs->fail_op #define INDEX_OPCODE Yap_heap_regs->index_op #define LOCKPRED_OPCODE Yap_heap_regs->lockpred_op +#define ORLAST_OPCODE Yap_heap_regs->orlast_op #define UNDEF_OPCODE Yap_heap_regs->undef_op #define NOfAtoms Yap_heap_regs->n_of_atoms @@ -148,6 +149,7 @@ #define PredThrow Yap_heap_regs->pred_throw #define PredHandleThrow Yap_heap_regs->pred_handle_throw #define PredIs Yap_heap_regs->pred_is +#define PredSafeCallCleanup Yap_heap_regs->pred_safe_call_cleanup #ifdef YAPOR #define PredGetwork Yap_heap_regs->pred_getwork #define PredGetworkSeq Yap_heap_regs->pred_getwork_seq diff --git a/H/hstruct.h b/H/hstruct.h index dc526569a..8ddb8a4aa 100644 --- a/H/hstruct.h +++ b/H/hstruct.h @@ -85,6 +85,7 @@ OPCODE fail_op; OPCODE index_op; OPCODE lockpred_op; + OPCODE orlast_op; OPCODE undef_op; UInt n_of_atoms; @@ -148,6 +149,7 @@ struct pred_entry *pred_throw; struct pred_entry *pred_handle_throw; struct pred_entry *pred_is; + struct pred_entry *pred_safe_call_cleanup; #ifdef YAPOR struct pred_entry *pred_getwork; struct pred_entry *pred_getwork_seq; diff --git a/H/iatoms.h b/H/iatoms.h index 445a70f79..6eff7a802 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -223,6 +223,7 @@ AtomRetryCounter = Yap_LookupAtom("retry_counter"); AtomRTree = Yap_LookupAtom("rtree"); AtomSafe = Yap_FullLookupAtom("$safe"); + AtomSafeCallCleanup = Yap_FullLookupAtom("$safe_call_cleanup"); AtomSame = Yap_LookupAtom("=="); AtomSemic = Yap_LookupAtom(";"); AtomShiftCountOverflow = Yap_LookupAtom("shift_count_overflow"); @@ -384,6 +385,7 @@ FunctorRestoreRegs = Yap_MkFunctor(AtomRestoreRegs,2); FunctorRestoreRegs1 = Yap_MkFunctor(AtomRestoreRegs,1); FunctorSafe = Yap_MkFunctor(AtomSafe,1); + FunctorSafeCallCleanup = Yap_MkFunctor(AtomSafeCallCleanup,4); FunctorSame = Yap_MkFunctor(AtomSame,2); FunctorSlash = Yap_MkFunctor(AtomSlash,2); FunctorStaticClause = Yap_MkFunctor(AtomStaticClause,1); diff --git a/H/ihstruct.h b/H/ihstruct.h index 36c794525..3dcc832e3 100644 --- a/H/ihstruct.h +++ b/H/ihstruct.h @@ -85,6 +85,7 @@ Yap_heap_regs->fail_op = Yap_opcode(_op_fail); Yap_heap_regs->index_op = Yap_opcode(_index_pred); Yap_heap_regs->lockpred_op = Yap_opcode(_lock_pred); + Yap_heap_regs->orlast_op = Yap_opcode(_or_last); Yap_heap_regs->undef_op = Yap_opcode(_undef_p); @@ -148,6 +149,7 @@ Yap_heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,PROLOG_MODULE)); Yap_heap_regs->pred_handle_throw = RepPredProp(PredPropByFunc(FunctorHandleThrow,PROLOG_MODULE)); Yap_heap_regs->pred_is = RepPredProp(PredPropByFunc(FunctorIs,PROLOG_MODULE)); + Yap_heap_regs->pred_safe_call_cleanup = RepPredProp(PredPropByFunc(FunctorSafeCallCleanup,PROLOG_MODULE)); #ifdef YAPOR Yap_heap_regs->pred_getwork = RepPredProp(PredPropByAtom(AtomGetwork,PROLOG_MODULE)); Yap_heap_regs->pred_getwork_seq = RepPredProp(PredPropByAtom(AtomGetworkSeq,PROLOG_MODULE)); diff --git a/H/ratoms.h b/H/ratoms.h index 825de0761..559de2392 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -225,6 +225,7 @@ AtomRetryCounter = AtomAdjust(AtomRetryCounter); AtomRTree = AtomAdjust(AtomRTree); AtomSafe = AtomAdjust(AtomSafe); + AtomSafeCallCleanup = AtomAdjust(AtomSafeCallCleanup); AtomSame = AtomAdjust(AtomSame); AtomSemic = AtomAdjust(AtomSemic); AtomShiftCountOverflow = AtomAdjust(AtomShiftCountOverflow); @@ -386,6 +387,7 @@ FunctorRestoreRegs = FuncAdjust(FunctorRestoreRegs); FunctorRestoreRegs1 = FuncAdjust(FunctorRestoreRegs1); FunctorSafe = FuncAdjust(FunctorSafe); + FunctorSafeCallCleanup = FuncAdjust(FunctorSafeCallCleanup); FunctorSame = FuncAdjust(FunctorSame); FunctorSlash = FuncAdjust(FunctorSlash); FunctorStaticClause = FuncAdjust(FunctorStaticClause); diff --git a/H/rhstruct.h b/H/rhstruct.h index 68bf30896..7c2d34ce1 100644 --- a/H/rhstruct.h +++ b/H/rhstruct.h @@ -85,6 +85,7 @@ Yap_heap_regs->fail_op = Yap_opcode(_op_fail); Yap_heap_regs->index_op = Yap_opcode(_index_pred); Yap_heap_regs->lockpred_op = Yap_opcode(_lock_pred); + Yap_heap_regs->orlast_op = Yap_opcode(_or_last); Yap_heap_regs->undef_op = Yap_opcode(_undef_p); @@ -148,6 +149,7 @@ Yap_heap_regs->pred_throw = PtoPredAdjust(Yap_heap_regs->pred_throw); Yap_heap_regs->pred_handle_throw = PtoPredAdjust(Yap_heap_regs->pred_handle_throw); Yap_heap_regs->pred_is = PtoPredAdjust(Yap_heap_regs->pred_is); + Yap_heap_regs->pred_safe_call_cleanup = PtoPredAdjust(Yap_heap_regs->pred_safe_call_cleanup); #ifdef YAPOR Yap_heap_regs->pred_getwork = PtoPredAdjust(Yap_heap_regs->pred_getwork); Yap_heap_regs->pred_getwork_seq = PtoPredAdjust(Yap_heap_regs->pred_getwork_seq); diff --git a/H/tatoms.h b/H/tatoms.h index 61aaca47d..06768078d 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -452,6 +452,8 @@ #define AtomRTree Yap_heap_regs->AtomRTree_ Atom AtomSafe_; #define AtomSafe Yap_heap_regs->AtomSafe_ + Atom AtomSafeCallCleanup_; +#define AtomSafeCallCleanup Yap_heap_regs->AtomSafeCallCleanup_ Atom AtomSame_; #define AtomSame Yap_heap_regs->AtomSame_ Atom AtomSemic_; @@ -774,6 +776,8 @@ #define FunctorRestoreRegs1 Yap_heap_regs->FunctorRestoreRegs1_ Functor FunctorSafe_; #define FunctorSafe Yap_heap_regs->FunctorSafe_ + Functor FunctorSafeCallCleanup_; +#define FunctorSafeCallCleanup Yap_heap_regs->FunctorSafeCallCleanup_ Functor FunctorSame_; #define FunctorSame Yap_heap_regs->FunctorSame_ Functor FunctorSlash_; diff --git a/misc/ATOMS b/misc/ATOMS index b544962f4..5c6009cbd 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -234,6 +234,7 @@ A RestoreRegs F "$restore_regs" A RetryCounter N "retry_counter" A RTree N "rtree" A Safe F "$safe" +A SafeCallCleanup F "$safe_call_cleanup" A Same N "==" A Semic N ";" A ShiftCountOverflow N "shift_count_overflow" @@ -395,6 +396,7 @@ F ResourceError ResourceError 1 F RestoreRegs RestoreRegs 2 F RestoreRegs1 RestoreRegs 1 F Safe Safe 1 +F SafeCallCleanup SafeCallCleanup 4 F Same Same 2 F Slash Slash 2 F StaticClause StaticClause 1 diff --git a/misc/HEAPFIELDS b/misc/HEAPFIELDS index 8f2942b4a..e0e0bf738 100644 --- a/misc/HEAPFIELDS +++ b/misc/HEAPFIELDS @@ -90,6 +90,7 @@ OPCODE expand_op_code EXPAND_OP_CODE MkOp _expand_index OPCODE fail_op FAIL_OPCODE MkOp _op_fail OPCODE index_op INDEX_OPCODE MkOp _index_pred OPCODE lockpred_op LOCKPRED_OPCODE MkOp _lock_pred +OPCODE orlast_op ORLAST_OPCODE MkOp _or_last OPCODE undef_op UNDEF_OPCODE MkOp _undef_p /* atom tables */ @@ -161,6 +162,7 @@ struct pred_entry *pred_static_clause PredStaticClause MkPred FunctorDoStaticCla struct pred_entry *pred_throw PredThrow MkPred FunctorThrow PROLOG_MODULE struct pred_entry *pred_handle_throw PredHandleThrow MkPred FunctorHandleThrow PROLOG_MODULE struct pred_entry *pred_is PredIs MkPred FunctorIs PROLOG_MODULE +struct pred_entry *pred_safe_call_cleanup PredSafeCallCleanup MkPred FunctorSafeCallCleanup PROLOG_MODULE #ifdef YAPOR struct pred_entry *pred_getwork PredGetwork MkPred AtomGetwork 0 PROLOG_MODULE struct pred_entry *pred_getwork_seq PredGetworkSeq MkPred AtomGetworkSeq 0 PROLOG_MODULE diff --git a/packages/chr b/packages/chr index f6a790076..c325e4564 160000 --- a/packages/chr +++ b/packages/chr @@ -1 +1 @@ -Subproject commit f6a79007615bf46dc79712c41d61289834f28ba3 +Subproject commit c325e4564bb8d4e32c27f2061df85f13d315974e diff --git a/packages/jpl b/packages/jpl index eb6d27251..a2d2f0310 160000 --- a/packages/jpl +++ b/packages/jpl @@ -1 +1 @@ -Subproject commit eb6d27251c2548c25e6d37fff2a27a014caaa7aa +Subproject commit a2d2f03107eecd45462cd61a678035132cf06326 diff --git a/packages/plunit/examples/simple.pl b/packages/plunit/examples/simple.pl index 9d45fca95..3afee1f9a 100644 --- a/packages/plunit/examples/simple.pl +++ b/packages/plunit/examples/simple.pl @@ -1,6 +1,7 @@ -:- module(ex_simple, []). :- use_module(library(plunit)). +:- module(ex_simple, []). + :- begin_tests(lists). test(true) :- diff --git a/pl/boot.yap b/pl/boot.yap index 6d5432960..575f2913a 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -1163,6 +1163,12 @@ catch(G, C, A) :- % % throw has to be *exactly* after system catch! % +throw(_Ball) :- + % use existing ball + nb_getval('$catch',Ball), + nb_delete('$catch'), + !, + '$jump_env_and_store_ball'(Ball). throw(Ball) :- % get current jump point '$jump_env_and_store_ball'(Ball). @@ -1173,7 +1179,10 @@ throw(Ball) :- '$catch'(_,_,_) :- fail. '$handle_throw'(_, _, _). -'$handle_throw'(C, A, Ball) :- +'$handle_throw'(C, A, _Ball) :- + nb_getval('$catch',Ball), + nb_delete('$catch'), + '$reset_exception', % reset info ('catch_ball'(Ball, C) -> '$execute'(A) diff --git a/pl/control.yap b/pl/control.yap index 32e995eff..3f96d0cf1 100644 --- a/pl/control.yap +++ b/pl/control.yap @@ -123,9 +123,13 @@ setup_call_catcher_cleanup(Setup, Goal, Catcher, 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) :- +'$clean_call'(_, Cleanup) :- '$execute'(Cleanup), !. -'$clean_call'(_,_). +'$clean_call'(_, _). + +'$cc_check_throw' :- + nb_getval('$catch',Ball), + throw(Ball). %%% The unknown predicate, % informs about what the user wants to be done when