use arrays to implement catch and throw instead of record
cleanup queues at top-level and at catch-throw. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@69 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
parent
08ebcf94be
commit
97d882c1a7
87
C/arrays.c
87
C/arrays.c
@ -771,6 +771,36 @@ p_create_static_array(void)
|
||||
}
|
||||
}
|
||||
|
||||
/* has a static array associated (+Name) */
|
||||
static Int
|
||||
p_has_static_array(void)
|
||||
{
|
||||
Term t = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t)) {
|
||||
return (FALSE);
|
||||
}
|
||||
else if (IsAtomTerm(t)) {
|
||||
/* Create a named array */
|
||||
AtomEntry *ae = RepAtom(AtomOfTerm(t));
|
||||
StaticArrayEntry *pp;
|
||||
|
||||
READ_LOCK(ae->ARWLock);
|
||||
pp = RepStaticArrayProp(ae->PropOfAE);
|
||||
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
|
||||
pp = RepStaticArrayProp(pp->NextOfPE);
|
||||
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
return (FALSE);
|
||||
} else {
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
return(TRUE);
|
||||
}
|
||||
} else {
|
||||
return (FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
/* resize a static array (+Name, + Size, +Props) */
|
||||
/* does not work for mmap arrays yet */
|
||||
static Int
|
||||
@ -1369,7 +1399,7 @@ p_assign_static(void)
|
||||
Error(INSTANTIATION_ERROR,t3,"assign_static");
|
||||
return (FALSE);
|
||||
}
|
||||
if (indx < 0 || indx >= - ptr->ArrayEArity) {
|
||||
if (indx < 0 || indx >= - ptr->ArrayEArity) {
|
||||
WRITE_UNLOCK(ptr->ArRWLock);
|
||||
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
|
||||
}
|
||||
@ -1543,6 +1573,60 @@ p_sync_mmapped_arrays(void)
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/*
|
||||
This is a hack, to steal the first element of a key.
|
||||
|
||||
It first fetches the first element in the chain, and then erases it
|
||||
through its reference.
|
||||
|
||||
Be careful when using this routine. It is especially evil because if
|
||||
the term is ground it should be copied to the stack, as space for
|
||||
the entry may be deleted. For the moment, the terms I want are just
|
||||
integers, so no problemo, amigo.
|
||||
|
||||
*/
|
||||
static Term
|
||||
StealFirstFromDB(DBRef ref)
|
||||
{
|
||||
Term TermDB, out;
|
||||
|
||||
if ((TermDB = FetchTermFromDB(ref,3)) == (CELL)0) {
|
||||
/* oops, we are in trouble, not enough stack space */
|
||||
return(TermNil);
|
||||
}
|
||||
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
|
||||
/* it's not a wonderful world afterall */
|
||||
return(TermNil);
|
||||
out = ArgOfTerm(1,TermDB);
|
||||
/* now, return what once was there, only nevermore */
|
||||
return(out);
|
||||
}
|
||||
|
||||
Int
|
||||
SetDBForThrow(Term Message)
|
||||
{
|
||||
Term cut_pt_term;
|
||||
Atom a = FullLookupAtom("$catch_queue");
|
||||
AtomEntry *ae = RepAtom(a);
|
||||
StaticArrayEntry *ptr;
|
||||
DBRef ref;
|
||||
READ_LOCK(ae->ARWLock);
|
||||
ptr = RepStaticArrayProp(ae->PropOfAE);
|
||||
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
|
||||
ptr = RepStaticArrayProp(ptr->NextOfPE);
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
ref = ptr->ValueOfVE.terms[0];
|
||||
|
||||
cut_pt_term = StealFirstFromDB(ref);
|
||||
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
|
||||
/* ooops, babe we are in trouble */
|
||||
return(-1);
|
||||
}
|
||||
/* OK, we've got the place to cut to, next store the new throw */
|
||||
ptr->ValueOfVE.terms[1] = StoreTermInDB(Message,3);
|
||||
return(IntegerOfTerm(cut_pt_term));
|
||||
}
|
||||
|
||||
void
|
||||
InitArrayPreds(void)
|
||||
{
|
||||
@ -1558,5 +1642,6 @@ InitArrayPreds(void)
|
||||
InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
|
||||
InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
|
||||
InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag);
|
||||
InitCPred("$has_static_array", 1, p_has_static_array, TestPredFlag|SafePredFlag);
|
||||
}
|
||||
|
||||
|
||||
133
C/dbase.c
133
C/dbase.c
@ -114,7 +114,7 @@ typedef struct {
|
||||
} SFKeep;
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
typedef struct idb_queue
|
||||
{
|
||||
Functor id; /* identify this as being pointed to by a DBRef */
|
||||
Term EntryTerm; /* cell bound to itself */
|
||||
@ -123,6 +123,8 @@ typedef struct
|
||||
rwlock_t QRWLock; /* a simple lock to protect this entry */
|
||||
#endif
|
||||
DBRef FirstInQueue, LastInQueue;
|
||||
Int age; /* the number of catches when we created the queue */
|
||||
struct idb_queue *next, *prev;
|
||||
} db_queue;
|
||||
|
||||
#define HashFieldMask ((CELL)0xffL)
|
||||
@ -263,7 +265,6 @@ STATIC_PROTO(Int p_dequeue, (void));
|
||||
STATIC_PROTO(Int p_first_age, (void));
|
||||
STATIC_PROTO(Int p_db_nb_to_ref, (void));
|
||||
STATIC_PROTO(Int p_last_age, (void));
|
||||
STATIC_PROTO(Term StealFirstFromDB, (Atom, Int));
|
||||
|
||||
#if OS_HANDLES_TR_OVERFLOW
|
||||
#define check_trail(x)
|
||||
@ -3451,24 +3452,6 @@ p_erase(void)
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
/* erase(+Ref) */
|
||||
static Int
|
||||
p_smash(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t1)) {
|
||||
Error(INSTANTIATION_ERROR, t1, "erase");
|
||||
return (FALSE);
|
||||
}
|
||||
if (!IsDBRefTerm(t1)) {
|
||||
Error(TYPE_ERROR_DBREF, t1, "erase");
|
||||
return (FALSE);
|
||||
}
|
||||
EraseEntry(DBRefOfTerm(t1));
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
/* eraseall(+Key) */
|
||||
static Int
|
||||
p_eraseall(void)
|
||||
@ -3799,7 +3782,7 @@ p_init_queue(void)
|
||||
db_queue *dbq;
|
||||
Term t;
|
||||
|
||||
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NIL) {
|
||||
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
|
||||
if (!growheap(FALSE)) {
|
||||
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
|
||||
return(FALSE);
|
||||
@ -3808,12 +3791,17 @@ p_init_queue(void)
|
||||
dbq->id = FunctorDBRef;
|
||||
dbq->EntryTerm = MkAtomTerm(AbsAtom((AtomEntry *)dbq));
|
||||
dbq->Flags = DBClMask;
|
||||
dbq->FirstInQueue = dbq->LastInQueue = NIL;
|
||||
dbq->FirstInQueue = dbq->LastInQueue = NULL;
|
||||
dbq->next = DBQueues;
|
||||
dbq->prev = NULL;
|
||||
DBQueues = dbq;
|
||||
dbq->age = IntOfTerm(GetValue(AtomCatch));
|
||||
INIT_RWLOCK(dbq->QRWLock);
|
||||
t = MkDBRefTerm((DBRef)dbq);
|
||||
return(unify(ARG1, t));
|
||||
}
|
||||
|
||||
|
||||
static Int
|
||||
p_enqueue(void)
|
||||
{
|
||||
@ -3887,6 +3875,12 @@ p_dequeue(void)
|
||||
WRITE_LOCK(father_key->QRWLock);
|
||||
if ((cur_instance = father_key->FirstInQueue) == NIL) {
|
||||
/* an empty queue automatically goes away */
|
||||
if (father_key == DBQueues)
|
||||
DBQueues = father_key->next;
|
||||
else
|
||||
father_key->prev->next = father_key->next;
|
||||
if (father_key->next != NULL)
|
||||
father_key->next->prev = father_key->prev;
|
||||
WRITE_UNLOCK(father_key->QRWLock);
|
||||
FreeDBSpace((char *) father_key);
|
||||
return(FALSE);
|
||||
@ -3907,77 +3901,34 @@ p_dequeue(void)
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
This is a hack, to steal the first element of a key.
|
||||
|
||||
It first fetches the first element in the chain, and then erases it
|
||||
through its reference.
|
||||
|
||||
Be careful when using this routine. It is especially evil because if
|
||||
the term is ground it should be copied to the stack, as space for
|
||||
the entry may be deleted. For the moment, the terms I want are just
|
||||
integers, so no problemo, amigo.
|
||||
|
||||
*/
|
||||
static Term
|
||||
StealFirstFromDB(Atom key, Int arity)
|
||||
static Int
|
||||
p_clean_queues(void)
|
||||
{
|
||||
Prop AtProp;
|
||||
Register DBRef ref;
|
||||
Term TermDB;
|
||||
Term out;
|
||||
Int myage = IntOfTerm(ARG1);
|
||||
db_queue *ptr;
|
||||
YAPEnterCriticalSection();
|
||||
ptr = DBQueues;
|
||||
while (ptr) {
|
||||
if (ptr->age >= myage) {
|
||||
DBRef cur_instance;
|
||||
db_queue *optr = ptr;
|
||||
|
||||
/* get the DB property */
|
||||
if ((AtProp = FindDBProp(RepAtom(key), 0, arity)) == NIL) {
|
||||
return(TermNil);
|
||||
while ((cur_instance = ptr->FirstInQueue)) {
|
||||
/* release space for cur_instance */
|
||||
ptr->FirstInQueue = (DBRef)(cur_instance->Parent);
|
||||
ErasePendingRefs(cur_instance);
|
||||
FreeDBSpace((char *) cur_instance);
|
||||
}
|
||||
ptr = ptr->next;
|
||||
FreeDBSpace((char *) optr);
|
||||
} else
|
||||
break;
|
||||
}
|
||||
/* get the first entry */
|
||||
#ifdef KEEP_OLD_ENTRIES_HANGING_ABOUT
|
||||
ref = RepDBProp(AtProp)->FirstNEr;
|
||||
#else
|
||||
ref = RepDBProp(AtProp)->First;
|
||||
#endif
|
||||
/* is there anyone home ? */
|
||||
while (ref != NIL
|
||||
&& (ref->Flags & (DBCode | ErasedMask)))
|
||||
ref = NextDBRef(ref);
|
||||
if (ref == NIL) {
|
||||
return(TermNil);
|
||||
}
|
||||
/* get our fine term */
|
||||
if ((TermDB = GetDBTerm(ref)) == (CELL)0) {
|
||||
/* oops, we are in trouble, not enough stack space */
|
||||
return(TermNil);
|
||||
}
|
||||
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
|
||||
/* it's not a wonderful world afterall */
|
||||
return(TermNil);
|
||||
|
||||
out = ArgOfTerm(1,TermDB);
|
||||
/* next, make it disappear from the DB */
|
||||
EraseEntry(ref);
|
||||
/* now, return what once was there, only nevermore */
|
||||
return(out);
|
||||
}
|
||||
|
||||
Int
|
||||
SetDBForThrow(Term Message)
|
||||
{
|
||||
Term cut_pt_term;
|
||||
|
||||
/* who's gonna catch us? */
|
||||
DBModule = 0;
|
||||
cut_pt_term = StealFirstFromDB(AtomCatch, 0);
|
||||
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
|
||||
/* ooops, babe we are in trouble */
|
||||
return(-1);
|
||||
}
|
||||
/* OK, we've got the place to cut to, next store the new throw */
|
||||
if (record(MkFirst, MkAtomTerm(AtomThrow), Message, TermNil) == NIL)
|
||||
return (-1);
|
||||
else
|
||||
/* off we go, to see the wizard of Oz */
|
||||
return(IntegerOfTerm(cut_pt_term));
|
||||
if (ptr)
|
||||
ptr->prev = NULL;
|
||||
DBQueues = ptr;
|
||||
YAPLeaveCriticalSection();
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/* given a key, find the clock number for the first entry */
|
||||
@ -4187,7 +4138,6 @@ InitDBPreds(void)
|
||||
InitCPred("$recordzp", 4, p_drcdzp, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$recordaifnot", 3, p_rcdaifnot, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$recordzifnot", 3, p_rcdzifnot, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$db_smash", 1, p_smash, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
|
||||
InitCPred("instance", 2, p_instance, SyncPredFlag);
|
||||
@ -4199,6 +4149,7 @@ InitDBPreds(void)
|
||||
InitCPred("$db_key", 2, p_db_key, 0);
|
||||
InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
|
||||
InitCPred("$db_dequeue", 2, p_dequeue, SyncPredFlag);
|
||||
InitCPred("$db_clean_queues", 1, p_clean_queues, SyncPredFlag);
|
||||
InitCPred("$db_first_age", 2, p_first_age, TestPredFlag|SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$db_nb_to_ref", 3, p_db_nb_to_ref, TestPredFlag|SafePredFlag);
|
||||
InitCPred("$db_last_age", 2, p_last_age, TestPredFlag|SafePredFlag|SyncPredFlag);
|
||||
|
||||
1
C/init.c
1
C/init.c
@ -820,6 +820,7 @@ InitCodes(void)
|
||||
heap_regs->no_of_modules = 1;
|
||||
heap_regs->primitives_module = 0;
|
||||
heap_regs->user_module = 1;
|
||||
heap_regs->db_queues = NULL;
|
||||
heap_regs->atom_abol = LookupAtom("$abol");
|
||||
AtomAltNot = LookupAtom("not");
|
||||
heap_regs->atom_append = LookupAtom ("append");
|
||||
|
||||
4
C/save.c
4
C/save.c
@ -944,6 +944,10 @@ restore_codes(void)
|
||||
heap_regs->dead_clauses = (Clause *)
|
||||
AddrAdjust((ADDR)(heap_regs->dead_clauses));
|
||||
}
|
||||
if (heap_regs->db_queues != NULL) {
|
||||
heap_regs->db_queues = (struct idb_queue *)
|
||||
AddrAdjust((ADDR)(heap_regs->db_queues));
|
||||
}
|
||||
heap_regs->retry_recorded_code =
|
||||
PtoOpAdjust(heap_regs->retry_recorded_code);
|
||||
heap_regs->retry_recorded_k_code =
|
||||
|
||||
@ -1099,7 +1099,7 @@ ProcessSIGINT(void)
|
||||
if (in_readline) {
|
||||
/* readline must eat a newline, otherwise we will
|
||||
have to wait before we do the Abort() */
|
||||
} else {
|
||||
} else if (!(PrologMode & CritMode)) {
|
||||
#endif
|
||||
#if defined(__MINGW32__) || _MSC_VER
|
||||
/* we can't do a direct abort, so ask the system to do it for us */
|
||||
|
||||
4
H/Heap.h
4
H/Heap.h
@ -10,7 +10,7 @@
|
||||
* File: Heap.h *
|
||||
* mods: *
|
||||
* comments: Heap Init Structure *
|
||||
* version: $Id: Heap.h,v 1.4 2001-06-08 13:38:42 vsc Exp $ *
|
||||
* version: $Id: Heap.h,v 1.5 2001-06-08 19:10:43 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
|
||||
/* information that can be stored in Code Space */
|
||||
@ -133,6 +133,7 @@ typedef struct various_codes {
|
||||
#endif
|
||||
int primitives_module;
|
||||
int user_module;
|
||||
struct idb_queue *db_queues;
|
||||
Atom
|
||||
atom_abol,
|
||||
atom_alarm,
|
||||
@ -316,6 +317,7 @@ typedef struct various_codes {
|
||||
#define ModuleName heap_regs->module_name
|
||||
#define PrimitivesModule heap_regs->primitives_module
|
||||
#define UserModule heap_regs->user_module
|
||||
#define DBQueues heap_regs->db_queues
|
||||
#define NoOfModules heap_regs->no_of_modules
|
||||
#define AtomAbol heap_regs->atom_abol
|
||||
#define AtomAlarm heap_regs->atom_alarm
|
||||
|
||||
@ -16,6 +16,7 @@
|
||||
|
||||
<h2>Yap-4.3.19:</h2>
|
||||
<ul>
|
||||
<li>FIXED: change catch and throw to use arrays.</li>
|
||||
<li>CLEANUP: split TRAIL_REF.</li>
|
||||
<li>FIXED: give correct type to FreeBlocks.</li>
|
||||
<li>FIXED: give correct type to alias list.</li>
|
||||
|
||||
81
pl/boot.yap
81
pl/boot.yap
@ -43,6 +43,7 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
),
|
||||
'$set_yap_flags'(10,0),
|
||||
'$set_value'('$gc',on),
|
||||
'$init_catch',
|
||||
prompt(' ?- '),
|
||||
(
|
||||
'$get_value'('$break',0)
|
||||
@ -61,13 +62,25 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
|
||||
),
|
||||
'$clean_catch_and_throw',
|
||||
'$db_clean_queues'(0),
|
||||
'$startup_reconsult',
|
||||
'$startup_goals'
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%
|
||||
'$init_catch' :-
|
||||
% initialise access to the catch queue
|
||||
( '$has_static_array'('$catch_queue') ->
|
||||
true
|
||||
;
|
||||
static_array('$catch_queue',2, term)
|
||||
),
|
||||
update_array('$catch_queue', 0, '$'),
|
||||
update_array('$catch_queue', 1, '$').
|
||||
|
||||
|
||||
%
|
||||
% encapsulate $cut_by because of co-routining.
|
||||
%
|
||||
'$cut_by'(X) :- '$$cut_by'(X).
|
||||
@ -1122,9 +1135,9 @@ catch(G,C,A) :-
|
||||
'$catch'(G,C,A).
|
||||
|
||||
'$catch'(G,C,A) :-
|
||||
'$get_value'('$catch_counter', I),
|
||||
'$get_value'('$catch', I),
|
||||
I1 is I+1,
|
||||
'$set_value'('$catch_counter', I1),
|
||||
'$set_value'('$catch', I1),
|
||||
'$current_module'(M),
|
||||
'$catch'(G,C,A,I,M).
|
||||
|
||||
@ -1134,23 +1147,35 @@ catch(G,C,A) :-
|
||||
'$catch_call'(X,G,I).
|
||||
% someone sent us a throw.
|
||||
'$catch'(_,C,A,_,M) :-
|
||||
('$recorded'('$throw',X,R)->true),
|
||||
erase(R),
|
||||
array_element('$catch_queue', 1, X), X \= '$',
|
||||
update_array('$catch_queue', 1, '$'),
|
||||
array_element('$catch_queue', 0, catch(_,Lev,Q)),
|
||||
update_array('$catch_queue', 0, Q),
|
||||
'$db_clean_queues'(Lev),
|
||||
( C=X -> '$current_module'(_,M), '$execute'(A) ; throw(X)).
|
||||
% normal exit: make sure we only erase what we should erase!
|
||||
'$catch'(_,_,_,I,_) :-
|
||||
'$recorded'('$catch','$catch'(_,J),R), J >= I,
|
||||
erase(R), fail.
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
'$erase_catch_elements'(OldCatch, I, Catch),
|
||||
update_array('$catch_queue', 0, Catch),
|
||||
fail.
|
||||
|
||||
'$erase_catch_elements'(catch(X, J, P), I, Catch) :-
|
||||
J >= I, !,
|
||||
'$erase_catch_elements'(P, I, Catch).
|
||||
'$erase_catch_elements'(Catch, _, Catch).
|
||||
|
||||
'$catch_call'(X,G,I) :-
|
||||
'$recorda'('$catch','$catch'(X,I),_),
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
|
||||
'$execute'(G),
|
||||
( % on exit remove the catch
|
||||
('$recorded'('$catch','$catch'(X,I),R)->true),
|
||||
erase(R)
|
||||
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||
update_array('$catch_queue', 0, Catch)
|
||||
;
|
||||
% on backtracking reinstate the catch before backtracking to G
|
||||
'$recorda'('$catch','$catch'(X,I),_),
|
||||
array_element('$catch_queue', 0, Catch),
|
||||
update_array('$catch_queue', 0, catch(X,I,Catch)),
|
||||
fail
|
||||
).
|
||||
|
||||
@ -1161,9 +1186,9 @@ catch(G,C,A) :-
|
||||
% also avoids module preprocessing and goal_expansion
|
||||
%
|
||||
'$system_catch'(G,C,A) :-
|
||||
'$get_value'('$catch_counter', I),
|
||||
'$get_value'('$catch', I),
|
||||
I1 is I+1,
|
||||
'$set_value'('$catch_counter', I1),
|
||||
'$set_value'('$catch', I1),
|
||||
'$current_module'(M),
|
||||
'$system_catch'(G,C,A,I,M).
|
||||
|
||||
@ -1173,8 +1198,11 @@ catch(G,C,A) :-
|
||||
'$system_catch_call'(X,G,I).
|
||||
% someone sent us a throw.
|
||||
'$system_catch'(_,C,A,_,M0) :-
|
||||
('$recorded'('$throw',X,R)->true),
|
||||
erase(R),
|
||||
array_element('$catch_queue', 1, X), X \= '$',
|
||||
update_array('$catch_queue', 1, '$'),
|
||||
array_element('$catch_queue', 0, catch(_,Lev,Q)),
|
||||
'$db_clean_queues'(Lev),
|
||||
update_array('$catch_queue', 0, Q),
|
||||
( C=X ->
|
||||
'$current_module'(_,M0),
|
||||
(A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A))
|
||||
@ -1183,27 +1211,30 @@ catch(G,C,A) :-
|
||||
).
|
||||
% normal exit: make sure we only erase what we should erase!
|
||||
'$system_catch'(_,_,_,I,_) :-
|
||||
'$recorded'('$catch','$catch'(_,J),R), J >= I,
|
||||
erase(R), fail.
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
'$erase_catch_elements'(OldCatch, I, Catch),
|
||||
update_array('$catch_queue', 0, Catch),
|
||||
fail.
|
||||
|
||||
'$system_catch_call'(X,G,I) :-
|
||||
'$recorda'('$catch','$catch'(X,I),_),
|
||||
array_element('$catch_queue', 0, OldCatch),
|
||||
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
|
||||
'$execute0'(G),
|
||||
( % on exit remove the catch
|
||||
('$recorded'('$catch','$catch'(X,I),R)->true),
|
||||
erase(R)
|
||||
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||
update_array('$catch_queue', 0, Catch)
|
||||
;
|
||||
% on backtracking reinstate the catch before backtracking to G
|
||||
'$recorda'('$catch','$catch'(X,I),_),
|
||||
array_element('$catch_queue', 0, Catch),
|
||||
update_array('$catch_queue', 0, catch(X,I,Catch)),
|
||||
fail
|
||||
).
|
||||
|
||||
throw(A) :-
|
||||
% fetch the point to jump to
|
||||
'$recorded'('$catch','$catch'(X,_),R), !,
|
||||
erase(R),
|
||||
array_element('$catch_queue', 0, catch(X,_,_)), !,
|
||||
% now explain why we are jumping.
|
||||
'$recordz'('$throw',A,_),
|
||||
update_array('$catch_queue', 1, A),
|
||||
'$$cut_by'(X),
|
||||
fail.
|
||||
throw(G) :-
|
||||
@ -1218,7 +1249,7 @@ throw(G) :-
|
||||
throw(error(type_error(list,S),T)).
|
||||
|
||||
'$clean_catch_and_throw' :-
|
||||
'$set_value'('$catch_counter', 0),
|
||||
'$set_value'('$catch', 0),
|
||||
fail.
|
||||
'$clean_catch_and_throw' :-
|
||||
'$recorded'('$catch',_,R),
|
||||
|
||||
Reference in New Issue
Block a user