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:
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) */
|
/* resize a static array (+Name, + Size, +Props) */
|
||||||
/* does not work for mmap arrays yet */
|
/* does not work for mmap arrays yet */
|
||||||
static Int
|
static Int
|
||||||
|
@ -1369,7 +1399,7 @@ p_assign_static(void)
|
||||||
Error(INSTANTIATION_ERROR,t3,"assign_static");
|
Error(INSTANTIATION_ERROR,t3,"assign_static");
|
||||||
return (FALSE);
|
return (FALSE);
|
||||||
}
|
}
|
||||||
if (indx < 0 || indx >= - ptr->ArrayEArity) {
|
if (indx < 0 || indx >= - ptr->ArrayEArity) {
|
||||||
WRITE_UNLOCK(ptr->ArRWLock);
|
WRITE_UNLOCK(ptr->ArRWLock);
|
||||||
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
|
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
|
||||||
}
|
}
|
||||||
|
@ -1543,6 +1573,60 @@ p_sync_mmapped_arrays(void)
|
||||||
return(TRUE);
|
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
|
void
|
||||||
InitArrayPreds(void)
|
InitArrayPreds(void)
|
||||||
{
|
{
|
||||||
|
@ -1558,5 +1642,6 @@ InitArrayPreds(void)
|
||||||
InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
|
InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
|
||||||
InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
|
InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
|
||||||
InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, 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;
|
} SFKeep;
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
typedef struct
|
typedef struct idb_queue
|
||||||
{
|
{
|
||||||
Functor id; /* identify this as being pointed to by a DBRef */
|
Functor id; /* identify this as being pointed to by a DBRef */
|
||||||
Term EntryTerm; /* cell bound to itself */
|
Term EntryTerm; /* cell bound to itself */
|
||||||
|
@ -123,6 +123,8 @@ typedef struct
|
||||||
rwlock_t QRWLock; /* a simple lock to protect this entry */
|
rwlock_t QRWLock; /* a simple lock to protect this entry */
|
||||||
#endif
|
#endif
|
||||||
DBRef FirstInQueue, LastInQueue;
|
DBRef FirstInQueue, LastInQueue;
|
||||||
|
Int age; /* the number of catches when we created the queue */
|
||||||
|
struct idb_queue *next, *prev;
|
||||||
} db_queue;
|
} db_queue;
|
||||||
|
|
||||||
#define HashFieldMask ((CELL)0xffL)
|
#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_first_age, (void));
|
||||||
STATIC_PROTO(Int p_db_nb_to_ref, (void));
|
STATIC_PROTO(Int p_db_nb_to_ref, (void));
|
||||||
STATIC_PROTO(Int p_last_age, (void));
|
STATIC_PROTO(Int p_last_age, (void));
|
||||||
STATIC_PROTO(Term StealFirstFromDB, (Atom, Int));
|
|
||||||
|
|
||||||
#if OS_HANDLES_TR_OVERFLOW
|
#if OS_HANDLES_TR_OVERFLOW
|
||||||
#define check_trail(x)
|
#define check_trail(x)
|
||||||
|
@ -3451,24 +3452,6 @@ p_erase(void)
|
||||||
return (TRUE);
|
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) */
|
/* eraseall(+Key) */
|
||||||
static Int
|
static Int
|
||||||
p_eraseall(void)
|
p_eraseall(void)
|
||||||
|
@ -3799,7 +3782,7 @@ p_init_queue(void)
|
||||||
db_queue *dbq;
|
db_queue *dbq;
|
||||||
Term t;
|
Term t;
|
||||||
|
|
||||||
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NIL) {
|
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
|
||||||
if (!growheap(FALSE)) {
|
if (!growheap(FALSE)) {
|
||||||
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
|
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
|
||||||
return(FALSE);
|
return(FALSE);
|
||||||
|
@ -3808,12 +3791,17 @@ p_init_queue(void)
|
||||||
dbq->id = FunctorDBRef;
|
dbq->id = FunctorDBRef;
|
||||||
dbq->EntryTerm = MkAtomTerm(AbsAtom((AtomEntry *)dbq));
|
dbq->EntryTerm = MkAtomTerm(AbsAtom((AtomEntry *)dbq));
|
||||||
dbq->Flags = DBClMask;
|
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);
|
INIT_RWLOCK(dbq->QRWLock);
|
||||||
t = MkDBRefTerm((DBRef)dbq);
|
t = MkDBRefTerm((DBRef)dbq);
|
||||||
return(unify(ARG1, t));
|
return(unify(ARG1, t));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
static Int
|
static Int
|
||||||
p_enqueue(void)
|
p_enqueue(void)
|
||||||
{
|
{
|
||||||
|
@ -3887,6 +3875,12 @@ p_dequeue(void)
|
||||||
WRITE_LOCK(father_key->QRWLock);
|
WRITE_LOCK(father_key->QRWLock);
|
||||||
if ((cur_instance = father_key->FirstInQueue) == NIL) {
|
if ((cur_instance = father_key->FirstInQueue) == NIL) {
|
||||||
/* an empty queue automatically goes away */
|
/* 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);
|
WRITE_UNLOCK(father_key->QRWLock);
|
||||||
FreeDBSpace((char *) father_key);
|
FreeDBSpace((char *) father_key);
|
||||||
return(FALSE);
|
return(FALSE);
|
||||||
|
@ -3907,77 +3901,34 @@ p_dequeue(void)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
/*
|
static Int
|
||||||
This is a hack, to steal the first element of a key.
|
p_clean_queues(void)
|
||||||
|
|
||||||
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)
|
|
||||||
{
|
{
|
||||||
Prop AtProp;
|
Int myage = IntOfTerm(ARG1);
|
||||||
Register DBRef ref;
|
db_queue *ptr;
|
||||||
Term TermDB;
|
YAPEnterCriticalSection();
|
||||||
Term out;
|
ptr = DBQueues;
|
||||||
|
while (ptr) {
|
||||||
|
if (ptr->age >= myage) {
|
||||||
|
DBRef cur_instance;
|
||||||
|
db_queue *optr = ptr;
|
||||||
|
|
||||||
/* get the DB property */
|
while ((cur_instance = ptr->FirstInQueue)) {
|
||||||
if ((AtProp = FindDBProp(RepAtom(key), 0, arity)) == NIL) {
|
/* release space for cur_instance */
|
||||||
return(TermNil);
|
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 */
|
if (ptr)
|
||||||
#ifdef KEEP_OLD_ENTRIES_HANGING_ABOUT
|
ptr->prev = NULL;
|
||||||
ref = RepDBProp(AtProp)->FirstNEr;
|
DBQueues = ptr;
|
||||||
#else
|
YAPLeaveCriticalSection();
|
||||||
ref = RepDBProp(AtProp)->First;
|
return(TRUE);
|
||||||
#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));
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/* given a key, find the clock number for the first entry */
|
/* 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("$recordzp", 4, p_drcdzp, SafePredFlag|SyncPredFlag);
|
||||||
InitCPred("$recordaifnot", 3, p_rcdaifnot, SafePredFlag|SyncPredFlag);
|
InitCPred("$recordaifnot", 3, p_rcdaifnot, SafePredFlag|SyncPredFlag);
|
||||||
InitCPred("$recordzifnot", 3, p_rcdzifnot, 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("erase", 1, p_erase, SafePredFlag|SyncPredFlag);
|
||||||
InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
|
InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
|
||||||
InitCPred("instance", 2, p_instance, SyncPredFlag);
|
InitCPred("instance", 2, p_instance, SyncPredFlag);
|
||||||
|
@ -4199,6 +4149,7 @@ InitDBPreds(void)
|
||||||
InitCPred("$db_key", 2, p_db_key, 0);
|
InitCPred("$db_key", 2, p_db_key, 0);
|
||||||
InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
|
InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
|
||||||
InitCPred("$db_dequeue", 2, p_dequeue, 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_first_age", 2, p_first_age, TestPredFlag|SafePredFlag|SyncPredFlag);
|
||||||
InitCPred("$db_nb_to_ref", 3, p_db_nb_to_ref, TestPredFlag|SafePredFlag);
|
InitCPred("$db_nb_to_ref", 3, p_db_nb_to_ref, TestPredFlag|SafePredFlag);
|
||||||
InitCPred("$db_last_age", 2, p_last_age, TestPredFlag|SafePredFlag|SyncPredFlag);
|
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->no_of_modules = 1;
|
||||||
heap_regs->primitives_module = 0;
|
heap_regs->primitives_module = 0;
|
||||||
heap_regs->user_module = 1;
|
heap_regs->user_module = 1;
|
||||||
|
heap_regs->db_queues = NULL;
|
||||||
heap_regs->atom_abol = LookupAtom("$abol");
|
heap_regs->atom_abol = LookupAtom("$abol");
|
||||||
AtomAltNot = LookupAtom("not");
|
AtomAltNot = LookupAtom("not");
|
||||||
heap_regs->atom_append = LookupAtom ("append");
|
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 *)
|
heap_regs->dead_clauses = (Clause *)
|
||||||
AddrAdjust((ADDR)(heap_regs->dead_clauses));
|
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 =
|
heap_regs->retry_recorded_code =
|
||||||
PtoOpAdjust(heap_regs->retry_recorded_code);
|
PtoOpAdjust(heap_regs->retry_recorded_code);
|
||||||
heap_regs->retry_recorded_k_code =
|
heap_regs->retry_recorded_k_code =
|
||||||
|
|
|
@ -1099,7 +1099,7 @@ ProcessSIGINT(void)
|
||||||
if (in_readline) {
|
if (in_readline) {
|
||||||
/* readline must eat a newline, otherwise we will
|
/* readline must eat a newline, otherwise we will
|
||||||
have to wait before we do the Abort() */
|
have to wait before we do the Abort() */
|
||||||
} else {
|
} else if (!(PrologMode & CritMode)) {
|
||||||
#endif
|
#endif
|
||||||
#if defined(__MINGW32__) || _MSC_VER
|
#if defined(__MINGW32__) || _MSC_VER
|
||||||
/* we can't do a direct abort, so ask the system to do it for us */
|
/* 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 *
|
* File: Heap.h *
|
||||||
* mods: *
|
* mods: *
|
||||||
* comments: Heap Init Structure *
|
* 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 */
|
/* information that can be stored in Code Space */
|
||||||
|
@ -133,6 +133,7 @@ typedef struct various_codes {
|
||||||
#endif
|
#endif
|
||||||
int primitives_module;
|
int primitives_module;
|
||||||
int user_module;
|
int user_module;
|
||||||
|
struct idb_queue *db_queues;
|
||||||
Atom
|
Atom
|
||||||
atom_abol,
|
atom_abol,
|
||||||
atom_alarm,
|
atom_alarm,
|
||||||
|
@ -316,6 +317,7 @@ typedef struct various_codes {
|
||||||
#define ModuleName heap_regs->module_name
|
#define ModuleName heap_regs->module_name
|
||||||
#define PrimitivesModule heap_regs->primitives_module
|
#define PrimitivesModule heap_regs->primitives_module
|
||||||
#define UserModule heap_regs->user_module
|
#define UserModule heap_regs->user_module
|
||||||
|
#define DBQueues heap_regs->db_queues
|
||||||
#define NoOfModules heap_regs->no_of_modules
|
#define NoOfModules heap_regs->no_of_modules
|
||||||
#define AtomAbol heap_regs->atom_abol
|
#define AtomAbol heap_regs->atom_abol
|
||||||
#define AtomAlarm heap_regs->atom_alarm
|
#define AtomAlarm heap_regs->atom_alarm
|
||||||
|
|
|
@ -16,6 +16,7 @@
|
||||||
|
|
||||||
<h2>Yap-4.3.19:</h2>
|
<h2>Yap-4.3.19:</h2>
|
||||||
<ul>
|
<ul>
|
||||||
|
<li>FIXED: change catch and throw to use arrays.</li>
|
||||||
<li>CLEANUP: split TRAIL_REF.</li>
|
<li>CLEANUP: split TRAIL_REF.</li>
|
||||||
<li>FIXED: give correct type to FreeBlocks.</li>
|
<li>FIXED: give correct type to FreeBlocks.</li>
|
||||||
<li>FIXED: give correct type to alias list.</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_yap_flags'(10,0),
|
||||||
'$set_value'('$gc',on),
|
'$set_value'('$gc',on),
|
||||||
|
'$init_catch',
|
||||||
prompt(' ?- '),
|
prompt(' ?- '),
|
||||||
(
|
(
|
||||||
'$get_value'('$break',0)
|
'$get_value'('$break',0)
|
||||||
|
@ -61,13 +62,25 @@ true :- true. % otherwise, $$compile will ignore this clause.
|
||||||
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
|
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
|
||||||
),
|
),
|
||||||
'$clean_catch_and_throw',
|
'$clean_catch_and_throw',
|
||||||
|
'$db_clean_queues'(0),
|
||||||
'$startup_reconsult',
|
'$startup_reconsult',
|
||||||
'$startup_goals'
|
'$startup_goals'
|
||||||
;
|
;
|
||||||
true
|
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.
|
% encapsulate $cut_by because of co-routining.
|
||||||
%
|
%
|
||||||
'$cut_by'(X) :- '$$cut_by'(X).
|
'$cut_by'(X) :- '$$cut_by'(X).
|
||||||
|
@ -1122,9 +1135,9 @@ catch(G,C,A) :-
|
||||||
'$catch'(G,C,A).
|
'$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,
|
I1 is I+1,
|
||||||
'$set_value'('$catch_counter', I1),
|
'$set_value'('$catch', I1),
|
||||||
'$current_module'(M),
|
'$current_module'(M),
|
||||||
'$catch'(G,C,A,I,M).
|
'$catch'(G,C,A,I,M).
|
||||||
|
|
||||||
|
@ -1134,23 +1147,35 @@ catch(G,C,A) :-
|
||||||
'$catch_call'(X,G,I).
|
'$catch_call'(X,G,I).
|
||||||
% someone sent us a throw.
|
% someone sent us a throw.
|
||||||
'$catch'(_,C,A,_,M) :-
|
'$catch'(_,C,A,_,M) :-
|
||||||
('$recorded'('$throw',X,R)->true),
|
array_element('$catch_queue', 1, X), X \= '$',
|
||||||
erase(R),
|
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)).
|
( C=X -> '$current_module'(_,M), '$execute'(A) ; throw(X)).
|
||||||
% normal exit: make sure we only erase what we should erase!
|
% normal exit: make sure we only erase what we should erase!
|
||||||
'$catch'(_,_,_,I,_) :-
|
'$catch'(_,_,_,I,_) :-
|
||||||
'$recorded'('$catch','$catch'(_,J),R), J >= I,
|
array_element('$catch_queue', 0, OldCatch),
|
||||||
erase(R), fail.
|
'$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) :-
|
'$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),
|
'$execute'(G),
|
||||||
( % on exit remove the catch
|
( % on exit remove the catch
|
||||||
('$recorded'('$catch','$catch'(X,I),R)->true),
|
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||||
erase(R)
|
update_array('$catch_queue', 0, Catch)
|
||||||
;
|
;
|
||||||
% on backtracking reinstate the catch before backtracking to G
|
% 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
|
fail
|
||||||
).
|
).
|
||||||
|
|
||||||
|
@ -1161,9 +1186,9 @@ catch(G,C,A) :-
|
||||||
% also avoids module preprocessing and goal_expansion
|
% also avoids module preprocessing and goal_expansion
|
||||||
%
|
%
|
||||||
'$system_catch'(G,C,A) :-
|
'$system_catch'(G,C,A) :-
|
||||||
'$get_value'('$catch_counter', I),
|
'$get_value'('$catch', I),
|
||||||
I1 is I+1,
|
I1 is I+1,
|
||||||
'$set_value'('$catch_counter', I1),
|
'$set_value'('$catch', I1),
|
||||||
'$current_module'(M),
|
'$current_module'(M),
|
||||||
'$system_catch'(G,C,A,I,M).
|
'$system_catch'(G,C,A,I,M).
|
||||||
|
|
||||||
|
@ -1173,8 +1198,11 @@ catch(G,C,A) :-
|
||||||
'$system_catch_call'(X,G,I).
|
'$system_catch_call'(X,G,I).
|
||||||
% someone sent us a throw.
|
% someone sent us a throw.
|
||||||
'$system_catch'(_,C,A,_,M0) :-
|
'$system_catch'(_,C,A,_,M0) :-
|
||||||
('$recorded'('$throw',X,R)->true),
|
array_element('$catch_queue', 1, X), X \= '$',
|
||||||
erase(R),
|
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 ->
|
( C=X ->
|
||||||
'$current_module'(_,M0),
|
'$current_module'(_,M0),
|
||||||
(A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A))
|
(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!
|
% normal exit: make sure we only erase what we should erase!
|
||||||
'$system_catch'(_,_,_,I,_) :-
|
'$system_catch'(_,_,_,I,_) :-
|
||||||
'$recorded'('$catch','$catch'(_,J),R), J >= I,
|
array_element('$catch_queue', 0, OldCatch),
|
||||||
erase(R), fail.
|
'$erase_catch_elements'(OldCatch, I, Catch),
|
||||||
|
update_array('$catch_queue', 0, Catch),
|
||||||
|
fail.
|
||||||
|
|
||||||
'$system_catch_call'(X,G,I) :-
|
'$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),
|
'$execute0'(G),
|
||||||
( % on exit remove the catch
|
( % on exit remove the catch
|
||||||
('$recorded'('$catch','$catch'(X,I),R)->true),
|
array_element('$catch_queue', 0, catch(X,I,Catch)),
|
||||||
erase(R)
|
update_array('$catch_queue', 0, Catch)
|
||||||
;
|
;
|
||||||
% on backtracking reinstate the catch before backtracking to G
|
% 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
|
fail
|
||||||
).
|
).
|
||||||
|
|
||||||
throw(A) :-
|
throw(A) :-
|
||||||
% fetch the point to jump to
|
% fetch the point to jump to
|
||||||
'$recorded'('$catch','$catch'(X,_),R), !,
|
array_element('$catch_queue', 0, catch(X,_,_)), !,
|
||||||
erase(R),
|
|
||||||
% now explain why we are jumping.
|
% now explain why we are jumping.
|
||||||
'$recordz'('$throw',A,_),
|
update_array('$catch_queue', 1, A),
|
||||||
'$$cut_by'(X),
|
'$$cut_by'(X),
|
||||||
fail.
|
fail.
|
||||||
throw(G) :-
|
throw(G) :-
|
||||||
|
@ -1218,7 +1249,7 @@ throw(G) :-
|
||||||
throw(error(type_error(list,S),T)).
|
throw(error(type_error(list,S),T)).
|
||||||
|
|
||||||
'$clean_catch_and_throw' :-
|
'$clean_catch_and_throw' :-
|
||||||
'$set_value'('$catch_counter', 0),
|
'$set_value'('$catch', 0),
|
||||||
fail.
|
fail.
|
||||||
'$clean_catch_and_throw' :-
|
'$clean_catch_and_throw' :-
|
||||||
'$recorded'('$catch',_,R),
|
'$recorded'('$catch',_,R),
|
||||||
|
|
Reference in New Issue