diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

new module system. BEWARE! BEWARE! BEWARE!

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@177 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2001-11-15 00:01:43 +00:00
parent a628251951
commit b289d9ac9c
57 changed files with 1859 additions and 2163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
C/absmi.c
View File

@ -1789,7 +1789,7 @@ absmi(int inp)
NoStackComitY:
/* find something to fool S */
if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) {
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2));
SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0));
PREG = NEXTOP(PREG,x);
XREGS[0] = XREG(PREG->u.y.y);
goto creep_either;
@ -1801,7 +1801,7 @@ absmi(int inp)
NoStackComitX:
/* find something to fool S */
if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) {
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2));
SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0));
PREG = NEXTOP(PREG,x);
#if USE_THREADED_CODE
if (PREG->opc == (OPCODE)OpAddress[_fcall])
@ -1827,7 +1827,7 @@ absmi(int inp)
/* don't forget I cannot creep at ; */
NoStackEither:
/* find something to fool S */
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,1));
SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,1),0));
#ifdef YAPOR
/* abort_optyap("NoStackCall in function absmi"); */
if (HeapTop > GlobalBase - MinHeapGap)
@ -5948,7 +5948,7 @@ absmi(int inp)
at = FullLookupAtom("$undefp");
{
Prop p = GetPredProp (at, 1);
Prop p = GetPredPropByFunc(MkFunctor(at, 1),0);
if (p == NIL) {
CFREG = CalculateStackGap();
FAIL();
@ -9557,7 +9557,7 @@ absmi(int inp)
Op(p_dif, e);
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("\\="),2)),XREGS+1);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("\\="),2),0)),XREGS+1);
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
BEGD(d1);
@ -9651,7 +9651,7 @@ absmi(int inp)
Op(p_eq, e);
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("=="),2)),XREGS+1);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("=="),2),0)),XREGS+1);
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
BEGD(d1);
@ -9775,7 +9775,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.xxx.x1);
H[1] = XREG(PREG->u.xxx.x2);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -9864,7 +9864,7 @@ absmi(int inp)
H[0] = t;
H[1] = XREG(PREG->u.xxc.xi);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H);
H = Ho;
}
#endif /* LOW_LEVEL_TRACE */
@ -9935,7 +9935,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.yxx.x1);
H[1] = XREG(PREG->u.yxx.x2);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10038,7 +10038,7 @@ absmi(int inp)
H[0] = t;
H[1] = XREG(PREG->u.yxc.xi);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H);
H = Ho;
}
#endif /* LOW_LEVEL_TRACE */
@ -10125,7 +10125,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.xxx.x1);
H[2] = XREG(PREG->u.xxx.x2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
/* We have to build the structure */
@ -10230,7 +10230,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.xcx.c);
H[2] = XREG(PREG->u.xcx.xi);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10325,7 +10325,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.xxc.xi);
H[2] = ti;
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
H = hi;
}
#endif /* LOW_LEVEL_TRACE */
@ -10410,7 +10410,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.yxx.x1);
H[2] = XREG(PREG->u.yxx.x2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
/* We have to build the structure */
@ -10533,7 +10533,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.ycx.c);
H[2] = XREG(PREG->u.ycx.xi);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
/* We have to build the structure */
@ -10650,7 +10650,7 @@ absmi(int inp)
RESET_VARIABLE(H);
H[1] = XREG(PREG->u.yxc.xi);
H[2] = ti;
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
H = hi;
}
#endif /* LOW_LEVEL_TRACE */
@ -10758,7 +10758,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.xxx.x);
RESET_VARIABLE(H+1);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10804,7 +10804,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.xyx.x);
RESET_VARIABLE(H+1);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10853,7 +10853,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.yxx.x2);
RESET_VARIABLE(H+1);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10902,7 +10902,7 @@ absmi(int inp)
H[0] = XREG(PREG->u.yyx.x);
RESET_VARIABLE(H+1);
RESET_VARIABLE(H+2);
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H);
}
#endif /* LOW_LEVEL_TRACE */
BEGD(d0);
@ -10951,7 +10951,7 @@ absmi(int inp)
Op(p_functor, e);
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),XREGS+1);
low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),XREGS+1);
#endif /* LOW_LEVEL_TRACE */
restart_functor:
BEGD(d0);
@ -11135,24 +11135,33 @@ absmi(int inp)
BOp(p_execute, sla);
{
PredEntry *pen;
int mod = IntOfTerm(ARG2);
CACHE_Y_AS_ENV(Y);
BEGD(d0);
d0 = ARG1;
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
}
deref_head(d0, execute_unk);
execute_nvar:
if (IsApplTerm(d0)) {
Functor f = FunctorOfTerm(d0);
if (IsExtensionFunctor(f)) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_nvar;
}
pen = RepPredProp(PredPropByFunc(f, ARG2));
pen = RepPredProp(PredPropByFunc(f, mod));
if (pen->PredFlags & MetaPredFlag) {
d0 = ExecuteCallMetaCall();
if (f == FunctorModule) {
Term tmod = LookupModule(ArgOfTerm(1,d0));
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
d0 = ArgOfTerm(2,d0);
goto execute_nvar;
}
}
d0 = ExecuteCallMetaCall(mod);
goto execute_nvar;
}
BEGP(pt1);
@ -11174,9 +11183,9 @@ absmi(int inp)
ENDP(pt1);
CACHE_A1();
} else if (IsAtomTerm(d0)) {
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), ARG2));
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod));
} else {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_nvar;
}
@ -11230,7 +11239,7 @@ absmi(int inp)
BEGP(pt1);
deref_body(d0, pt1, execute_unk, execute_nvar);
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_nvar;
ENDP(pt1);
ENDD(d0);
@ -11248,24 +11257,34 @@ absmi(int inp)
BOp(p_execute_within, sla);
{
PredEntry *pen;
int mod = CurrentModule;
CACHE_Y_AS_ENV(Y);
BEGD(d0);
d0 = ARG1;
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
}
deref_head(d0, execute_within_unk);
execute_within_nvar:
if (IsApplTerm(d0)) {
Functor f = FunctorOfTerm(d0);
if (IsExtensionFunctor(f)) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_within_nvar;
}
pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr));
pen = RepPredProp(PredPropByFunc(f, mod));
if (pen->PredFlags & MetaPredFlag) {
d0 = ExecuteCallMetaCall();
if (f == FunctorModule) {
Term tmod;
tmod = ArgOfTerm(1,d0);
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
d0 = ArgOfTerm(2,d0);
goto execute_within_nvar;
}
}
d0 = ExecuteCallMetaCall(mod);
goto execute_within_nvar;
}
BEGP(pt1);
@ -11310,9 +11329,9 @@ absmi(int inp)
PREG = NEXTOP(PREG, sla);
JMPNext();
}else
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), *CurrentModulePtr));
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod));
} else {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_within_nvar;
}
@ -11366,7 +11385,7 @@ absmi(int inp)
BEGP(pt1);
deref_body(d0, pt1, execute_within_unk, execute_within_nvar);
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto execute_within_nvar;
ENDP(pt1);
ENDD(d0);
@ -11383,24 +11402,33 @@ absmi(int inp)
BOp(p_last_execute_within, sla);
{
PredEntry *pen;
int mod = CurrentModule;
CACHE_Y_AS_ENV(Y);
BEGD(d0);
d0 = ARG1;
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
}
deref_head(d0, last_execute_within_unk);
last_execute_within_nvar:
if (IsApplTerm(d0)) {
Functor f = FunctorOfTerm(d0);
if (IsExtensionFunctor(f)) {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto last_execute_within_nvar;
}
pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr));
pen = RepPredProp(PredPropByFunc(f, mod));
if (pen->PredFlags & MetaPredFlag) {
d0 = ExecuteCallMetaCall();
if (f == FunctorModule) {
Term tmod = ArgOfTerm(1,d0);
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
d0 = ArgOfTerm(2,d0);
goto last_execute_within_nvar;
}
}
d0 = ExecuteCallMetaCall(mod);
goto last_execute_within_nvar;
}
BEGP(pt1);
@ -11445,9 +11473,9 @@ absmi(int inp)
PREG = NEXTOP(PREG, sla);
JMPNext();
}else
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), *CurrentModulePtr));
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod));
} else {
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto last_execute_within_nvar;
}
@ -11489,7 +11517,7 @@ absmi(int inp)
BEGP(pt1);
deref_body(d0, pt1, last_execute_within_unk, last_execute_within_nvar);
d0 = ExecuteCallMetaCall();
d0 = ExecuteCallMetaCall(mod);
goto last_execute_within_nvar;
ENDP(pt1);
ENDD(d0);

108
C/adtdefs.c
View File

@ -22,8 +22,8 @@ static char SccsId[] = "%W% %G%";
#define ADTDEFS_C
#include "Yap.h"
Prop STD_PROTO(PredPropByFunc,(Functor, Term));
Prop STD_PROTO(PredPropByAtom,(Atom, Term));
Prop STD_PROTO(PredPropByFunc,(Functor, SMALLUNSGN));
Prop STD_PROTO(PredPropByAtom,(Atom, SMALLUNSGN));
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
@ -263,22 +263,7 @@ GetAProp(Atom a, PropFlags kind)
}
inline static Prop
UnlockedFunctorGetPredProp(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
FunctorEntry *fe = (FunctorEntry *)f;
PredEntry *p;
p = RepPredProp(p0 = fe->PropsOfFE);
while (p0 && (/* p->KindOfPE != PEProp || only preds in here */
(p->ModuleOfPred != cur_mod && p->ModuleOfPred)))
p = RepPredProp(p0 = p->NextOfPE);
return (p0);
}
inline static Prop
GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod)
GetPredPropByAtomHavingLock(AtomEntry* ae, int cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
@ -296,7 +281,7 @@ GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod)
}
Prop
GetPredPropByAtom(Atom at, Term cur_mod)
GetPredPropByAtom(Atom at, int cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
@ -309,39 +294,39 @@ GetPredPropByAtom(Atom at, Term cur_mod)
}
Prop
GetPredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; */
static inline Prop
GetPredPropByFuncHavingLock(Functor f, SMALLUNSGN cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
Functor f;
FunctorEntry *fe = (FunctorEntry *)f;
if (arity == 0)
return(GetPredPropByAtom(ap, *CurrentModulePtr));
WRITE_LOCK(ae->ARWLock);
f = InlinedUnlockedMkFunctor(ae, arity);
WRITE_UNLOCK(ae->ARWLock);
READ_LOCK(f->FRWLock);
p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr);
READ_UNLOCK(f->FRWLock);
return (p0);
p0 = fe->PropsOfFE;
while (p0) {
PredEntry *p = RepPredProp(p0);
if (/* p->KindOfPE != 0 || only props */
(p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) {
return (p0);
}
p0 = p->NextOfPE;
}
return(NIL);
}
Prop
GetPredPropByFunc(Functor f, Term t)
GetPredPropByFunc(Functor f, int cur_mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
READ_LOCK(f->FRWLock);
p0 = UnlockedFunctorGetPredProp(f, t);
p0 = GetPredPropByFuncHavingLock(f, cur_mod);
READ_UNLOCK(f->FRWLock);
return (p0);
}
Prop
GetPredPropHavingLock(Atom ap, unsigned int arity)
GetPredPropHavingLock(Atom ap, unsigned int arity, SMALLUNSGN mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
@ -349,11 +334,11 @@ GetPredPropHavingLock(Atom ap, unsigned int arity)
Functor f;
if (arity == 0) {
GetPredPropByAtomHavingLock(ae, *CurrentModulePtr);
GetPredPropByAtomHavingLock(ae, mod);
}
f = InlinedUnlockedMkFunctor(ae, arity);
READ_LOCK(f->FRWLock);
p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr);
p0 = GetPredPropByFuncHavingLock(f, mod);
READ_UNLOCK(f->FRWLock);
return (p0);
}
@ -388,11 +373,12 @@ GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
}
Prop
NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
NewPredPropByFunctor(FunctorEntry *fe, SMALLUNSGN cur_mod)
{
Prop p0;
PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p));
Int m = IntOfTerm(cur_mod);
/* printf("entering %s:%s/%d\n", RepAtom(AtomOfTerm(ModuleName[cur_mod]))->StrOfAE, RepAtom(fe->NameOfFE)->StrOfAE, fe->ArityOfFE); */
INIT_RWLOCK(p->PRWLock);
p->KindOfPE = PEProp;
@ -403,12 +389,9 @@ NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
p->OwnerFile = AtomNil;
p->OpcodeOfPred = UNDEF_OPCODE;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
if (m == 0)
p->ModuleOfPred = 0;
else
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[m];
ModulePred[m] = p;
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[cur_mod];
ModulePred[cur_mod] = p;
INIT_LOCK(p->StatisticsForPred.lock);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
@ -425,11 +408,12 @@ NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
}
Prop
NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
NewPredPropByAtom(AtomEntry *ae, SMALLUNSGN cur_mod)
{
Prop p0;
PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p));
int m = IntOfTerm(cur_mod);
/* Printf("entering %s:%s/0\n", RepAtom(AtomOfTerm(ModuleName[cur_mod]))->StrOfAE, ae->StrOfAE); */
INIT_RWLOCK(p->PRWLock);
p->KindOfPE = PEProp;
@ -440,12 +424,9 @@ NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
p->OwnerFile = AtomNil;
p->OpcodeOfPred = UNDEF_OPCODE;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
if (!m)
p->ModuleOfPred = 0;
else
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[m];
ModulePred[m] = p;
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[cur_mod];
ModulePred[cur_mod] = p;
INIT_LOCK(p->StatisticsForPred.lock);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
@ -461,25 +442,6 @@ NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
return (p0);
}
Prop
PredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae;
Functor f;
if (arity == 0) {
return(PredPropByAtom(ap, *CurrentModulePtr));
}
ae = RepAtom(ap);
WRITE_LOCK(ae->ARWLock);
f = InlinedUnlockedMkFunctor(ae, arity);
p0 = PredPropByFunc(f, *CurrentModulePtr);
WRITE_UNLOCK(ae->ARWLock);
return(p0);
}
Term
GetValue(Atom a)
{

4
C/amasm.c
View File

@ -858,7 +858,7 @@ a_empty_call(void)
code_p->opc = emit_op(_fcall);
}
if (pass_no) {
PredEntry *pe = RepPredProp(GetPredProp(AtomTrue,0));
PredEntry *pe = RepPredProp(GetPredPropByAtom(AtomTrue,0));
code_p->u.sla.s = emit_count(-Signed(RealEnvSize) - CELLSIZE *
cpc->rnd2);
code_p->u.sla.l = emit_a((CELL)&(pe->StateOfPred));
@ -1184,7 +1184,7 @@ a_either(op_numbers opcode, CELL opr, CELL lab)
#endif /* YAPOR */
{
if (pass_no) {
Prop fe = GetPredProp(AtomTrue,0);
Prop fe = GetPredPropByAtom(AtomTrue,0);
code_p->opc = emit_op(opcode);
code_p->u.sla.s = emit_count(opr);
code_p->u.sla.l = emit_a(lab);

68
C/bb.c
View File

@ -26,7 +26,7 @@ static char SccsId[] = "%W% %G%";
#endif
static BBProp
PutBBProp(AtomEntry *ae) /* get BBentry for at; */
PutBBProp(AtomEntry *ae, SMALLUNSGN mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
@ -34,7 +34,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */
WRITE_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
@ -46,7 +46,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */
}
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsBBProp(p);
p->ModuleOfBB = CurrentModule;
p->ModuleOfBB = mod;
p->Element = NULL;
p->KeyOfBB = AbsAtom(ae);
p->KindOfPE = BBProperty;
@ -57,7 +57,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */
}
static BBProp
PutIntBBProp(Int key) /* get BBentry for at; */
PutIntBBProp(Int key, SMALLUNSGN mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
@ -82,7 +82,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != CurrentModule))) {
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
@ -93,7 +93,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
p->ModuleOfBB = CurrentModule;
p->ModuleOfBB = mod;
p->Element = NULL;
p->KeyOfBB = (Atom)key;
p->KindOfPE = BBProperty;
@ -105,7 +105,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */
}
static BBProp
GetBBProp(AtomEntry *ae) /* get BBentry for at; */
GetBBProp(AtomEntry *ae, SMALLUNSGN mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
@ -113,7 +113,7 @@ GetBBProp(AtomEntry *ae) /* get BBentry for at; */
READ_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
READ_UNLOCK(ae->ARWLock);
@ -124,7 +124,7 @@ GetBBProp(AtomEntry *ae) /* get BBentry for at; */
}
static BBProp
GetIntBBProp(Int key) /* get BBentry for at; */
GetIntBBProp(Int key, SMALLUNSGN mod) /* get BBentry for at; */
{
Prop p0;
BBProp p;
@ -137,7 +137,7 @@ GetIntBBProp(Int key) /* get BBentry for at; */
p = RepBBProp(p0);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
key != (Int)(p->KeyOfBB) ||
(p->ModuleOfBB != CurrentModule))) {
(p->ModuleOfBB != mod))) {
p = RepBBProp(p0 = p->NextOfPE);
}
if (p0 == NIL) {
@ -187,70 +187,62 @@ resize_bb_int_keys(UInt new_size) {
}
static BBProp
AddBBProp(Term t1, char *msg)
AddBBProp(Term t1, char *msg, SMALLUNSGN mod)
{
SMALLUNSGN old_module = CurrentModule;
BBProp p;
restart:
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
} if (IsAtomTerm(t1)) {
p = PutBBProp(RepAtom(AtomOfTerm(t1)));
p = PutBBProp(RepAtom(AtomOfTerm(t1)), mod);
} else if (IsIntegerTerm(t1)) {
p = PutIntBBProp(IntegerOfTerm(t1));
p = PutIntBBProp(IntegerOfTerm(t1), mod);
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
Term tmod = ArgOfTerm(1, t1);
if (!IsVarTerm(tmod) ) {
t1 = ArgOfTerm(2, t1);
p = AddBBProp(t1, msg);
mod = LookupModule(tmod);
goto restart;
} else {
Error(INSTANTIATION_ERROR, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
*CurrentModulePtr = MkIntTerm(old_module);
return(p);
}
static BBProp
FetchBBProp(Term t1, char *msg)
FetchBBProp(Term t1, char *msg, SMALLUNSGN mod)
{
SMALLUNSGN old_module = CurrentModule;
BBProp p;
restart:
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
} if (IsAtomTerm(t1)) {
p = GetBBProp(RepAtom(AtomOfTerm(t1)));
p = GetBBProp(RepAtom(AtomOfTerm(t1)), mod);
} else if (IsIntegerTerm(t1)) {
p = GetIntBBProp(IntegerOfTerm(t1));
p = GetIntBBProp(IntegerOfTerm(t1), mod);
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
Term tmod = ArgOfTerm(1, t1);
if (!IsVarTerm(tmod) ) {
mod = LookupModule(tmod);
t1 = ArgOfTerm(2, t1);
p = FetchBBProp(t1, msg);
goto restart;
} else {
Error(INSTANTIATION_ERROR, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
*CurrentModulePtr = MkIntTerm(old_module);
return(p);
}
@ -258,7 +250,7 @@ static Int
p_bb_put(void)
{
Term t1 = Deref(ARG1);
BBProp p = AddBBProp(t1, "bb_put/2");
BBProp p = AddBBProp(t1, "bb_put/2", CurrentModule);
if (p == NULL)
return(FALSE);
WRITE_LOCK(p->BBRWLock);
@ -274,7 +266,7 @@ static Int
p_bb_get(void)
{
Term t1 = Deref(ARG1);
BBProp p = FetchBBProp(t1, "bb_get/2");
BBProp p = FetchBBProp(t1, "bb_get/2", CurrentModule);
Term out;
if (p == NULL || p->Element == NULL)
return(FALSE);
@ -291,7 +283,7 @@ p_bb_delete(void)
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_delete/2");
p = FetchBBProp(t1, "bb_delete/2", CurrentModule);
if (p == NULL || p->Element == NULL)
return(FALSE);
out = FetchTermFromDB(p->Element,3);
@ -309,7 +301,7 @@ p_bb_update(void)
BBProp p;
Term out;
p = FetchBBProp(t1, "bb_update/3");
p = FetchBBProp(t1, "bb_update/3", CurrentModule);
if (p == NULL || p->Element == NULL)
return(FALSE);
WRITE_LOCK(p->BBRWLock);

10
C/c_interface.c
View File

@ -376,7 +376,7 @@ YapCallProlog(Term t)
Int out;
BACKUP_MACHINE_REGS();
out = execute_goal(t,0);
out = execute_goal(t, 0, CurrentModule);
RECOVER_MACHINE_REGS();
return(out);
@ -594,14 +594,16 @@ YapCompileClause(Term t)
{
char *ErrorMessage;
CODEADDR codeaddr;
int mod = CurrentModule;
BACKUP_MACHINE_REGS();
ErrorMessage = NULL;
ARG1 = t;
codeaddr = cclause (t,0);
codeaddr = cclause (t,0, mod);
if (codeaddr != NULL) {
t = Deref(ARG1); /* just in case there was an heap overflow */
addclause (t, codeaddr, TRUE);
addclause (t, codeaddr, TRUE, mod);
}
RECOVER_MACHINE_REGS();
@ -677,7 +679,7 @@ YapInit(yap_init_args *yap_init)
InitYaamRegs();
#endif
/* slaves, waiting for work */
*CurrentModulePtr = MkIntTerm(1);
CurrentModule = 1;
P = GETWORK_FIRST_TIME;
exec_absmi(FALSE);
abort_optyap("abstract machine unexpected exit");

521
C/cdmgr.c
View File

@ -52,8 +52,6 @@ STATIC_PROTO(void do_toggle_static_predicates_in_use, (int));
STATIC_PROTO(void recover_log_upd_clause, (Clause *));
STATIC_PROTO(PredEntry *NextPred, (PredEntry *,AtomEntry *));
STATIC_PROTO(Int p_number_of_clauses, (void));
STATIC_PROTO(Int p_find_dynamic, (void));
STATIC_PROTO(Int p_next_dynamic, (void));
STATIC_PROTO(Int p_compile, (void));
STATIC_PROTO(Int p_compile_dynamic, (void));
STATIC_PROTO(Int p_purge_clauses, (void));
@ -66,7 +64,6 @@ STATIC_PROTO(Int p_undefined, (void));
STATIC_PROTO(Int p_in_use, (void));
STATIC_PROTO(Int p_new_multifile, (void));
STATIC_PROTO(Int p_is_multifile, (void));
STATIC_PROTO(Int p_is_logical_updatable, (void));
STATIC_PROTO(Int p_optimizer_on, (void));
STATIC_PROTO(Int p_optimizer_off, (void));
STATIC_PROTO(Int p_in_this_f_before, (void));
@ -79,7 +76,6 @@ STATIC_PROTO(Int p_is_profiled, (void));
STATIC_PROTO(Int p_profile_info, (void));
STATIC_PROTO(Int p_profile_reset, (void));
STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void));
STATIC_PROTO(Int p_search_for_static_predicate_in_use, (void));
#define PredArity(p) (p->ArityOfPE)
#define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G)
@ -787,34 +783,35 @@ addcl_permission_error(AtomEntry *ap, Int Arity)
void
addclause(Term t, CODEADDR cp, int mode)
addclause(Term t, CODEADDR cp, int mode, int mod)
/*
* mode 0 assertz 1 consult 2 asserta
*/
{
AtomEntry *ap;
Int Arity;
PredEntry *p;
int spy_flag = FALSE;
SMALLUNSGN mod = CurrentModule;
Atom at;
UInt Arity;
if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
t = ArgOfTerm(1, t);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
p = RepPredProp(PredPropByAtom(at, mod));
Arity = 0;
ap = RepAtom(AtomOfTerm(t));
} else {
Functor f = FunctorOfTerm(t);
ap = RepAtom(NameOfFunctor(f));
Arity = ArityOfFunctor(f);
at = NameOfFunctor(f);
p = RepPredProp(PredPropByFunc(f, mod));
}
p = RepPredProp(PredProp(AbsAtom(ap), Arity));
PutValue(AtomAbol, TermNil);
WRITE_LOCK(p->PRWLock);
/* we are redefining a prolog module predicate */
if (mod != 0 && p->ModuleOfPred == 0) {
addcl_permission_error(ap, Arity);
WRITE_UNLOCK(p->PRWLock);
addcl_permission_error(RepAtom(at), Arity);
return;
}
/* The only problem we have now is when we need to throw away
@ -824,7 +821,7 @@ addclause(Term t, CODEADDR cp, int mode)
if (!RemoveIndexation(p)) {
/* should never happen */
WRITE_UNLOCK(p->PRWLock);
addcl_permission_error(ap,Arity);
addcl_permission_error(RepAtom(at),Arity);
return;
}
}
@ -877,12 +874,13 @@ addclause(Term t, CODEADDR cp, int mode)
static Int
p_in_this_f_before(void)
{ /* '$in_this_file_before'(N,A) */
{ /* '$in_this_file_before'(N,A,M) */
unsigned int arity;
Atom at;
Term t;
register consult_obj *fp;
Prop p0;
SMALLUNSGN mod;
if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t))
return (FALSE);
@ -892,7 +890,14 @@ p_in_this_f_before(void)
return (FALSE);
else
arity = IntOfTerm(t);
p0 = PredProp(at, arity);
if (IsVarTerm(t = Deref(ARG3)) && !IsAtomTerm(t))
return (FALSE);
else
mod = LookupModule(t);
if (arity)
p0 = PredPropByFunc(MkFunctor(at, arity),CurrentModule);
else
p0 = PredPropByAtom(at, CurrentModule);
if (ConsultSp == ConsultBase || (fp = ConsultSp)->p == p0)
return (FALSE);
else
@ -908,12 +913,14 @@ p_in_this_f_before(void)
static Int
p_first_cl_in_f(void)
{ /* '$first_cl_in_file'(+N,+Ar) */
{ /* '$first_cl_in_file'(+N,+Ar,+Mod) */
unsigned int arity;
Atom at;
Term t;
register consult_obj *fp;
Prop p0;
SMALLUNSGN mod;
if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t))
return (FALSE);
@ -923,7 +930,14 @@ p_first_cl_in_f(void)
return (FALSE);
else
arity = IntOfTerm(t);
p0 = PredProp(at, arity);
if (IsVarTerm(t = Deref(ARG3)) && !IsAtomTerm(t))
return (FALSE);
else
mod = LookupModule(t);
if (arity)
p0 = PredPropByFunc(MkFunctor(at, arity),mod);
else
p0 = PredPropByAtom(at, mod);
for (fp = ConsultSp; fp < ConsultBase; ++fp)
if (fp->p == p0)
break;
@ -948,7 +962,10 @@ p_mk_cl_not_first(void)
return (FALSE);
else
arity = IntOfTerm(t);
p0 = PredProp(at, arity);
if (arity)
p0 = PredPropByFunc(MkFunctor(at, arity),CurrentModule);
else
p0 = PredPropByAtom(at, CurrentModule);
--ConsultSp;
ConsultSp->p = p0;
return (TRUE);
@ -991,18 +1008,23 @@ where_new_clause(pred_prop, mode)
static Int
p_compile(void)
{ /* '$compile'(+C,+Flags) */
{ /* '$compile'(+C,+Flags, Mod) */
Term t = Deref(ARG1);
Term t1 = Deref(ARG2);
Term t3 = Deref(ARG3);
CODEADDR codeadr;
Int mod;
if (IsVarTerm(t1) || !IsIntTerm(t1))
return (FALSE);
codeadr = cclause(t, 2); /* vsc: give the number of arguments
if (IsVarTerm(t3) || !IsAtomTerm(t3))
return (FALSE);
mod = LookupModule(t3);
codeadr = cclause(t, 2, mod); /* vsc: give the number of arguments
to cclause in case there is overflow */
t = Deref(ARG1); /* just in case there was an heap overflow */
if (!ErrorMessage)
addclause(t, codeadr, (int) (IntOfTerm(t1) & 3));
addclause(t, codeadr, (int) (IntOfTerm(t1) & 3), mod);
if (ErrorMessage) {
if (IntOfTerm(t1) & 4) {
Error(Error_TYPE, Error_Term,
@ -1016,25 +1038,30 @@ p_compile(void)
static Int
p_compile_dynamic(void)
{ /* '$compile_dynamic'(+C,+Flags,-Ref) */
{ /* '$compile_dynamic'(+C,+Flags,Mod,-Ref) */
Term t = Deref(ARG1);
Term t1 = Deref(ARG2);
Term t3 = Deref(ARG3);
Clause *cl;
CODEADDR code_adr;
int old_optimize;
Int mod;
if (IsVarTerm(t1) || !IsIntTerm(t1))
return (FALSE);
if (IsVarTerm(t3) || !IsAtomTerm(t3))
return (FALSE);
old_optimize = optimizer_on;
optimizer_on = FALSE;
code_adr = cclause(t, 3); /* vsc: give the number of arguments to
mod = LookupModule(t3);
code_adr = cclause(t, 3, mod); /* vsc: give the number of arguments to
cclause() in case there is a overflow */
t = Deref(ARG1); /* just in case there was an heap overflow */
if (!ErrorMessage) {
optimizer_on = old_optimize;
cl = ClauseCodeToClause(code_adr);
addclause(t, code_adr, (int) (IntOfTerm(t1) & 3));
addclause(t, code_adr, (int) (IntOfTerm(t1) & 3), mod);
}
if (ErrorMessage) {
if (IntOfTerm(t1) & 4) {
@ -1047,7 +1074,7 @@ p_compile_dynamic(void)
if (!(cl->ClFlags & LogUpdMask))
cl->ClFlags = DynamicMask;
t = MkIntegerTerm((Int)code_adr);
return(unify(ARG3, t));
return(unify(ARG4, t));
}
@ -1145,17 +1172,23 @@ p_purge_clauses(void)
{ /* '$purge_clauses'(+Func) */
PredEntry *pred;
Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
CODEADDR q, q1;
int mod;
PutValue(AtomAbol, MkAtomTerm(AtomNil));
if (IsVarTerm(t))
return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return (FALSE);
}
mod = LookupModule(t2);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0));
pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
pred = RepPredProp(PredPropByFunc(fun, mod));
} else
return (FALSE);
WRITE_LOCK(pred->PRWLock);
@ -1197,24 +1230,30 @@ p_purge_clauses(void)
static Int
p_setspy(void)
{ /* '$set_spy'(+Fun) */
{ /* '$set_spy'(+Fun,+M) */
Atom at;
PredEntry *pred;
CELL fg;
Term t;
Term t2;
SMALLUNSGN mod;
at = FullLookupAtom("$spy");
pred = RepPredProp(PredProp(at, 1));
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
SpyCode = pred;
t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t))
return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0));
pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
pred = RepPredProp(PredPropByFunc(fun, mod));
} else {
return (FALSE);
}
@ -1249,20 +1288,26 @@ p_setspy(void)
static Int
p_rmspy(void)
{ /* '$rm_spy'(+T) */
{ /* '$rm_spy'(+T,+Mod) */
Atom at;
PredEntry *pred;
Term t;
Term t2;
SMALLUNSGN mod;
t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsVarTerm(t))
return (FALSE);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0));
pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
pred = RepPredProp(PredPropByFunc(fun, mod));
} else
return (FALSE);
WRITE_LOCK(pred->PRWLock);
@ -1294,19 +1339,25 @@ p_rmspy(void)
static Int
p_number_of_clauses(void)
{ /* '$number_of_clauses'(Predicate,N) */
{ /* '$number_of_clauses'(Predicate,M,N) */
Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
int ncl = 0;
Prop pe;
CODEADDR q;
int testing;
int mod;
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return(FALSE);
}
mod = LookupModule(t2);
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pe = PredProp(a, 0);
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f, *CurrentModulePtr);
pe = PredPropByFunc(f, mod);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
@ -1328,113 +1379,29 @@ p_number_of_clauses(void)
}
READ_UNLOCK(RepPredProp(pe)->PRWLock);
t = MkIntTerm(ncl);
return (unify_constant(ARG2, t));
}
static Int
p_find_dynamic(void)
{ /* '$find_dynamic'(+G,+N,-C) */
Term t = Deref(ARG1);
Prop pe;
CODEADDR q;
int position;
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pe = PredProp(a, 0);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
t = Deref(ARG2);
if (IsVarTerm(t) || !IsIntTerm(t))
return (FALSE);
position = IntOfTerm(t);
READ_LOCK(RepPredProp(pe)->PRWLock);
if (!(RepPredProp(pe)->PredFlags & DynamicPredFlag))
return (FALSE);
while (position > 1) {
while (ClauseCodeToClause(q)->ClFlags & ErasedMask)
q = NextClause(q);
position--;
q = NextClause(q);
}
while (ClauseCodeToClause(q)->ClFlags & ErasedMask)
q = NextClause(q);
#if defined(YAPOR) || defined(THREADS)
{
Clause *cl = ClauseCodeToClause(q);
LOCK(cl->ClLock);
TRAIL_CLREF(cl);
INC_CLREF_COUNT(cl);
UNLOCK(cl->ClLock);
}
#else
if (!(ClauseCodeToClause(q)->ClFlags & InUseMask)) {
OPREG *opp = &(ClauseCodeToClause(q)->ClFlags);
TRAIL_CLREF(ClauseCodeToClause(q));
*opp |= InUseMask;
}
#endif
READ_UNLOCK(RepPredProp(pe)->PRWLock);
t = MkIntegerTerm((Int)q);
return (unify(ARG3, t));
}
static Int
p_next_dynamic(void)
{ /* '$next_dynamic'(+G,+C,-N) */
Term t = Deref(ARG1);
Prop pe;
CODEADDR q, oldq;
int position;
t = Deref(ARG2);
if (IsVarTerm(t) || !IsIntegerTerm(t))
return (FALSE);
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pe = PredProp(a, 0);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
READ_LOCK(RepPredProp(pe)->PRWLock);
if (!(RepPredProp(pe)->PredFlags & DynamicPredFlag))
return (FALSE);
oldq = (CODEADDR)IntegerOfTerm(t);
position = 1;
while (q != oldq) {
if (!(ClauseCodeToClause(q)->ClFlags & ErasedMask))
position++;
q = NextClause(q);
}
if (!(ClauseCodeToClause(q)->ClFlags & ErasedMask))
position++;
READ_UNLOCK(RepPredProp(pe)->PRWLock);
t = MkIntTerm(position);
return (unify_constant(ARG3, t));
}
static Int
p_in_use(void)
{ /* '$in_use'(+P) */
{ /* '$in_use'(+P,+Mod) */
Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
PredEntry *pe;
Int out;
int mod;
if (IsVarTerm(t))
return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0));
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
pe = RepPredProp(PredPropByFunc(fun, mod));
} else
return (FALSE);
READ_LOCK(pe->PRWLock);
@ -1445,11 +1412,12 @@ p_in_use(void)
static Int
p_new_multifile(void)
{ /* '$new_multifile'(+N,+Ar) */
{ /* '$new_multifile'(+N,+Ar,+Mod) */
Atom at;
int arity;
PredEntry *pe;
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG3));
if (IsVarTerm(t))
return (FALSE);
@ -1464,7 +1432,10 @@ p_new_multifile(void)
arity = IntOfTerm(t);
else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
if (arity == 0)
pe = RepPredProp(PredPropByAtom(at, mod));
else
pe = RepPredProp(PredPropByFunc(MkFunctor(at, arity),mod));
WRITE_LOCK(pe->PRWLock);
pe->PredFlags |= MultiFileFlag;
WRITE_UNLOCK(pe->PRWLock);
@ -1474,28 +1445,27 @@ p_new_multifile(void)
static Int
p_is_multifile(void)
{ /* '$is_multifile'(+N,+Ar) */
Atom at;
int arity;
{ /* '$is_multifile'(+S,+Mod) */
PredEntry *pe;
Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
Int out;
int mod;
if (IsVarTerm(t))
return (FALSE);
if (IsAtomTerm(t))
at = AtomOfTerm(t);
else
if (IsVarTerm(t2))
return (FALSE);
t = Deref(ARG2);
if (IsVarTerm(t))
if (!IsAtomTerm(t2))
return (FALSE);
if (IsIntTerm(t))
arity = IntOfTerm(t);
else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
if (pe == NIL)
mod = LookupModule(t2);
if (IsAtomTerm(t)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod));
} else if (IsApplTerm(t)) {
pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod));
} else
return(FALSE);
if (EndOfPAEntr(pe))
return (FALSE);
READ_LOCK(pe->PRWLock);
out = (pe->PredFlags & MultiFileFlag);
@ -1503,52 +1473,23 @@ p_is_multifile(void)
return(out);
}
static Int
p_is_logical_updatable(void)
{ /* '$is_logical_updatable'(+N,+Ar) */
Atom at;
int arity;
PredEntry *pe;
Term t = Deref(ARG1);
Int out;
if (IsVarTerm(t))
return (FALSE);
if (IsAtomTerm(t))
at = AtomOfTerm(t);
else
return (FALSE);
t = Deref(ARG2);
if (IsVarTerm(t))
return (FALSE);
if (IsIntTerm(t))
arity = IntOfTerm(t);
else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
if (pe == NIL)
return (FALSE);
READ_LOCK(pe->PRWLock);
out = (pe->PredFlags & LogUpdatePredFlag);
READ_UNLOCK(pe->PRWLock);
return(out);
}
static Int
p_is_dynamic(void)
{ /* '$is_dynamic'(+P) */
PredEntry *pe;
Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
Int out;
SMALLUNSGN mod = LookupModule(t2);
if (IsVarTerm(t)) {
return (FALSE);
} else if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0));
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
pe = RepPredProp(PredPropByFunc(fun, mod));
} else
return (FALSE);
if (pe == NIL)
@ -1562,31 +1503,40 @@ p_is_dynamic(void)
static Int
p_set_pred_module(void)
{ /* '$set_pred_module'(+P,+Mod) */
Atom at;
int arity;
PredEntry *pe;
Term t = Deref(ARG1);
SMALLUNSGN mod = CurrentModule;
restart_set_pred:
if (IsVarTerm(t)) {
return (FALSE);
} else if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
arity = 0;
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
at = NameOfFunctor(fun);
arity = ArityOfFunctor(fun);
if (fun == FunctorModule) {
Term tmod = ArgOfTerm(1, t);
if (IsVarTerm(tmod) ) {
Error(INSTANTIATION_ERROR,ARG1,"set_pred_module/1");
return(FALSE);
}
if (!IsAtomTerm(tmod) ) {
Error(TYPE_ERROR_ATOM,ARG1,"set_pred_module/1");
return(FALSE);
}
mod = LookupModule(tmod);
t = ArgOfTerm(2, t);
goto restart_set_pred;
}
pe = RepPredProp(PredPropByFunc(fun, mod));
} else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
if (pe == NIL)
if (EndOfPAEntr(pe))
return (FALSE);
WRITE_LOCK(pe->PRWLock);
{
SMALLUNSGN mod = LookupModule(Deref(ARG2));
if (mod)
pe->ModuleOfPred = MkIntTerm(mod);
else
pe->ModuleOfPred = 0;
pe->ModuleOfPred = mod;
}
WRITE_UNLOCK(pe->PRWLock);
return(TRUE);
@ -1594,12 +1544,23 @@ p_set_pred_module(void)
static Int
p_undefined(void)
{ /* '$undefined'(P) */
{ /* '$undefined'(P,Mod) */
PredEntry *pe;
Term t;
Term tmod = *CurrentModulePtr;
Term t2;
SMALLUNSGN mod;
t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
Error(INSTANTIATION_ERROR,ARG2,"undefined/1");
return(FALSE);
}
if (!IsAtomTerm(t2)) {
Error(TYPE_ERROR_ATOM,ARG2,"undefined/1");
return(FALSE);
}
mod = LookupModule(t2);
restart_undefined:
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
@ -1607,24 +1568,24 @@ p_undefined(void)
}
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(GetPredPropByAtom(at,tmod));
pe = RepPredProp(GetPredPropByAtom(at,mod));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t);
if (funt == FunctorModule) {
Term mod = ArgOfTerm(1, t);
if (IsVarTerm(mod) ) {
Term tmod = ArgOfTerm(1, t);
if (IsVarTerm(tmod) ) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
return(FALSE);
}
if (!IsAtomTerm(mod) ) {
if (!IsAtomTerm(tmod) ) {
Error(TYPE_ERROR_ATOM,ARG1,"undefined/1");
return(FALSE);
}
tmod = MkIntTerm(LookupModule(mod));
mod = LookupModule(tmod);
t = ArgOfTerm(2, t);
goto restart_undefined;
}
pe = RepPredProp(GetPredPropByFunc(funt, tmod));
pe = RepPredProp(GetPredPropByFunc(funt, mod));
} else {
return (FALSE);
}
@ -1650,20 +1611,32 @@ p_undefined(void)
static Int
p_kill_dynamic(void)
{ /* '$kill_dynamic'(P) */
{ /* '$kill_dynamic'(P,M) */
PredEntry *pe;
Term t;
Term t2;
SMALLUNSGN mod;
t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
Error(INSTANTIATION_ERROR,ARG2,"undefined/1");
return(FALSE);
}
if (!IsAtomTerm(t2)) {
Error(TYPE_ERROR_ATOM,ARG2,"undefined/1");
return(FALSE);
}
mod = LookupModule(t2);
t = Deref(ARG1);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0));
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
pe = RepPredProp(PredPropByFunc(funt, mod));
} else
return (FALSE);
if (pe == NIL)
if (EndOfPAEntr(pe))
return (TRUE);
WRITE_LOCK(pe->PRWLock);
if (!(pe->PredFlags & DynamicPredFlag)) {
@ -1845,43 +1818,6 @@ do_toggle_static_predicates_in_use(int mask)
#endif
static Int
p_search_for_static_predicate_in_use(void)
{
#if defined(YAPOR) || defined(THREADS)
return(FALSE);
#else
PredEntry *pe;
Term t;
Int out;
t = Deref(ARG1);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(ARG1);
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
} else
return(FALSE);
/* do nothing if we are in consult */
if (STATIC_PREDICATES_MARKED)
return (pe->StateOfPred & InUseMask);
/* if it was not defined, surely it was not in use */
if (pe == NIL)
return (TRUE);
READ_LOCK(pe->PRWLock);
if (pe->PredFlags & (BasicPredFlag|StandardPredFlag|DynamicPredFlag|CPredFlag)) {
READ_UNLOCK(pe->PRWLock);
return(FALSE);
}
out = search_for_static_predicate_in_use(pe, TRUE);
READ_UNLOCK(pe->PRWLock);
return(out);
#endif
}
/* This predicate is to be used by reconsult to mark all predicates
currently in use as being executed.
@ -2039,22 +1975,30 @@ p_is_profiled(void)
static Int
p_profile_info(void)
{
Term tname = Deref(ARG1);
Term tarity = Deref(ARG2);
Term tmod = Deref(ARG1);
Term tfun = Deref(ARG2);
int mod;
Term out;
PredEntry *pe;
Int arity;
Atom name;
Term p[3];
if (IsVarTerm(tname) || !IsAtomTerm(tname))
if (IsVarTerm(tmod) || !IsAtomTerm(tmod))
return(FALSE);
if (IsVarTerm(tarity) || !IsIntTerm(tarity))
mod = LookupModule(tmod);
if (IsVarTerm(tfun)) {
return(FALSE);
name = AtomOfTerm(tname);
arity = IntOfTerm(tarity);
pe = RepPredProp(GetPredProp(name, arity));
if (pe == NULL)
} else if (IsApplTerm(tfun)) {
Functor f = FunctorOfTerm(tfun);
if (IsExtensionFunctor(f)) {
return(FALSE);
}
pe = RepPredProp(GetPredPropByFunc(f, mod));
} else if (IsAtomTerm(tfun)) {
pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(tfun), mod));
} else {
return(FALSE);
}
if (EndOfPAEntr(pe))
return(FALSE);
LOCK(pe->StatisticsForPred.lock);
if (!(pe->StatisticsForPred.NOfEntries)) {
@ -2072,20 +2016,28 @@ p_profile_info(void)
static Int
p_profile_reset(void)
{
Term tname = Deref(ARG1);
Term tarity = Deref(ARG2);
Term tmod = Deref(ARG1);
Term tfun = Deref(ARG2);
int mod;
PredEntry *pe;
Int arity;
Atom name;
if (IsVarTerm(tname) || !IsAtomTerm(tname))
if (IsVarTerm(tmod) || !IsAtomTerm(tmod))
return(FALSE);
if (IsVarTerm(tarity) || !IsIntTerm(tarity))
mod = LookupModule(tmod);
if (IsVarTerm(tfun)) {
return(FALSE);
name = AtomOfTerm(tname);
arity = IntOfTerm(tarity);
pe = RepPredProp(GetPredProp(name, arity));
if (pe == NULL)
} else if (IsApplTerm(tfun)) {
Functor f = FunctorOfTerm(tfun);
if (IsExtensionFunctor(f)) {
return(FALSE);
}
pe = RepPredProp(GetPredPropByFunc(f, mod));
} else if (IsAtomTerm(tfun)) {
pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(tfun), mod));
} else {
return(FALSE);
}
if (EndOfPAEntr(pe))
return(FALSE);
LOCK(pe->StatisticsForPred.lock);
pe->StatisticsForPred.NOfEntries = 0;
@ -2124,21 +2076,23 @@ p_parent_pred(void)
unify(ARG3, MkIntTerm(arity)));
}
static Int /* $parent_pred(Module, Name, Arity) */
static Int /* $system_predicate(P) */
p_system_pred(void)
{
PredEntry *pe;
Term mod = *CurrentModulePtr;
Term t1 = Deref(ARG1);
restart:
restart_system_pred:
if (IsVarTerm(t1))
return (FALSE);
if (IsAtomTerm(t1)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod));
pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(t1), 0));
} else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1);
if (funt == FunctorModule) {
if (IsExtensionFunctor(funt)) {
return(FALSE);
}
while (funt == FunctorModule) {
Term nmod = ArgOfTerm(1, t1);
if (IsVarTerm(nmod)) {
Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
@ -2148,13 +2102,14 @@ p_system_pred(void)
Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
return(FALSE);
}
mod = MkIntTerm(LookupModule(nmod));
t1 = ArgOfTerm(2, t1);
goto restart;
goto restart_system_pred;
}
pe = RepPredProp(PredPropByFunc(funt, mod));
pe = RepPredProp(GetPredPropByFunc(funt, 0));
} else
return (FALSE);
if (EndOfPAEntr(pe))
return(FALSE);
return(pe->ModuleOfPred == 0);
}
@ -2165,33 +2120,29 @@ InitCdMgr(void)
InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag);
InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag);
InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag);
InitCPred("$set_spy", 1, p_setspy, SafePredFlag|SyncPredFlag);
InitCPred("$rm_spy", 1, p_rmspy, SafePredFlag|SyncPredFlag);
InitCPred("$set_spy", 2, p_setspy, SafePredFlag|SyncPredFlag);
InitCPred("$rm_spy", 2, p_rmspy, SafePredFlag|SyncPredFlag);
/* gc() may happen during compilation, hence these predicates are
now unsafe */
InitCPred("$compile", 2, p_compile, SyncPredFlag);
InitCPred("$compile_dynamic", 3, p_compile_dynamic, SyncPredFlag);
InitCPred("$purge_clauses", 1, p_purge_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$in_use", 1, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag);
InitCPred("$is_logical_updatable", 1, p_is_logical_updatable, TestPredFlag | SafePredFlag);
InitCPred("$is_dynamic", 1, p_is_dynamic, TestPredFlag | SafePredFlag);
InitCPred("$number_of_clauses", 2, p_number_of_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$find_dynamic", 3, p_find_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$next_dynamic", 3, p_next_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$undefined", 1, p_undefined, SafePredFlag|TestPredFlag);
InitCPred("$compile", 3, p_compile, SyncPredFlag);
InitCPred("$compile_dynamic", 4, p_compile_dynamic, SyncPredFlag);
InitCPred("$purge_clauses", 2, p_purge_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$in_use", 2, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag);
InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag);
InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$undefined", 2, p_undefined, SafePredFlag|TestPredFlag);
InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag);
InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag);
InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag);
InitCPred("$kill_dynamic", 1, p_kill_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$in_this_file_before", 2, p_in_this_f_before, SafePredFlag);
InitCPred("$first_clause_in_file", 2, p_first_cl_in_f, SafePredFlag);
InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag);
InitCPred("$first_clause_in_file", 3, p_first_cl_in_f, SafePredFlag);
InitCPred("$mk_cl_not_first", 2, p_mk_cl_not_first, SafePredFlag);
InitCPred("$new_multifile", 2, p_new_multifile, SafePredFlag|SyncPredFlag);
InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag);
InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag);
InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag);
InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag);
InitCPred("$profile_reset", 2, p_profile_reset, SafePredFlag|SyncPredFlag);
InitCPred("$search_for_static_predicates_in_use", 1, p_search_for_static_predicate_in_use, TestPredFlag|SafePredFlag|SyncPredFlag);
InitCPred("$toggle_static_predicates_in_use", 0, p_toggle_static_predicates_in_use, SafePredFlag|SyncPredFlag);
InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag);
InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag);

115
C/compiler.c
View File

@ -34,10 +34,10 @@ STATIC_PROTO(void c_arg, (Int, Term, unsigned int));
STATIC_PROTO(void c_args, (Term));
STATIC_PROTO(void c_eq, (Term, Term));
STATIC_PROTO(void c_test, (Int, Term));
STATIC_PROTO(void c_bifun, (Int, Term, Term, Term));
STATIC_PROTO(void c_goal, (Term));
STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int));
STATIC_PROTO(void c_goal, (Term, int));
STATIC_PROTO(void get_type_info, (Term));
STATIC_PROTO(void c_body, (Term));
STATIC_PROTO(void c_body, (Term, int));
STATIC_PROTO(void get_cl_info, (Term));
STATIC_PROTO(void c_head, (Term));
STATIC_PROTO(int usesvar, (int));
@ -702,7 +702,7 @@ bip_cons Op,Xk,Ri,C
*/
static void
c_bifun(Int Op, Term t1, Term t2, Term t3)
c_bifun(Int Op, Term t1, Term t2, Term t3, int mod)
{
/* compile Z = X Op Y arithmetic function */
/* first we fetch the arguments */
@ -821,7 +821,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
if (IsNumTerm(t1)) {
/* we will always fail */
if (i2)
c_goal(MkAtomTerm(AtomFalse));
c_goal(MkAtomTerm(AtomFalse), mod);
} else if (!IsAtomTerm(t1)) {
char s[32];
@ -892,7 +892,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
} else if (IsApplTerm(t2)) {
Functor f = FunctorOfTerm(t2);
if (i1 < 1 || i1 > ArityOfFunctor(f)) {
c_goal(MkAtomTerm(AtomFalse));
c_goal(MkAtomTerm(AtomFalse), mod);
} else {
c_eq(ArgOfTerm(i1, t2), t3);
}
@ -906,7 +906,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
c_eq(TailOfTerm(t2), t3);
return;
default:
c_goal(MkAtomTerm(AtomFalse));
c_goal(MkAtomTerm(AtomFalse), mod);
return;
}
}
@ -1066,13 +1066,13 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
}
static void
c_functor(Term Goal)
c_functor(Term Goal, int mod)
{
Term t1 = ArgOfTerm(1, Goal);
Term t2 = ArgOfTerm(2, Goal);
Term t3 = ArgOfTerm(3, Goal);
if (IsVarTerm(t1) && IsNewVar(t1)) {
c_bifun(_functor, t2, t3, t1);
c_bifun(_functor, t2, t3, t1, mod);
} else if (IsNonVarTerm(t1)) {
/* just split the structure */
if (IsAtomicTerm(t1)) {
@ -1095,7 +1095,7 @@ c_functor(Term Goal)
c_var(t3,f_flag,(unsigned int)_functor);
} else {
Functor f = FunctorOfTerm(Goal);
Prop p0 = PredPropByFunc(f, *CurrentModulePtr);
Prop p0 = PredPropByFunc(f, mod);
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero);
c_args(Goal);
@ -1122,16 +1122,14 @@ IsTrueGoal(Term t) {
}
static void
c_goal(Term Goal)
c_goal(Term Goal, int mod)
{
Functor f;
PredEntry *p;
Prop p0;
int save_CurrentModule = CurrentModule;
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
}
if (IsNumTerm(Goal)) {
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
@ -1142,7 +1140,6 @@ c_goal(Term Goal)
FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal);
} else if (IsPairTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
} else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) {
Term M = ArgOfTerm(1, Goal);
@ -1153,19 +1150,17 @@ c_goal(Term Goal)
save_machine_regs();
longjmp(CompilerBotch, 1);
}
*CurrentModulePtr = MkIntTerm(LookupModule(M));
Goal = ArgOfTerm(2, Goal);
mod = LookupModule(M);
}
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
}
if (IsAtomTerm(Goal)) {
Atom atom = AtomOfTerm(Goal);
if (atom == AtomFail || atom == AtomFalse) {
emit(fail_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (atom == AtomTrue || atom == AtomOtherwise) {
@ -1178,13 +1173,12 @@ c_goal(Term Goal)
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (atom == AtomCut) {
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(PredProp(AtomCut,0)), Zero);
emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero);
if (onlast) {
/* never a problem here with a -> b, !, c ; d */
emit(deallocate_op, Zero, Zero);
@ -1207,7 +1201,6 @@ c_goal(Term Goal)
/* needs to adjust previous commits */
adjust_current_commits();
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
#ifndef YAPOR
@ -1216,7 +1209,7 @@ c_goal(Term Goal)
CELL l2 = ++labelno;
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(PredProp(AtomRepeat,0)), Zero);
emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomRepeat,0)), Zero);
or_found = 1;
push_branch(onbranch, TermNil);
cur_branch++;
@ -1247,20 +1240,17 @@ c_goal(Term Goal)
onbranch = pop_branch();
emit(pop_or_op, Zero, Zero);
/* --onbranch; */
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
#endif /* YAPOR */
else
f = MkFunctor(atom, 0);
p = RepPredProp(p0 = PredProp(atom, 0));
p = RepPredProp(p0 = PredPropByAtom(atom, mod));
/* if we are profiling, make sure we register we entered this predicate */
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
}
else {
f = FunctorOfTerm(Goal);
p = RepPredProp(p0 = PredPropByFunc(f, *CurrentModulePtr));
p = RepPredProp(p0 = PredPropByFunc(f, mod));
if (f == FunctorOr) {
CELL l = ++labelno;
CELL m = ++labelno;
@ -1289,7 +1279,7 @@ c_goal(Term Goal)
}
emit_3ops(push_or_op, l, Zero, Zero);
if (looking_at_comit &&
is_a_test_pred(ArgOfTerm(1, arg))) {
is_a_test_pred(ArgOfTerm(1, arg), mod)) {
/*
* let them think they are still the
* first
@ -1346,16 +1336,16 @@ c_goal(Term Goal)
}
save = onlast;
onlast = FALSE;
c_goal(ArgOfTerm(1, arg));
c_goal(ArgOfTerm(1, arg), mod);
if (!optimizing_comit) {
c_var((Term) comitvar, comit_b_flag,
1);
}
onlast = save;
c_goal(ArgOfTerm(2, arg));
c_goal(ArgOfTerm(2, arg), mod);
}
else
c_goal(ArgOfTerm(1, Goal));
c_goal(ArgOfTerm(1, Goal), mod);
if (!onlast) {
emit(jump_op, m, Zero);
}
@ -1372,16 +1362,15 @@ c_goal(Term Goal)
else {
optimizing_comit = FALSE; /* not really necessary */
}
c_goal(Goal);
c_goal(Goal, mod);
/* --onbranch; */
onbranch = pop_branch();
if (!onlast) {
emit(label_op, m, Zero);
if ((onlast = save))
c_goal(MkAtomTerm(AtomTrue));
c_goal(MkAtomTerm(AtomTrue), mod);
}
emit(pop_or_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorComma) {
@ -1389,10 +1378,9 @@ c_goal(Term Goal)
int t2 = ArgOfTerm(2, Goal);
onlast = FALSE;
c_goal(ArgOfTerm(1, Goal));
c_goal(ArgOfTerm(1, Goal), mod);
onlast = save;
c_goal(t2);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
c_goal(t2, mod);
return;
}
else if (f == FunctorNot || f == FunctorAltNot) {
@ -1416,7 +1404,7 @@ c_goal(Term Goal)
emit_3ops(push_or_op, label, Zero, Zero);
emit_3ops(either_op, label, Zero, Zero);
emit(restore_tmps_op, Zero, Zero);
c_goal(ArgOfTerm(1, Goal));
c_goal(ArgOfTerm(1, Goal), mod);
c_var(comitvar, comit_b_flag, 1);
onlast = save;
emit(fail_op, end_label, Zero);
@ -1427,10 +1415,9 @@ c_goal(Term Goal)
onlast = save;
/* --onbranch; */
onbranch = pop_branch();
c_goal(MkAtomTerm(AtomTrue));
c_goal(MkAtomTerm(AtomTrue), mod);
++goalno;
emit(pop_or_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorArrow) {
@ -1445,11 +1432,10 @@ c_goal(Term Goal)
}
onlast = FALSE;
c_var(comitvar, save_b_flag, 1);
c_goal(ArgOfTerm(1, Goal));
c_goal(ArgOfTerm(1, Goal), mod);
c_var(comitvar, comit_b_flag, 1);
onlast = save;
c_goal(ArgOfTerm(2, Goal));
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
c_goal(ArgOfTerm(2, Goal), mod);
return;
} else if (f == FunctorEq) {
if (profiling)
@ -1468,23 +1454,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else if (f == FunctorModSwitch) {
Term omod = MkVarTerm();
Term mod = ArgOfTerm(1, Goal);
Term goal = ArgOfTerm(2, Goal);
Term a[1];
int cp_onlast = onlast;
onlast = FALSE;
a[0] = omod;
c_goal(MkApplTerm(FunctorCurrentModule, 1, a));
a[0] = mod;
c_goal(MkApplTerm(FunctorChangeModule, 1, a));
c_goal(goal);
a[0] = omod;
onlast = cp_onlast;
c_goal(MkApplTerm(FunctorChangeModule, 1, a));
return;
} else if (p->PredFlags & BasicPredFlag) {
int op = p->PredFlags & 0x7f;
@ -1505,16 +1474,16 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else if (op >= _plus && op <= _functor) {
if (op == _functor) {
c_functor(Goal);
c_functor(Goal, mod);
} else {
c_bifun(op,
ArgOfTerm(1, Goal),
ArgOfTerm(2, Goal),
ArgOfTerm(3, Goal));
ArgOfTerm(3, Goal),
mod);
}
if (onlast) {
emit(deallocate_op, Zero, Zero);
@ -1529,7 +1498,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else {
c_args(Goal);
@ -1604,7 +1572,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else {
if (profiling)
@ -1678,7 +1645,6 @@ c_goal(Term Goal)
if (!onlast)
++goalno;
}
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
}
static void
@ -1707,7 +1673,7 @@ get_type_info(Term Goal)
}
static void
c_body(Term Body)
c_body(Term Body, int mod)
{
onhead = FALSE;
BodyStart = cpc;
@ -1728,11 +1694,11 @@ c_body(Term Body)
Body = ArgOfTerm(1, Body);
break;
}
c_goal(ArgOfTerm(1, Body));
c_goal(ArgOfTerm(1, Body), mod);
Body = t2;
}
onlast = TRUE;
c_goal(Body);
c_goal(Body, mod);
}
static void
@ -2739,7 +2705,7 @@ c_optimize(PInstr *pc)
}
CODEADDR
cclause(Term inp_clause, int NOfArgs)
cclause(Term inp_clause, int NOfArgs, int mod)
{ /* compile a prolog clause, copy of clause myst be in ARG1 */
/* returns address of code for clause */
Term head, body;
@ -2750,7 +2716,6 @@ cclause(Term inp_clause, int NOfArgs)
int botch_why;
volatile Term my_clause = inp_clause;
/* may botch while doing a different module */
volatile int save_CurrentModule = CurrentModule;
/* first, initialise CompilerBotch to handle all cases of interruptions */
ErrorMessage = NIL;
@ -2760,7 +2725,6 @@ cclause(Term inp_clause, int NOfArgs)
reset_vars();
{
Int osize = 2*sizeof(CELL)*(ASP-H);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
ARG1 = my_clause;
if (!gc(2, ENV, P)) {
Error_TYPE = SYSTEM_ERROR;
@ -2780,7 +2744,6 @@ cclause(Term inp_clause, int NOfArgs)
/* out of temporary cells */
restore_machine_regs();
reset_vars();
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
if (maxvnum < 16*1024) {
maxvnum *= 2;
} else {
@ -2790,7 +2753,6 @@ cclause(Term inp_clause, int NOfArgs)
/* not enough heap */
restore_machine_regs();
reset_vars();
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "not enough heap space to compile clause";
@ -2798,7 +2760,6 @@ cclause(Term inp_clause, int NOfArgs)
}
restart_compilation:
if (ErrorMessage != NIL) {
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
reset_vars();
return (0);
}
@ -2852,9 +2813,9 @@ cclause(Term inp_clause, int NOfArgs)
/* find out which predicate we are compiling for */
if (IsAtomTerm(head)) {
Atom ap = AtomOfTerm(head);
CurrentPred = RepPredProp(PredProp(ap, 0));
CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
} else {
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),*CurrentModulePtr));
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),mod));
}
/* insert extra instructions to count calls */
READ_LOCK(CurrentPred->PRWLock);
@ -2868,7 +2829,7 @@ cclause(Term inp_clause, int NOfArgs)
/* phase 1 : produce skeleton code and variable information */
c_head(head);
emit(allocate_op, Zero, Zero);
c_body(body);
c_body(body, mod);
/* Insert blobs at the very end */
if (BlobsStart != NULL) {
cpc->nextInst = BlobsStart;

12
C/computils.c
View File

@ -68,23 +68,25 @@ AllocCMem (int size)
}
int
is_a_test_pred (Term arg)
is_a_test_pred (Term arg, SMALLUNSGN mod)
{
if (IsVarTerm (arg))
return (FALSE);
else if (IsAtomTerm (arg))
{
Atom At = AtomOfTerm (arg);
if (RepPredProp (PredProp (At, 0)) == NULL)
PredEntry *pe = RepPredProp(PredPropByAtom(At, mod));
if (EndOfPAEntr(pe))
return (FALSE);
return (RepPredProp (PredProp (At, 0))->PredFlags & TestPredFlag);
return (pe->PredFlags & TestPredFlag);
}
else if (IsApplTerm (arg))
{
Functor f = FunctorOfTerm (arg);
if (RepPredProp (PredPropByFunc (f, *CurrentModulePtr)) == NULL)
PredEntry *pe = RepPredProp(PredPropByFunc(f, mod));
if (EndOfPAEntr(pe))
return (FALSE);
return (RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->PredFlags & TestPredFlag);
return (pe->PredFlags & TestPredFlag);
}
else
return (FALSE);

4
C/corout.c
View File

@ -1158,8 +1158,8 @@ void InitCoroutPreds(void)
attas[susp_ext].mark_op = mark_suspended_goal;
#endif /* FIXED_STACKS */
at = LookupAtom("$wake_up_goal");
pred = RepPredProp(PredProp(at, 2));
WakeUpCode = (CELL *) pred;
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 2),0));
WakeUpCode = pred;
InitAttVarPreds();
#endif /* COROUTINING */
InitCPred("$read_svar_list", 2, p_read_svar_list, SafePredFlag);

93
C/dbase.c
View File

@ -164,8 +164,6 @@ static Term DBErrorTerm; /* error term */
static char *DBErrorMsg; /* Error Message */
static DBRef *tofref; /* place the refs also up */
static SMALLUNSGN DBModule;
CELL *next_float = NULL;
#ifdef SFUNC
@ -197,7 +195,7 @@ STATIC_PROTO(void linkblk,(link_entry *,CELL *));
STATIC_PROTO(CELL *linkcells,(CELL *,Int));
#endif
STATIC_PROTO(Int cmpclls,(CELL *,CELL *,Int));
STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int));
STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int, SMALLUNSGN));
STATIC_PROTO(CELL CalcKey, (Term));
STATIC_PROTO(CELL *MkDBTerm, (CELL *, CELL *, CELL *, CELL *, CELL *, int *));
STATIC_PROTO(DBRef CreateDBStruct, (Term, DBProp, int));
@ -392,7 +390,7 @@ int DBTrailOverflow(void)
/* get DB entry for ap/arity; */
static Prop
FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity)
FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity, SMALLUNSGN dbmod)
{
Prop p0;
DBProp p;
@ -400,7 +398,7 @@ FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity)
p = RepDBProp(p0 = ae->PropsOfAE);
while (p0 && (((p->KindOfPE & ~0x1) != (CodeDB|DBProperty)) ||
(p->ArityOfDB != arity) ||
((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != DBModule ))) {
((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != dbmod))) {
p = RepDBProp(p0 = p->NextOfPE);
}
return (p0);
@ -409,12 +407,12 @@ FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity)
/* get DB entry for ap/arity; */
static Prop
FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity)
FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity, SMALLUNSGN dbmod)
{
Prop out;
READ_LOCK(ae->ARWLock);
out = FindDBPropHavingLock(ae, CodeDB, arity);
out = FindDBPropHavingLock(ae, CodeDB, arity, dbmod);
READ_UNLOCK(ae->ARWLock);
return(out);
}
@ -1551,7 +1549,6 @@ p_rcda(void)
/* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBModule = 0;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
restart_record:
@ -1591,7 +1588,6 @@ p_rcdap(void)
{
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBModule = CurrentModule;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
restart_record:
@ -1631,7 +1627,6 @@ p_rcdz(void)
{
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBModule = 0;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
restart_record:
@ -1671,7 +1666,6 @@ p_rcdzp(void)
{
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBModule = CurrentModule;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
restart_record:
@ -1713,7 +1707,6 @@ p_rcdstatp(void)
int mk_first;
Term TRef;
DBModule = CurrentModule;
if (IsVarTerm(t3) || !IsIntTerm(t3))
return (FALSE);
if (IsVarTerm(t3) || !IsIntTerm(t3))
@ -1759,7 +1752,6 @@ p_drcdap(void)
{
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
DBModule = CurrentModule;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
if (IsVarTerm(t4) || !IsIntegerTerm(t4))
@ -1803,7 +1795,6 @@ p_drcdzp(void)
{
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
DBModule = CurrentModule;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
if (IsVarTerm(t4) || !IsIntegerTerm(t4))
@ -1849,7 +1840,6 @@ p_rcdaifnot(void)
DBRef db_ref;
restart_record:
DBModule = 0;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
found_one = NIL;
@ -1892,7 +1882,6 @@ p_rcdzifnot(void)
DBRef db_ref;
restart_record:
DBModule = 0;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
found_one = NIL;
@ -2062,7 +2051,7 @@ FetchIntDBPropFromKey(Int key, int flag, int new, char *error_mssg)
}
p->ArityOfDB = 0;
p->First = p->Last = NIL;
p->ModuleOfDB = DBModule;
p->ModuleOfDB = 0;
p->FunctorOfDB = fun;
p->NextOfPE = INT_KEYS[hash_key];
INIT_RWLOCK(p->DBRWLock);
@ -2078,7 +2067,37 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
{
Atom At;
Int arity;
SMALLUNSGN dbmod;
if (flag & MkCode) {
if (IsVarTerm(twork)) {
Error(INSTANTIATION_ERROR, twork, error_mssg);
return(RepDBProp(NIL));
}
if (!IsApplTerm(twork)) {
Error(SYSTEM_ERROR, twork, "missing module");
return(RepDBProp(NIL));
} else {
Functor f = FunctorOfTerm(twork);
Term tmod;
if (f != FunctorModule) {
Error(SYSTEM_ERROR, twork, "missing module");
return(RepDBProp(NIL));
}
tmod = ArgOfTerm(1, twork);
if (IsVarTerm(tmod)) {
Error(INSTANTIATION_ERROR, twork, "var in module");
return(RepDBProp(NIL));
}
if (!IsAtomTerm(tmod)) {
Error(TYPE_ERROR_ATOM, twork, "not atom in module");
return(RepDBProp(NIL));
}
dbmod = LookupModule(tmod);
twork = ArgOfTerm(2, twork);
}
} else
dbmod = 0;
if (IsVarTerm(twork)) {
Error(INSTANTIATION_ERROR, twork, error_mssg);
return(RepDBProp(NIL));
@ -2106,11 +2125,13 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
AtomEntry *ae = RepAtom(At);
WRITE_LOCK(ae->ARWLock);
if (EndOfPAEntr(p = RepDBProp(FindDBPropHavingLock(ae, flag, arity)))) {
if (EndOfPAEntr(p = RepDBProp(FindDBPropHavingLock(ae, flag, arity, dbmod)))) {
/* create a new DBProp */
int OLD_UPDATE_MODE = UPDATE_MODE;
if (flag & MkCode) {
PredEntry *pp = RepPredProp(GetPredPropHavingLock(At, arity));
PredEntry *pp;
pp = RepPredProp(GetPredPropHavingLock(At, arity, dbmod));
if (!EndOfPAEntr(pp)) {
READ_LOCK(pp->PRWLock);
if(pp->PredFlags & LogUpdatePredFlag)
@ -2139,7 +2160,7 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
UPDATE_MODE = OLD_UPDATE_MODE;
p->ArityOfDB = arity;
p->First = p->Last = NIL;
p->ModuleOfDB = DBModule;
p->ModuleOfDB = dbmod;
/* This is NOT standard but is QUITE convenient */
INIT_RWLOCK(p->DBRWLock);
if (arity == 0)
@ -2152,7 +2173,7 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
WRITE_UNLOCK(ae->ARWLock);
return(p);
} else
return(RepDBProp(FindDBProp(RepAtom(At), flag, arity)));
return(RepDBProp(FindDBProp(RepAtom(At), flag, arity, dbmod)));
}
/* Finds a term recorded under the key ARG1 */
@ -2335,7 +2356,6 @@ p_db_key(void)
Register Term twork = Deref(ARG1); /* fetch the key */
DBProp AtProp;
DBModule = 0;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, TRUE, "db_key/3"))) {
/* should never happen */
return(FALSE);
@ -2733,7 +2753,6 @@ in_rded(void)
* ARG1 */
DBModule = 0;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "recorded/3"))) {
if (b0 == B)
cut_fail();
@ -2754,7 +2773,6 @@ in_rded_with_key(void)
static Int
co_rded(void)
{
DBModule = 0;
return (c_recorded(0));
}
@ -2767,7 +2785,6 @@ in_rdedp(void)
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE, "recorded/3"))) {
if (b0 == B)
cut_fail();
@ -2781,7 +2798,6 @@ in_rdedp(void)
static Int
co_rdedp(void)
{
DBModule = CurrentModule;
return (c_recorded(MkCode));
}
@ -2793,7 +2809,6 @@ p_somercdedp(void)
DBProp AtProp;
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE, "some_recorded/3"))) {
return(FALSE);
}
@ -2823,7 +2838,6 @@ p_first_instance(void)
if (!IsVarTerm(ARG3)) {
cut_fail();
}
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "first_instance/3"))) {
return(FALSE);
}
@ -3121,11 +3135,10 @@ MyEraseClause(Clause *clau)
father = ref->Parent;
if ((arity = father->ArityOfDB) == 0) {
Atom name = (Atom) father->FunctorOfDB;
pred = RepPredProp(PredProp(name, 0));
pred = RepPredProp(PredPropByAtom(name, father->ModuleOfDB));
} else {
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr));
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, father->ModuleOfDB));
}
DBModule = father->ModuleOfDB;
WRITE_LOCK(pred->PRWLock);
if (StillInChain((CODEADDR)(clau->ClCode), pred)) {
if (previous == NIL && next != NIL) {
@ -3315,11 +3328,10 @@ PrepareToEraseClause(Clause *clau, DBRef dbr)
/* inefficient, but that will do for the moment, sir. */
if (father->ArityOfDB == 0) {
Atom name = (Atom) father->FunctorOfDB;
pred = RepPredProp(PredProp(name, 0));
pred = RepPredProp(PredPropByAtom(name, father->ModuleOfDB));
} else {
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr));
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, father->ModuleOfDB));
}
DBModule = father->ModuleOfDB;
WRITE_LOCK(pred->PRWLock);
/* got my pred entry, let's have some fun! */
clau_code = (CODEADDR)(clau->ClCode);
@ -3465,7 +3477,6 @@ p_eraseall(void)
Register DBRef entryref;
DBProp p;
DBModule = 0;
if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, FALSE, "eraseall/3"))) {
return(TRUE);
}
@ -3947,7 +3958,6 @@ p_first_age(void)
Term to;
DBProp AtProp;
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(t1, MkCode, FALSE, "first_age/3"))) {
return(FALSE);
}
@ -3984,7 +3994,6 @@ p_db_nb_to_ref(void)
else if (IsLongIntTerm(t1))
age = LongIntOfTerm(t1);
else return(FALSE);
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(t2, MkCode, FALSE, "recorded/3"))) {
return(FALSE);
}
@ -4024,7 +4033,6 @@ p_last_age(void)
DBProp AtProp;
Term last_age;
DBModule = CurrentModule;
if ((AtProp = FetchDBPropFromKey(t1, MkCode, FALSE, "$last_age/2")) == NIL) {
return(FALSE);
}
@ -4065,7 +4073,6 @@ p_hold_index(void)
DBRef index;
DBModule = CurrentModule;
if (EndOfPAEntr(AtProp = (LogUpdDBProp)FetchDBPropFromKey(Deref(ARG1), MkCode, FALSE, "recorded/3"))) {
return(FALSE);
}
@ -4173,16 +4180,16 @@ InitBackDB(void)
InitCPredBack("recorded", 3, 3, in_rded, co_rded, SyncPredFlag);
/* internal version, just to prevent the debugger from nosying around */
RETRY_C_RECORDED_CODE = NEXTOP((yamop *)
(RepPredProp(PredProp(LookupAtom("recorded"), 3))->FirstClause),lds);
(RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("recorded"), 3),0))->FirstClause),lds);
InitCPredBack("$recorded_with_key", 3, 3, in_rded_with_key, co_rded, SyncPredFlag);
RETRY_C_RECORDED_K_CODE = NEXTOP((yamop *)
(RepPredProp(PredProp(LookupAtom("$recorded_with_key"), 3))->FirstClause),lds);
(RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recorded_with_key"), 3),0))->FirstClause),lds);
InitCPredBack("$recorded", 3, 3, in_rded, co_rded, SyncPredFlag);
RETRY_C_DRECORDED_CODE = NEXTOP((yamop *)
(RepPredProp(PredProp(LookupAtom("$recorded"), 3))->FirstClause),lds);
(RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recorded"), 3),0))->FirstClause),lds);
InitCPredBack("$recordedp", 3, 3, in_rdedp, co_rdedp, SyncPredFlag);
RETRY_C_RECORDEDP_CODE = NEXTOP((yamop *)
(RepPredProp(PredProp(LookupAtom("$recordedp"), 3))->FirstClause),lds);
(RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recordedp"), 3),0))->FirstClause),lds);
InitCPredBack("current_key", 2, 4, init_current_key, cont_current_key,
SyncPredFlag);
}

299
C/exec.c
View File

@ -61,26 +61,28 @@ CallPredicate(PredEntry *pen, choiceptr cut_pt) {
}
inline static Int
CallMetaCall(void) {
CallMetaCall(SMALLUNSGN mod) {
ARG2 = current_cp_as_integer(); /* p_save_cp */
ARG3 = ARG1;
ARG4 = ModuleName[mod];
return (CallPredicate(PredMetaCall, B));
}
Term
ExecuteCallMetaCall(void) {
Term ts[3];
ExecuteCallMetaCall(SMALLUNSGN mod) {
Term ts[4];
ts[0] = ARG1;
ts[1] = current_cp_as_integer(); /* p_save_cp */
ts[2] = ARG1;
return(MkApplTerm(PredMetaCall->FunctorOfPred,3,ts));
ts[3] = ModuleName[mod];
return(MkApplTerm(PredMetaCall->FunctorOfPred,4,ts));
}
static Int
CallError(yap_error_number err)
CallError(yap_error_number err, SMALLUNSGN mod)
{
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCall());
return(CallMetaCall(mod));
} else {
Error(err, ARG1, "call/1");
return(FALSE);
@ -189,42 +191,51 @@ p_save_cp(void)
}
inline static Int
EnterCreepMode(PredEntry *pen) {
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,*CurrentModulePtr));
ARG1 = MkPairTerm(Module_Name((CODEADDR)(pen)),ARG1);
EnterCreepMode(PredEntry *pen, Term t) {
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,0));
ARG1 = MkPairTerm(Module_Name((CODEADDR)(pen)),t);
CreepFlag = CalculateStackGap();
P_before_spy = P;
return (CallPredicate(PredSpy, B));
}
inline static Int
do_execute(Term t)
do_execute(Term t, int mod)
{
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCall());
return(CallMetaCall(mod));
}
restart_exec:
if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR);
return CallError(INSTANTIATION_ERROR, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register CELL *pt;
PredEntry *pen;
unsigned int i, arity;
f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, mod);
}
arity = ArityOfFunctor(f);
pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr));
pen = RepPredProp(PredPropByFunc(f, mod));
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & MetaPredFlag) {
return(CallMetaCall());
if (f == FunctorModule) {
Term tmod = ArgOfTerm(1,t);
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
t = ArgOfTerm(2,t);
goto restart_exec;
}
}
return(CallMetaCall(mod));
}
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
return(EnterCreepMode(pen, t));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
@ -252,16 +263,16 @@ do_execute(Term t)
else if (a == AtomFail || a == AtomFalse)
return(FALSE);
/* call may not define new system predicates!! */
pe = RepPredProp(PredPropByAtom(a, *CurrentModulePtr));
pe = RepPredProp(PredPropByAtom(a, mod));
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pe));
return(EnterCreepMode(pe, t));
}
return (CallPredicate(pe, B));
} else if (IsIntTerm(t)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, mod);
} else {
/* Is Pair Term */
return(CallMetaCall());
return(CallMetaCall(mod));
}
}
@ -269,21 +280,13 @@ static Int
p_execute(void)
{ /* '$execute'(Goal) */
Term t = Deref(ARG1);
return(do_execute(t));
return(do_execute(t, CurrentModule));
}
static Int
p_execute_in_mod(void)
{ /* '$execute'(Goal) */
if (ARG2 != ModuleName[CurrentModule]) {
/* switch modules, but do it in Prolog */
Term ts[2];
ts[0] = ARG2;
ts[1] = ARG1;
ARG1 = MkApplTerm(FunctorModule, 2, ts);
}
return(do_execute(Deref(ARG1)));
return(do_execute(Deref(ARG1), IntOfTerm(ARG2)));
}
inline static Int
@ -292,62 +295,54 @@ CallMetaCallWithin(void)
return (CallPredicate(PredMetaCall, B));
}
/* '$execute_within'(Goal,CutPt,OrigGoal) */
/* '$execute_within'(Goal,CutPt,OrigGoal,Mod) */
static Int
p_execute_within(void)
{
Term t = Deref(ARG1);
Term tmod = Deref(ARG4);
unsigned int arity;
Prop pe;
Atom a;
SMALLUNSGN mod = LookupModule(tmod);
restart_exec:
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCallWithin());
} else if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR);
return CallError(INSTANTIATION_ERROR, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
register CELL *pt;
if (IsExtensionFunctor(f)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, mod);
}
if (f == FunctorModule) {
Term mod = ArgOfTerm(1, t);
if (mod == ModuleName[CurrentModule]) {
/* we can skip this operation */
/* should catch most cases */
t = ArgOfTerm(2, t);
goto restart_exec;
} else {
/* I can't do better because I don't have a way of restoring the module */
return(CallMetaCallWithin());
}
} else {
{
PredEntry *pen;
arity = ArityOfFunctor(f);
a = NameOfFunctor(f);
if (CurrentModule)
pe = PredPropByFunc(f, *CurrentModulePtr);
else {
pe = GetPredPropByFunc(f, *CurrentModulePtr);
if (pe == NIL) {
return(CallMetaCallWithin());
}
}
pe = PredPropByFunc(f, mod);
pen = RepPredProp(pe);
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & MetaPredFlag) {
if (f == FunctorModule) {
Term tmod = ArgOfTerm(1,t);
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
t = ArgOfTerm(2,t);
goto restart_exec;
}
}
return(CallMetaCallWithin());
}
/* at this point check if we should enter creep mode */
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
return(EnterCreepMode(pen,t));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
@ -369,7 +364,7 @@ p_execute_within(void)
}
} else if (IsAtomOrIntTerm(t)) {
if (IsIntTerm(t)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, mod);
}
a = AtomOfTerm(t);
if (a == AtomTrue || a == AtomOtherwise)
@ -401,9 +396,9 @@ p_execute_within(void)
return(FALSE);
} else {
/* call may not define new system predicates!! */
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, mod);
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(RepPredProp(pe)));
return(EnterCreepMode(RepPredProp(pe),t));
}
return (CallPredicate(RepPredProp(pe), B));
}
@ -423,12 +418,12 @@ p_execute_within2(void)
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCallWithin());
} else if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR);
return CallError(INSTANTIATION_ERROR, CurrentModule);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, CurrentModule);
}
{
@ -438,7 +433,7 @@ p_execute_within2(void)
register unsigned int i;
unsigned int arity = ArityOfFunctor(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
pe = PredPropByFunc(f, CurrentModule);
pen = RepPredProp(pe);
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
@ -447,7 +442,7 @@ p_execute_within2(void)
}
/* at this point check if we should enter creep mode */
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
return(EnterCreepMode(pen,t));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
@ -498,13 +493,13 @@ p_execute_within2(void)
return(FALSE);
}
/* call may not define new system predicates!! */
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, CurrentModule);
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(RepPredProp(pe)));
return(EnterCreepMode(RepPredProp(pe),t));
}
return (CallPredicate(RepPredProp(pe), B));
} else if (IsIntTerm(t)) {
return CallError(TYPE_ERROR_CALLABLE);
return CallError(TYPE_ERROR_CALLABLE, CurrentModule);
} else {
/* Is Pair Term */
return(CallMetaCallWithin());
@ -514,14 +509,16 @@ p_execute_within2(void)
static Int
p_execute0(void)
{ /* '$execute'(Goal) */
{ /* '$execute0'(Goal,Mod) */
Term t = Deref(ARG1);
Term tmod = Deref(ARG2);
unsigned int arity;
Prop pe;
SMALLUNSGN mod = LookupModule(tmod);
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
@ -545,7 +542,7 @@ p_execute0(void)
XREGS[i] = *pt++;
#endif
}
pe = GetPredPropByFunc(f, *CurrentModulePtr);
pe = PredPropByFunc(f, mod);
} else
return (FALSE); /* for the moment */
/* N = arity; */
@ -557,11 +554,12 @@ static Int
p_execute_0(void)
{ /* '$execute_0'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG2));
Prop pe;
Atom a;
a = AtomOfTerm(t);
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -569,18 +567,13 @@ static Int
p_execute_1(void)
{ /* '$execute_0'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG3));
Prop pe;
Atom a;
a = AtomOfTerm(t);
ARG1 = ARG2;
if (CurrentModule)
pe = PredProp(a, 1);
else {
pe = GetPredProp(a, 1);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a,1),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -588,19 +581,14 @@ static Int
p_execute_2(void)
{ /* '$execute_2'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG4));
Prop pe;
Atom a;
a = AtomOfTerm(t);
ARG1 = ARG2;
ARG2 = ARG3;
if (CurrentModule)
pe = PredProp(a, 2);
else {
pe = GetPredProp(a, 2);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 2),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -608,6 +596,7 @@ static Int
p_execute_3(void)
{ /* '$execute_3'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG5));
Prop pe;
Atom a;
@ -615,13 +604,7 @@ p_execute_3(void)
ARG1 = ARG2;
ARG2 = ARG3;
ARG3 = ARG4;
if (CurrentModule)
pe = PredProp(a, 3);
else {
pe = GetPredProp(a, 3);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 3),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -629,6 +612,7 @@ static Int
p_execute_4(void)
{ /* '$execute_4'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG6));
Prop pe;
Atom a;
@ -637,13 +621,7 @@ p_execute_4(void)
ARG2 = ARG3;
ARG3 = ARG4;
ARG4 = ARG5;
if (CurrentModule)
pe = PredProp(a, 4);
else {
pe = GetPredProp(a, 4);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 4),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -651,6 +629,7 @@ static Int
p_execute_5(void)
{ /* '$execute_5'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG7));
Prop pe;
Atom a;
@ -660,13 +639,7 @@ p_execute_5(void)
ARG3 = ARG4;
ARG4 = ARG5;
ARG5 = ARG6;
if (CurrentModule)
pe = PredProp(a, 5);
else {
pe = GetPredProp(a, 5);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 5),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -674,6 +647,7 @@ static Int
p_execute_6(void)
{ /* '$execute_6'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG8));
Prop pe;
Atom a;
@ -684,13 +658,7 @@ p_execute_6(void)
ARG4 = ARG5;
ARG5 = ARG6;
ARG6 = ARG7;
if (CurrentModule)
pe = PredProp(a, 6);
else {
pe = GetPredProp(a, 6);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 6),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -698,6 +666,7 @@ static Int
p_execute_7(void)
{ /* '$execute_7'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG9));
Prop pe;
Atom a;
@ -709,13 +678,7 @@ p_execute_7(void)
ARG5 = ARG6;
ARG6 = ARG7;
ARG7 = ARG8;
if (CurrentModule)
pe = PredProp(a, 7);
else {
pe = GetPredProp(a, 7);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 6),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -723,6 +686,7 @@ static Int
p_execute_8(void)
{ /* '$execute_8'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG10));
Prop pe;
Atom a;
@ -735,13 +699,7 @@ p_execute_8(void)
ARG6 = ARG7;
ARG7 = ARG8;
ARG8 = ARG9;
if (CurrentModule)
pe = PredProp(a, 8);
else {
pe = GetPredProp(a, 8);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 8),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -749,6 +707,7 @@ static Int
p_execute_9(void)
{ /* '$execute_9'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG11));
Prop pe;
Atom a;
@ -762,13 +721,7 @@ p_execute_9(void)
ARG7 = ARG8;
ARG8 = ARG9;
ARG9 = ARG10;
if (CurrentModule)
pe = PredProp(a, 9);
else {
pe = GetPredProp(a, 9);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 9),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -776,6 +729,7 @@ static Int
p_execute_10(void)
{ /* '$execute_10'(Goal) */
Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG12));
Prop pe;
Atom a;
@ -790,13 +744,7 @@ p_execute_10(void)
ARG8 = ARG9;
ARG9 = ARG10;
ARG10 = ARG11;
if (CurrentModule)
pe = PredProp(a, 10);
else {
pe = GetPredProp(a, 10);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByFunc(MkFunctor(a, 10),mod);
return (CallPredicate(RepPredProp(pe), B));
}
@ -825,20 +773,36 @@ p_pred_goal_expansion_on(void) {
static Int
p_at_execute(void)
{ /* '$execute'(Goal,ClauseNumber) */
Term t = Deref(ARG1), t2 = Deref(ARG2);
unsigned int arity;
Term t = Deref(ARG1), tmod = Deref(ARG2), t2 = Deref(ARG3);
unsigned int arity;
Prop pe;
Atom a;
SMALLUNSGN mod = LookupModule(tmod);
if (IsAtomTerm(t))
arity = 0, a = AtomOfTerm(t);
else if (IsApplTerm(t)) {
restart_exec:
if (IsAtomTerm(t)) {
a = AtomOfTerm(t);
pe = PredPropByAtom(a, mod);
arity = 0;
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
register CELL *pt;
if (IsBlobFunctor(f))
return(FALSE);
if (f == FunctorModule) {
Term tmod = ArgOfTerm(1,t);
if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
mod = LookupModule(tmod);
t = ArgOfTerm(2,t);
goto restart_exec;
}
if (IsVarTerm(tmod)) {
Error(INSTANTIATION_ERROR, ARG1, "calling clause in debugger");
}
Error(TYPE_ERROR_ATOM, ARG1, "calling clause in debugger");
}
arity = ArityOfFunctor(f);
a = NameOfFunctor(f);
/* I cannot use the standard macro here because
@ -857,19 +821,13 @@ p_at_execute(void)
#else
XREGS[i] = *pt++;
#endif
pe = PredPropByFunc(f,mod);
} else
return (FALSE); /* for the moment */
if (IsVarTerm(t2) || !IsIntTerm(t2))
return (FALSE);
/* N = arity; */
/* call may not define new system predicates!! */
if (CurrentModule) {
pe = PredProp(a, arity);
} else {
pe = GetPredProp(a, arity);
if (pe == NIL)
return(FALSE);
}
return (CallClause(RepPredProp(pe), arity, IntOfTerm(t2)));
}
@ -973,7 +931,6 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
B->cp_depth = DEPTH;
#endif /* DEPTH_LIMIT */
if (top) {
Term t;
#if COROUTINING
RESET_VARIABLE((CELL *)GlobalBase);
DelayedVars = NewTimedVar((CELL)GlobalBase);
@ -981,14 +938,12 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
MutableList = NewTimedVar(TermNil);
AttsMutableList = NewTimedVar(TermNil);
#endif
t = NewTimedVar(MkIntTerm(0));
CurrentModulePtr = RepAppl(t)+1;
}
YENV = ASP = (CELL *)B;
HB = H;
YENV[E_CB] = Unsigned (B);
P = (yamop *) CodeAdr;
S = CellPtr (RepPredProp (PredProp (AtomCall, 1))); /* A1 mishaps */
S = CellPtr (RepPredProp (PredPropByFunc (MkFunctor(AtomCall, 1),0))); /* A1 mishaps */
TopB = B;
return(exec_absmi(top));
@ -996,7 +951,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
Int
execute_goal(Term t, int nargs)
execute_goal(Term t, int nargs, SMALLUNSGN mod)
{
Int out;
CODEADDR CodeAdr;
@ -1021,7 +976,7 @@ execute_goal(Term t, int nargs)
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pt = NULL;
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
@ -1033,31 +988,23 @@ execute_goal(Term t, int nargs)
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
pe = GetPredPropByFunc(f, *CurrentModulePtr);
pe = PredPropByFunc(f, mod);
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
}
ppe = RepPredProp(pe);
if (pe != NIL) {
READ_LOCK(ppe->PRWLock);
}
if (pe == NIL ||
ppe->OpcodeOfPred == UNDEF_OPCODE ||
ppe->PredFlags & (UserCPredFlag|CPredFlag|BasicPredFlag) ) {
if (pe != NIL) {
READ_UNLOCK(ppe->PRWLock);
}
return(CallMetaCall());
if (pe == NIL) {
return(CallMetaCall(mod));
}
READ_LOCK(ppe->PRWLock);
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
CodeAdr = RepPredProp (PredPropByAtom(at, *CurrentModulePtr))->CodeOfPred;
CodeAdr = RepPredProp (pe)->CodeOfPred;
READ_UNLOCK(ppe->PRWLock);
out = do_goal(CodeAdr, 0, pt, nargs, FALSE);
} else {
Functor f = FunctorOfTerm(t);
CodeAdr = RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->CodeOfPred;
CodeAdr = RepPredProp (pe)->CodeOfPred;
READ_UNLOCK(ppe->PRWLock);
out = do_goal(CodeAdr, ArityOfFunctor(f), pt, nargs, FALSE);
}
@ -1181,7 +1128,7 @@ RunTopGoal(Term t)
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pt = NULL;
pe = PredPropByAtom(a, *CurrentModulePtr);
pe = PredPropByAtom(a, CurrentModule);
arity = 0;
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
@ -1193,7 +1140,7 @@ RunTopGoal(Term t)
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
pe = GetPredPropByFunc(f, *CurrentModulePtr);
pe = GetPredPropByFunc(f, CurrentModule);
pt = RepAppl(t)+1;
arity = ArityOfFunctor(f);
} else {
@ -1325,10 +1272,10 @@ InitExecFs(void)
{
InitCPred("$execute", 1, p_execute, 0);
InitCPred("$execute_in_mod", 2, p_execute_in_mod, 0);
InitCPred("$execute_within", 3, p_execute_within, 0);
InitCPred("$execute_within", 4, p_execute_within, 0);
InitCPred("$execute_within", 1, p_execute_within2, 0);
InitCPred("$last_execute_within", 1, p_execute_within2, 0);
InitCPred("$execute", 2, p_at_execute, 0);
InitCPred("$execute", 3, p_at_execute, 0);
InitCPred("$call_with_args", 1, p_execute_0, 0);
InitCPred("$call_with_args", 2, p_execute_1, 0);
InitCPred("$call_with_args", 3, p_execute_2, 0);
@ -1343,7 +1290,7 @@ InitExecFs(void)
#ifdef DEPTH_LIMIT
InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0);
#endif
InitCPred("$execute0", 1, p_execute0, 0);
InitCPred("$execute0", 2, p_execute0, 0);
InitCPred("$save_current_choice_point", 1, p_save_cp, 0);
InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag);
InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag);

4
C/grow.c
View File

@ -142,8 +142,6 @@ SetHeapRegs(void)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
}
static void
@ -182,8 +180,6 @@ SetStackRegs(void)
YENV = PtoLocAdjust(YENV);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
}
static void

2
C/heapgc.c
View File

@ -359,7 +359,6 @@ push_registers(Int num_regs, yamop *nextop)
TrailTerm(TR+3) = DelayedVars;
TR += 4;
#endif
TrailTerm(TR++) = AbsAppl(CurrentModulePtr-1);
for (i = 1; i <= num_regs; i++)
TrailTerm(TR++) = (CELL) XREGS[i];
/* push any live registers we might have hanging around */
@ -403,7 +402,6 @@ pop_registers(Int num_regs, yamop *nextop)
DelayedVars = TrailTerm(ptr++);
#endif
#endif
CurrentModulePtr = RepAppl(TrailTerm(ptr++))+1;
for (i = 1; i <= num_regs; i++)
XREGS[i] = TrailTerm(ptr++);
/* pop any live registers we might have hanging around */

48
C/init.c
View File

@ -169,8 +169,6 @@ sigjmp_buf RestartEnv; /* used to restart after an abort execution */
CPredicate c_predicates[MAX_C_PREDS];
cmp_entry cmp_funcs[MAX_CMP_FUNCS];
static CELL InitModuleAddress;
/************** declarations local to init.c ************************/
static char *optypes[] =
{"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"};
@ -511,9 +509,13 @@ void
InitCPred(char *Name, int Arity, CPredicate code, int flags)
{
Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
PredEntry *pe;
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
if (Arity)
pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
@ -528,7 +530,6 @@ InitCPred(char *Name, int Arity, CPredicate code, int flags)
p_code->opc = opcode(_procceed);
{
Term mod = CurrentModule;
if (mod) mod = MkIntTerm(mod);
pe->ModuleOfPred = mod;
}
if (!(flags & UserCPredFlag)) {
@ -542,12 +543,17 @@ void
InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int flags)
{
Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
PredEntry *pe;
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
if (Arity)
pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
pe->ModuleOfPred = CurrentModule;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize);
@ -567,14 +573,19 @@ void
InitAsmPred(char *Name, int Arity, int code, CPredicate def, int flags)
{
Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
PredEntry *pe;
if (Arity)
pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
pe->PredFlags = flags | StandardPredFlag | (code);
if (def != NULL) {
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) def;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
pe->ModuleOfPred = CurrentModule;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize);
@ -634,7 +645,10 @@ InitCPredBack(char *Name, int Arity, int Extra, CPredicate Start, CPredicate Con
PredEntry *pe;
Atom atom = LookupAtom(Name);
pe = RepPredProp(PredProp(atom, Arity));
if (Arity)
pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
if (pe->FirstClause != NIL)
CleanBack(pe, Start, Cont);
else {
@ -753,11 +767,11 @@ InitCodes(void)
heap_regs->seq_def = TRUE;
heap_regs->getworkfirsttimecode.opc = opcode(_getwork_first_time);
heap_regs->getworkcode.opc = opcode(_getwork);
heap_regs->getworkcode.u.ld.p = (CODEADDR)RepPredProp(PredProp(LookupAtom("$getwork"), 0));
heap_regs->getworkcode.u.ld.p = (CODEADDR)RepPredProp(PredPropByAtom(LookupAtom("$getwork"), 0));
INIT_YAMOP_LTT(&(heap_regs->getworkcode), 0);
heap_regs->getworkcode_seq.opc = opcode(_getwork_seq);
INIT_YAMOP_LTT(&(heap_regs->getworkcode_seq), 0);
heap_regs->getworkcode_seq.u.ld.p = (CODEADDR)RepPredProp(PredProp(LookupAtom("$getwork_seq"), 0));
heap_regs->getworkcode_seq.u.ld.p = (CODEADDR)RepPredProp(PredPropByAtom(LookupAtom("$getwork_seq"), 0));
#endif /* YAPOR */
#ifdef TABLING
heap_regs->tablecompletioncode.opc = opcode(_table_completion);
@ -970,7 +984,6 @@ InitCodes(void)
heap_regs->functor_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1);
heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1);
heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_module"), 1);
heap_regs->functor_mod_switch = MkFunctor (LookupAtom("$mod_switch"), 2);
heap_regs->functor_u_minus = MkFunctor (heap_regs->atom_minus, 1);
heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1);
heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2);
@ -986,12 +999,16 @@ InitCodes(void)
heap_regs->yap_lib_dir = NULL;
heap_regs->size_of_overflow = 0;
/* make sure no one else can use these two atoms */
*CurrentModulePtr = MkIntTerm(1);
heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),MkIntTerm(1)));
*CurrentModulePtr = MkIntTerm(0);
heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),1));
CurrentModule = 0;
heap_regs->dead_clauses = NULL;
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,3),MkIntTerm(0)));
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,4),0));
ReleaseAtom(AtomOfTerm(heap_regs->term_refound_var));
{
/* make sure we know about the module predicate */
PredEntry *modp = RepPredProp(PredPropByFunc(heap_regs->functor_module,0));
modp->PredFlags |= MetaPredFlag;
}
}
static void
@ -1032,7 +1049,7 @@ InitYaamRegs(void)
#endif
at = FullLookupAtom("$undefp");
{
Prop p = GetPredProp (at, 1);
Prop p = GetPredPropByFunc(MkFunctor(at, 1),0);
if (p == NIL) {
UndefCode = NULL;
} else {
@ -1116,7 +1133,6 @@ InitStacks(int Heap,
/* the emulator will eventually copy them to its own local
register array, but for now they exist */
#endif /* PUSH_REGS */
CurrentModulePtr = &InitModuleAddress;
/* Init signal handling and time */
/* also init memory page size, required by later functions */

6
C/load_foreign.c
View File

@ -121,17 +121,17 @@ void
ReOpenLoadForeign(void)
{
ForeignObj *f_code = ForeignCodeLoaded;
int OldModule = CurrentModule;
SMALLUNSGN OldModule = CurrentModule;
YapInitProc InitProc = NULL;
while (f_code != NULL) {
*CurrentModulePtr = MkIntTerm(f_code->module);
CurrentModule = f_code->module;
if(ReLoadForeign(f_code->objs,f_code->libs,f_code->f,&InitProc)==LOAD_SUCCEEDED) {
(*InitProc)();
}
f_code = f_code->next;
}
*CurrentModulePtr = MkIntTerm(OldModule);
CurrentModule = OldModule;
}

18
C/modules.c
View File

@ -42,8 +42,6 @@ Module_Name(CODEADDR cap)
*/
return(ModuleName[CurrentModule]);
else {
if (ap->ModuleOfPred)
return (ModuleName[IntOfTerm(ap->ModuleOfPred)]);
return (ModuleName[ap->ModuleOfPred]);
}
}
@ -73,10 +71,10 @@ p_current_module(void)
return (0);
for (i = 0; i < NoOfModules; ++i)
if (ModuleName[i] == t) {
*CurrentModulePtr = MkIntTerm(i);
CurrentModule = i;
return (TRUE);
}
*CurrentModulePtr = MkIntTerm(NoOfModules);
CurrentModule = NoOfModules;
ModuleName[NoOfModules++] = t;
return (TRUE);
}
@ -92,8 +90,8 @@ p_current_module1(void)
static Int
p_change_module(void)
{ /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1)));
UpdateTimedVar(AbsAppl(CurrentModulePtr-1), t);
SMALLUNSGN mod = LookupModule(Deref(ARG1));
CurrentModule = mod;
return (TRUE);
}
@ -101,7 +99,9 @@ static Int
p_module_number(void)
{ /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1)));
return (unify(ARG2,t));
unify(t,ARG2);
ARG2 = t;
return(TRUE);
}
void
@ -109,10 +109,10 @@ InitModules(void)
{
ModuleName[PrimitivesModule = 0] =
MkAtomTerm(LookupAtom("prolog"));
*CurrentModulePtr = MkIntTerm(0);
CurrentModule = 0;
ModuleName[1] = MkAtomTerm(LookupAtom("user"));
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag);
InitCPred("$module_number", 2, p_module_number, SafePredFlag|SyncPredFlag);
InitCPred("$module_number", 2, p_module_number, SafePredFlag);
}

7
C/save.c
View File

@ -377,7 +377,7 @@ save_regs(int mode)
putcellptr((CELL *)TopB);
putcellptr((CELL *)DelayedB);
putout(FlipFlop);
putcellptr(CurrentModulePtr);
putout(CurrentModule);
#ifdef COROUTINING
putout(DelayedVars);
#endif
@ -672,7 +672,7 @@ get_regs(int flag)
TopB = (choiceptr)get_cellptr();
DelayedB = (choiceptr)get_cellptr();
FlipFlop = get_cell();
CurrentModulePtr = get_cellptr();
CurrentModule = get_cell();
#ifdef COROUTINING
DelayedVars = get_cell();
#endif
@ -1097,7 +1097,6 @@ restore_codes(void)
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
heap_regs->functor_change_module = FuncAdjust(heap_regs->functor_change_module);
heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_module);
heap_regs->functor_mod_switch = FuncAdjust(heap_regs->functor_mod_switch);
heap_regs->functor_u_minus = FuncAdjust(heap_regs->functor_u_minus);
heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus);
heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar);
@ -1164,8 +1163,6 @@ restore_regs(int flag)
HeapPlus = AddrAdjust(HeapPlus);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
#ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
#ifdef MULTI_ASSIGNMENT_VARIABLES

55
C/stdpreds.c
View File

@ -140,7 +140,7 @@ p_flipflop(void)
PredEntry *pred;
at = FullLookupAtom("$spy");
pred = RepPredProp(PredProp(at, 1));
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
SpyCode = pred;
return ((int) (FlipFlop = (1 - FlipFlop)));
}
@ -164,7 +164,7 @@ p_creep(void)
PredEntry *pred;
at = FullLookupAtom("$creep");
pred = RepPredProp(PredProp(at, 1));
pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
CreepCode = pred;
CreepFlag = Unsigned(LCL0)-Unsigned(H0);
return (TRUE);
@ -1362,26 +1362,29 @@ init_current_atom(void)
static Int
cont_current_predicate(void)
{
PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(2,1));
PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(3,1));
UInt Arity;
Atom name;
if (pp == NULL)
cut_fail();
EXTRA_CBACK_ARG(2,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule));
EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule));
Arity = pp->ArityOfPE;
if (Arity)
name = NameOfFunctor(pp->FunctorOfPred);
else
name = (Atom)pp->FunctorOfPred;
return (unify(ARG1,MkAtomTerm(name)) &&
unify(ARG2, MkIntegerTerm(Arity)));
return (unify(ARG2,MkAtomTerm(name)) &&
unify(ARG3, MkIntegerTerm(Arity)));
}
static Int
init_current_predicate(void)
{
EXTRA_CBACK_ARG(2,1) = (CELL)MkIntegerTerm((Int)ModulePred[CurrentModule]);
Term t1 = Deref(ARG1);
if (IsVarTerm(t1) || !IsAtomTerm(t1)) cut_fail();
EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)ModulePred[LookupModule(t1)]);
return (cont_current_predicate());
}
@ -1555,43 +1558,51 @@ p_debug()
static Int
p_flags(void)
{ /* $flags(+Functor,?OldFlags,?NewFlags) */
{ /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */
PredEntry *pe;
Int newFl;
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
int mod;
if (IsVarTerm(t1))
return (FALSE);
if (!IsAtomTerm(t2)) {
return(FALSE);
}
mod = LookupModule(t2);
if (IsVarTerm(t1))
return (FALSE);
if (IsAtomTerm(t1)) {
pe = RepPredProp(PredProp(AtomOfTerm(t1), 0));
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod));
} else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1);
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
pe = RepPredProp(PredPropByFunc(funt, mod));
} else
return (FALSE);
if (EndOfPAEntr(pe))
return (FALSE);
WRITE_LOCK(pe->PRWLock);
if (!unify_constant(ARG2, MkIntTerm(pe->PredFlags))) {
if (!unify_constant(ARG3, MkIntTerm(pe->PredFlags))) {
WRITE_UNLOCK(pe->PRWLock);
return(FALSE);
}
ARG3 = Deref(ARG3);
if (IsVarTerm(ARG3)) {
ARG4 = Deref(ARG4);
if (IsVarTerm(ARG4)) {
WRITE_UNLOCK(pe->PRWLock);
return (TRUE);
} else if (!IsIntTerm(ARG3)) {
} else if (!IsIntTerm(ARG4)) {
union arith_ret v;
if (Eval(ARG3, &v) == long_int_e) {
if (Eval(ARG4, &v) == long_int_e) {
newFl = v.Int;
} else {
WRITE_UNLOCK(pe->PRWLock);
Error(TYPE_ERROR_INTEGER, ARG3, "flags");
Error(TYPE_ERROR_INTEGER, ARG4, "flags");
return(FALSE);
}
} else
newFl = IntOfTerm(ARG3);
newFl = IntOfTerm(ARG4);
pe->PredFlags = (SMALLUNSGN) newFl;
WRITE_UNLOCK(pe->PRWLock);
return (TRUE);
@ -2005,10 +2016,10 @@ p_set_yap_flags(void)
if (value < 0 || value > 2)
return(FALSE);
if (value == 1) {
heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,4));
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0));
set_fpu_exceptions(TRUE);
} else {
heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,3));
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0));
set_fpu_exceptions(FALSE);
}
yap_flags[LANGUAGE_MODE_FLAG] = value;
@ -2073,7 +2084,7 @@ InitBackCPreds(void)
{
InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom,
SafePredFlag|SyncPredFlag);
InitCPredBack("$current_predicate", 2, 1, init_current_predicate, cont_current_predicate,
InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate,
SafePredFlag|SyncPredFlag);
InitCPredBack("current_op", 3, 3, init_current_op, cont_current_op,
SafePredFlag|SyncPredFlag);
@ -2134,7 +2145,7 @@ InitCPreds(void)
InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag);
#endif
/* Accessing and changing the flags for a predicate */
InitCPred("$flags", 3, p_flags, SafePredFlag|SyncPredFlag);
InitCPred("$flags", 4, p_flags, SafePredFlag|SyncPredFlag);
/* hiding and unhiding some predicates */
InitCPred("hide", 1, p_hide, SafePredFlag|SyncPredFlag);
InitCPred("unhide", 1, p_unhide, SafePredFlag|SyncPredFlag);

2
C/tracer.c
View File

@ -133,7 +133,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
/* if (vsc_count < 24) return; */
/* if (vsc_count > 500000) exit(0); */
/* if (gc_calls < 1) return;*/
YP_fprintf(YP_stderr,"%lu %p (%d)", vsc_count, B, CurrentModule);
YP_fprintf(YP_stderr,"%lu (%d)", vsc_count, CurrentModule);
/* check_trail_consistency(); */
if (pred == NULL) {
return;

4
C/write.c
View File

@ -379,7 +379,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
Term targs[1];
targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
execute_goal(MkApplTerm(FunctorPortray, 1, targs), 0, 1);
Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return;
@ -456,7 +456,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
Term targs[1];
targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0, 1);
Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return;

8
CHR/Makefile.in
View File

@ -88,9 +88,9 @@ install: $(CHR_TOP) $(CHR_LICENSE) $(CHR_PROGRAMS) $(CHR_EXAMPLES)
-mkdir $(DESTDIR)$(LIBDIR)/library
-mkdir $(DESTDIR)$(LIBDIR)/library/chr
-mkdir $(DESTDIR)$(LIBDIR)/library/chr/examples
$(INSTALL_DATA) $(CHR_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CHR_LICENSE) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CHR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/chr
$(INSTALL_DATA) $(CHR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/chr/examples
for h in $(CHR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
for h in $(CHR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
for h in $(CHR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/chr; done
for h in $(CHR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/chr/examples; done

34
CLPQR/Makefile.in
View File

@ -27,7 +27,6 @@ CLPQR_PROGRAMS= $(srcdir)/clpqr/arith.pl \
$(srcdir)/clpqr/fourmotz.pl \
$(srcdir)/clpqr/ineq.yap \
$(srcdir)/clpqr/itf3.pl \
$(srcdir)/clpqr/nf.yap \
$(srcdir)/clpqr/ordering.yap \
$(srcdir)/clpqr/project.pl \
$(srcdir)/clpqr/redund.pl \
@ -38,19 +37,21 @@ CLPQR_LOCAL= \
$(srcdir)/clpqr/monash.pl \
$(srcdir)/clpqr/printf.pl
CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.pl \
$(srcdir)/clpr/class.pl\
CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.yap \
$(srcdir)/clpr/class.yap\
$(srcdir)/clpr/geler.yap \
$(srcdir)/clpr/nf.yap \
$(srcdir)/clpr/nfr.yap
CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.pl \
$(srcdir)/clpq/class.pl\
CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.yap \
$(srcdir)/clpq/class.yap \
$(srcdir)/clpq/geler.yap \
$(srcdir)/clpr/nf.yap \
$(srcdir)/clpq/nfq.yap
CLPR_TOP= $(srcdir)/clpr.yap
CLPQ_TOP= $(srcdir)/clpq.pl
CLPQ_TOP= $(srcdir)/clpq.yap
CLPQR_LICENSE= $(srcdir)/CLPQR.LICENSE
@ -135,16 +136,15 @@ install: $(CLPR_TOP) $(CLPQ_TOP) $(CLPQR_LICENSE) $(CLPQR_PROGRAMS) $(CLPQR_LOCA
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash
$(INSTALL_DATA) $(CLPQ_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPR_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPQR_LICENSE) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq
$(INSTALL_DATA) $(CLPQ_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr
$(INSTALL_DATA) $(CLPR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr
$(INSTALL_DATA) $(CLPQR_LOCAL) $(DESTDIR)$(LIBDIR)/library/clpqr
$(INSTALL_DATA) $(CLPQR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/clpqr/examples
$(INSTALL_DATA) $(CLPQR_EXAMPLES_MONASH) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash
$(INSTALL_DATA) $(CLPQR_EXAMPLES_SESSION) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION
for h in $(CLPQ_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
for h in $(CLPR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
for h in $(CLPQR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
for h in $(CLPQR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done
for h in $(CLPQ_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpq; done
for h in $(CLPR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpr; done
for h in $(CLPQR_LOCAL); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done
for h in $(CLPQR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples; done
for h in $(CLPQR_EXAMPLES_MONASH); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash; done
for h in $(CLPQR_EXAMPLES_SESSION); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION; done

2
CLPQR/clpq/nfq.yap
View File

@ -43,7 +43,7 @@
solve/1
]).
:- ensure_loaded( nf).
:- ensure_loaded(nf).
transg( resubmit_eq(Nf)) -->
{

20
CLPQR/clpqr/bv.yap
View File

@ -75,7 +75,7 @@
% ----------------------------------- deref ------------------------------------ %
:- mode deref( +, -).
%:- mode deref( +, -).
%
deref( Lin, Lind) :-
split( Lin, H, I),
@ -84,7 +84,7 @@ deref( Lin, Lind) :-
log_deref( Len, H, [], Restd),
add_linear_11( Nonvar, Restd, Lind).
:- mode log_deref( +, +, -, -).
%:- mode log_deref( +, +, -, -).
%
log_deref( 0, Vs, Vs, Lin) :- !,
arith_eval( 0, Z),
@ -126,9 +126,11 @@ lin_deref( [v(K,[X^1])|Vs], Li, Lo) :-
%
% If we see a nonvar here, this is a fault
%
deref_var( X, Lin) :-
get_atts( X, lin(Lin)), !.
deref_var( X, Lin) :- % create a linear var
deref_var( X, Lin) :- % create a linear var
arith_eval( 0, Z),
arith_eval( 1, One),
Lin = [Z,Z,X*One],
@ -513,7 +515,7 @@ ub( X, Ub) :-
basis( X, Deps),
ub_first( Deps, X, Ub).
:- mode ub_first( +, ?, -).
%:- mode ub_first( +, ?, -).
%
ub_first( [Dep|Deps], X, Tightest) :-
( get_atts( Dep, [lin(Lin),type(Type)]),
@ -527,7 +529,7 @@ ub_first( [Dep|Deps], X, Tightest) :-
%
% Invariant: Ub >= 0 and decreasing
%
:- mode ub( +, ?, +, -).
%:- mode ub( +, ?, +, -).
%
ub( [], _, T0,T0).
ub( [Dep|Deps], X, T0,T1) :-
@ -545,7 +547,7 @@ lb( X, Lb) :-
basis( X, Deps),
lb_first( Deps, X, Lb).
:- mode lb_first( +, ?, -).
%:- mode lb_first( +, ?, -).
%
lb_first( [Dep|Deps], X, Tightest) :-
( get_atts( Dep, [lin(Lin),type(Type)]),
@ -559,7 +561,7 @@ lb_first( [Dep|Deps], X, Tightest) :-
%
% Invariant: Lb =< 0 and increasing
%
:- mode lb( +, ?, +, -).
%:- mode lb( +, ?, +, -).
%
lb( [], _, T0,T0).
lb( [Dep|Deps], X, T0,T1) :-
@ -576,7 +578,7 @@ lb( [Dep|Deps], X, T0,T1) :-
%
% Lb =< 0 for feasible rows
%
:- mode lb_inner( +, ?, +, -, -).
%:- mode lb_inner( +, ?, +, -, -).
%
lb_inner( t_l(L), X, Lin, t_L(L), Lb) :-
nf_rhs_x( Lin, X, Rhs, K),
@ -602,7 +604,7 @@ lb_inner( t_lu(L,U), X, Lin, W, Lb) :-
%
% Ub >= 0 for feasible rows
%
:- mode ub_inner( +, ?, +, -, -).
%:- mode ub_inner( +, ?, +, -, -).
%
ub_inner( t_l(L), X, Lin, t_L(L), Ub) :-
nf_rhs_x( Lin, X, Rhs, K),

1
CLPQR/clpqr/expand.yap
View File

@ -195,3 +195,4 @@ l2conj( [X|Xs], Conj) :-
( Xs = [], Conj = X
; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc)
).

2
CLPQR/clpqr/monash.pl
View File

@ -24,4 +24,4 @@
:- prolog_flag( unknown, _, fail).
dump. % cheating
dump( L) :- ordering( L).
dump( L) :- ordering( L).

1
CLPQR/clpr.pl
View File

@ -58,3 +58,4 @@ this_linear_solver( clpr).
'clpr/bb',
'clpr/dump'
]).

22
CLPQR/clpr.yap
View File

@ -10,9 +10,9 @@
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- sequential.
% :- sequential.
:- default_sequential(X), write(X), nl.
% :- default_sequential(X), write(X), nl.
:- module( clpr, [
{}/1,
@ -43,8 +43,8 @@ this_linear_solver( clpr).
:- ensure_loaded(
[
'clpr/itf3',
'clpr/store' % early because of macros
'clpqr/itf3',
'clpqr/store' % early because of macros
% but after itf3
]).
@ -54,11 +54,11 @@ this_linear_solver( clpr).
:- ensure_loaded(
[
'clpr/project',
'clpr/bv',
'clpr/ineq',
'clpr/redund',
'clpr/fourmotz',
'clpr/bb',
'clpr/dump'
'clpqr/project',
'clpqr/bv',
'clpqr/ineq',
'clpqr/redund',
'clpqr/fourmotz',
'clpqr/bb',
'clpqr/dump'
]).

1
CLPQR/clpr/arith_r.pl
View File

@ -31,6 +31,7 @@ arith_module( nfr).
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion(arith_eval(Term,Res), Module, Expansion) :-
arith_module( Module),
compile_R( Term, Res, Code),

1
CLPQR/clpr/class.pl
View File

@ -110,3 +110,4 @@ delete_first( [Y|Ys], X, Res) :-
Res = [Y|Tail],
delete_first( Ys, X, Tail)
).

1
CLPQR/clpr/geler.yap
View File

@ -114,6 +114,7 @@ run( Mutex, G) :- var(Mutex), Mutex=done, call( G).
:- meta_predicate geler(+,:).
%
geler( Vars, Goal) :-
attach( Vars, run(_Mutex,Goal)).

3
CLPQR/clpr/nfr.yap
View File

@ -10,7 +10,6 @@
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module( nfr,
[
{}/1,
@ -43,7 +42,7 @@
solve/1
]).
:- ensure_loaded( nf).
:- ensure_loaded(nf).
transg( resubmit_eq(Nf)) -->
{

7
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.12 2001-10-31 20:16:48 vsc Exp $ *
* version: $Id: Heap.h,v 1.13 2001-11-15 00:01:40 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -97,7 +97,7 @@ typedef struct various_codes {
Term mutable_list;
Term atts_mutable_list;
#endif
CELL *wake_up_code;
PredEntry *wake_up_code;
#endif
struct pred_entry *creep_code;
struct pred_entry *undef_code;
@ -253,7 +253,6 @@ typedef struct various_codes {
functor_stream_eOS,
functor_change_module,
functor_current_module,
functor_mod_switch,
functor_u_minus,
functor_u_plus,
functor_v_bar,
@ -295,8 +294,6 @@ typedef struct various_codes {
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */
#define FAILCODE ((CODEADDR)&(heap_regs->failcode ))
#define FAILCODE ((CODEADDR)&(heap_regs->failcode ))
#define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode ))
#define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode ))
#define YESCODE ((CODEADDR)&(heap_regs->yescode ))
#define NOCODE ((CODEADDR)&(heap_regs->nocode ))

7
H/Regs.h
View File

@ -10,7 +10,7 @@
* File: Regs.h *
* mods: *
* comments: YAP abstract machine registers *
* version: $Id: Regs.h,v 1.5 2001-09-24 18:07:16 vsc Exp $ *
* version: $Id: Regs.h,v 1.6 2001-11-15 00:01:43 vsc Exp $ *
*************************************************************************/
@ -96,7 +96,7 @@ typedef struct
Term TermNil_; /* 20 */
#endif
#endif
CELL *CurrentModulePtr_;
SMALLUNSGN CurrentModulePtr_;
#if (defined(YAPOR) && defined(SBA)) || defined(TABLING)
CELL *H_FZ_;
choiceptr B_FZ_;
@ -639,8 +639,7 @@ EXTERN inline void restore_B(void) {
#ifdef COROUTINING
#define DelayedVars REGS.DelayedVars_
#endif
#define CurrentModulePtr REGS.CurrentModulePtr_
#define CurrentModule IntOfTerm(*REGS.CurrentModulePtr_)
#define CurrentModule REGS.CurrentModulePtr_
#define REG_SIZE sizeof(REGS)/sizeof(CELL *)

21
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.4 2001-10-30 16:42:05 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.5 2001-11-15 00:01:43 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -36,8 +36,8 @@ Atom STD_PROTO(LookupAtom,(char *));
Atom STD_PROTO(FullLookupAtom,(char *));
void STD_PROTO(LookupAtomWithAddress,(char *,AtomEntry *));
Term STD_PROTO(MkApplTerm,(Functor,unsigned int,Term *));
Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, Term));
Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, Term));
Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, SMALLUNSGN));
Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, SMALLUNSGN));
Functor STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int));
Functor STD_PROTO(MkFunctor,(Atom,unsigned int));
void STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *));
@ -53,10 +53,9 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term));
#endif
int STD_PROTO(LookupModule,(Term));
Prop STD_PROTO(GetPredProp,(Atom,unsigned int));
Prop STD_PROTO(GetPredPropByAtom,(Atom, Term));
Prop STD_PROTO(GetPredPropByFunc,(Functor, Term));
Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int));
Prop STD_PROTO(GetPredPropByAtom,(Atom, int));
Prop STD_PROTO(GetPredPropByFunc,(Functor, int));
Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int,SMALLUNSGN));
Prop STD_PROTO(GetExpProp,(Atom,unsigned int));
Prop STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int));
Term STD_PROTO(Module_Name, (CODEADDR));
@ -120,7 +119,7 @@ int STD_PROTO(iequ,(Term,Term));
void STD_PROTO(InitCmpPreds,(void));
/* compiler.c */
CODEADDR STD_PROTO(cclause,(Term, int));
CODEADDR STD_PROTO(cclause,(Term, int, int));
/* computils.c */
@ -149,10 +148,10 @@ void STD_PROTO(InitEval,(void));
Int STD_PROTO(EvFArt,(Term));
/* exec.c */
Term STD_PROTO(ExecuteCallMetaCall,(void));
Term STD_PROTO(ExecuteCallMetaCall,(SMALLUNSGN mod));
void STD_PROTO(InitExecFs,(void));
int STD_PROTO(RunTopGoal,(Term));
Int STD_PROTO(execute_goal,(Term, int));
Int STD_PROTO(execute_goal,(Term, int, SMALLUNSGN));
int STD_PROTO(exec_absmi,(int));
@ -278,7 +277,7 @@ void STD_PROTO(InitUtilCPreds,(void));
/* yap.c */
void STD_PROTO(Abort,(char *msg, ...));
void STD_PROTO(addclause,(Term,CODEADDR,int));
void STD_PROTO(addclause,(Term,CODEADDR,int,int));
/* ypsocks.c */
void STD_PROTO(InitSockets,(void));

2
H/compile.h
View File

@ -250,7 +250,7 @@ void STD_PROTO(emit,(compiler_vm_op,Int,CELL));
void STD_PROTO(emit_3ops,(compiler_vm_op,CELL,CELL,CELL));
CELL *STD_PROTO(emit_extra_size,(compiler_vm_op,CELL,int));
char *STD_PROTO(AllocCMem,(int));
int STD_PROTO(is_a_test_pred,(Term));
int STD_PROTO(is_a_test_pred,(Term, SMALLUNSGN));
void STD_PROTO(bip_name,(Int, char *));
#ifdef DEBUG
void STD_PROTO(ShowCode,(void));

2
Makefile.in
View File

@ -9,7 +9,7 @@ BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/
LIBDIR=$(ROOTDIR)/lib
YAPLIBDIR=$(ROOTDIR)/lib/Yap
#
# where the includes should be stored

77
OPTYap/opt.preds.c
View File

@ -79,9 +79,9 @@ void init_optyap_preds(void) {
InitCPred("$parallel_yes_answer", 0, p_parallel_yes_answer, SafePredFlag);
#endif /* YAPOR */
#ifdef TABLING
InitCPred("$table", 1, p_table, SafePredFlag);
InitCPred("$abolish_trie", 1, p_abolish_trie, SafePredFlag);
InitCPred("$show_trie", 2, p_show_trie, SafePredFlag);
InitCPred("$table", 2, p_table, SafePredFlag);
InitCPred("$do_abolish_trie", 2, p_abolish_trie, SafePredFlag);
InitCPred("$show_trie", 3, p_show_trie, SafePredFlag);
#endif /* TABLING */
#ifdef STATISTICS
InitCPred("show_frames", 0, p_show_frames, SafePredFlag);
@ -183,25 +183,31 @@ int start_yapor(void) {
static
int p_sequential(void) {
Term t;
Term t, tmod;
Atom at;
int arity;
PredEntry *pe;
SMALLUNSGN mod;
t = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return(FALSE);
}
mod = LookupModule(tmod);
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
arity = 0;
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func);
arity = ArityOfFunctor(func);
pe = RepPredProp(PredPropByFunc(func, mod));
} else {
abort_optyap("unknown term in function p_sequential");
at = NULL; /* just to avoid gcc warning */
arity = 0; /* just to avoid gcc warning */
return(FALSE);
}
pe = RepPredProp(PredProp(at, arity));
pe->PredFlags |= SequentialPredFlag;
return (TRUE);
}
@ -449,25 +455,28 @@ void answer_to_stdout(char *answer) {
#ifdef TABLING
static
int p_table(void) {
Term t;
Atom at;
int arity;
Term t, t2;
PredEntry *pe;
tab_ent_ptr te;
sg_node_ptr sg_node;
SMALLUNSGN mod;
t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return (FALSE);
} else {
mod = LookupModule(t2);
}
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
arity = 0;
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func);
arity = ArityOfFunctor(func);
pe = RepPredProp(PredPropByFunc(func, mod));
} else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
pe->PredFlags |= TabledPredFlag;
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL);
new_table_entry(te, sg_node);
@ -479,25 +488,31 @@ int p_table(void) {
static
int p_abolish_trie(void) {
Term t;
Atom at;
int arity;
Term t, tmod;
SMALLUNSGN mod;
tab_ent_ptr tab_ent;
sg_hash_ptr hash;
sg_node_ptr sg_node;
UInt arity;
t = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return (FALSE);
} else {
mod = LookupModule(tmod);
}
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
Atom at = AtomOfTerm(t);
tab_ent = RepPredProp(PredPropByAtom(at, mod))->TableOfPred;
arity = 0;
} else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func);
tab_ent = RepPredProp(PredPropByFunc(func, mod))->TableOfPred;
arity = ArityOfFunctor(func);
} else
return (FALSE);
tab_ent = RepPredProp(PredProp(at, arity))->TableOfPred;
hash = TabEnt_hash_chain(tab_ent);
TabEnt_hash_chain(tab_ent) = NULL;
free_subgoal_hash_chain(hash);
@ -513,24 +528,32 @@ int p_abolish_trie(void) {
static
int p_show_trie(void) {
Term t1, t2;
Atom at;
int arity;
Term t1, t2, tmod;
PredEntry *pe;
SMALLUNSGN mod;
Atom at;
UInt arity;
t1 = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return (FALSE);
} else {
mod = LookupModule(tmod);
}
if (IsAtomTerm(t1)) {
at = AtomOfTerm(t1);
arity = 0;
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t1)) {
Functor func = FunctorOfTerm(t1);
at = NameOfFunctor(func);
arity = ArityOfFunctor(func);
pe = RepPredProp(PredPropByFunc(func, mod));
} else
return(FALSE);
pe = RepPredProp(PredProp(at, arity));
return (FALSE);
t2 = Deref(ARG2);
t2 = Deref(ARG3);
if (IsVarTerm(t2)) {
Term ta = MkAtomTerm(LookupAtom("stdout"));
Bind((CELL *)t2, ta);

4
library/atts.yap
View File

@ -134,7 +134,7 @@ do_verify_attributes([], _, _, []).
do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :-
existing_attribute(_,Mod,Key),
get_att(AttVar,Key,_),
Mod:current_predicate(verify_attributes, verify_attributes(_,_,_)), !,
current_predicate(verify_attributes, Mod:verify_attributes(_,_,_)), !,
do_verify_attributes(Mods, AttVar, Binding, Goals),
Mod:verify_attributes(AttVar, Binding, Goal).
do_verify_attributes([_|Mods], AttVar, Binding, Goals) :-
@ -171,7 +171,7 @@ fetch_att_goals([_|LMods], Att, LGoal) :-
call_module_attributes(Mod, AttV, G1) :-
existing_attribute(_,Mod,Key),
get_att(AttV,Key,_), !,
Mod:current_predicate(attribute_goal, attribute_goal(AttV,G1)),
current_predicate(attribute_goal, Mod:attribute_goal(AttV,G1)),
Mod:attribute_goal(AttV, G1).
simplify_trues((A,B), NG) :- !,

7
m4/Yatom.h.m4
View File

@ -203,7 +203,7 @@ typedef struct pred_entry {
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
unsigned int ArityOfPE; /* arity of property */
Term ModuleOfPred; /* module for this definition */
int ModuleOfPred; /* module for this definition */
CELL PredFlags;
CODEADDR CodeOfPred; /* code address */
CODEADDR TrueCodeOfPred; /* if needing to spy or to lock */
@ -496,10 +496,9 @@ Atom STD_PROTO(GetOp,(OpEntry *,int *,int));
/* vsc: redefined to GetAProp to avoid conflicts with Windows header files */
Prop STD_PROTO(GetAProp,(Atom,PropFlags));
Prop STD_PROTO(GetAPropHavingLock,(AtomEntry *,PropFlags));
Prop STD_PROTO(PredProp,(Atom,unsigned int));
EXTERN inline Prop
PredPropByFunc(Functor f, Term cur_mod)
PredPropByFunc(Functor f, SMALLUNSGN cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
@ -520,7 +519,7 @@ PredPropByFunc(Functor f, Term cur_mod)
}
EXTERN inline Prop
PredPropByAtom(Atom at, Term cur_mod)
PredPropByAtom(Atom at, SMALLUNSGN cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;

267
pl/boot.yap
View File

@ -242,12 +242,11 @@ repeat :- '$repeat'.
'$execute_command'(R,_,top) :- db_reference(R), !,
throw(error(type_error(callable,R),meta_call(R))).
'$execute_command'((:-G),_,Option) :- !,
'$process_directive'(G, Option),
'$current_module'(M),
'$process_directive'(G, Option, M),
fail.
'$execute_command'((?-G),V,_) :- !,
'$execute_command'(G,V,top).
'$execute_command'((Mod:G),V,Option) :- !,
'$mod_switch'(Mod,'$execute_command'(G,V,Option)).
'$execute_command'(G,V,Option) :- '$continue_with_command'(Option,V,G).
%
@ -257,38 +256,44 @@ repeat :- '$repeat'.
% SICStus accepts everything in files
% YAP accepts everything everywhere
%
'$process_directive'(G, top) :-
'$process_directive'(G, top, M) :-
'$access_yap_flags'(8, 0), !, % YAP mode, go in and do it,
'$process_directive'(G, consult).
'$process_directive'(G, top) :- !,
'$process_directive'(G, consult, M).
'$process_directive'(G, top, _) :- !,
throw(error(context_error((:- G),clause),query)).
%
% always allow directives.
%
'$process_directive'(D, Mode) :-
'$process_directive'(D, Mode, M) :-
'$directive'(D), !,
( '$exec_directive'(D, Mode) -> true ; true ).
( '$exec_directive'(D, Mode, M) -> true ; true ).
%
% allow multiple directives
%
'$process_directive'((G1,G2), Mode) :-
'$process_directive'((G1,G2), Mode, M) :-
'$all_directives'(G1),
'$all_directives'(G2), !,
'$exec_directives'(G1, Mode),
'$exec_directives'(G2, Mode).
'$exec_directives'(G1, Mode, M),
'$exec_directives'(G2, Mode, M).
%
% allow modules
%
'$process_directive'(M:G, Mode, _) :- !,
'$process_directive'(G, Mode, M).
%
% ISO does not allow goals (use initialization).
%
'$process_directive'(D, _) :-
'$process_directive'(D, _, M) :-
'$access_yap_flags'(8, 1), !, % ISO Prolog mode, go in and do it,
throw(error(context_error((:- D),query),directive)).
%
% but YAP and SICStus does.
%
'$process_directive'(G, _) :-
'$current_module'(M),
'$process_directive'(G, _, M) :-
( '$do_yes_no'(M:G) -> true ; '$format'(user_error,":- ~w:~w failed.~n",[M,G]) ).
'$all_directives'(M:G1) :- !,
'$all_directives'(G1).
'$all_directives'((G1,G2)) :- !,
'$all_directives'(G1),
'$all_directives'(G2).
@ -309,7 +314,7 @@ repeat :- '$repeat'.
% module prefixes all over the place, although unnecessarily so.
%
'$go_compile_clause'(M:G,V,N) :- !,
'$mod_switch'(M,'$go_compile_clause'(G,V,N)).
'$go_compile_clause'(G,V,N,Mod).
'$go_compile_clause'((M:G :- B),V,N) :- !,
'$current_module'(M1),
(M1 = M ->
@ -317,35 +322,39 @@ repeat :- '$repeat'.
;
'$preprocess_clause_before_mod_change'((G:-B),M1,M,NG)
),
'$mod_switch'(M,'$go_compile_clause'(NG,V,N)).
'$go_compile_clause'(NG,V,N,M).
'$go_compile_clause'(G,V,N) :-
'$prepare_term'(G,V,G0,G1),
'$$compile'(G1,G0,N).
'$current_module'(Mod),
'$go_compile_clause'(G,V,N,Mod).
'$prepare_term'(G,V,G0,G1) :-
'$go_compile_clause'(G, V, N, Mod) :-
'$prepare_term'(G, V, G0, G1, Mod),
'$$compile'(G1, G0, N, Mod).
'$prepare_term'(G,V,G0,G1, Mod) :-
( '$get_value'('$syntaxcheckflag',on) ->
'$check_term'(G,V) ; true ),
'$precompile_term'(G, G0, G1).
'$precompile_term'(G, G0, G1, Mod).
% process an input clause
'$$compile'(G,G0,L) :-
'$$compile'(G, G0, L, Mod) :-
'$head_and_body'(G,H,_),
'$inform_of_clause'(H,L),
'$flags'(H, Fl, Fl),
( Fl /\ 16'002008 =\= 0 -> '$assertz_dynamic'(L,G,G0) ;
'$$compile_stat'(G,G0,L,H) ).
'$flags'(H, Mod, Fl, Fl),
( Fl /\ 16'002008 =\= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ;
'$$compile_stat'(G,G0,L,H, Mod) ).
% process a clause for a static predicate
'$$compile_stat'(G,G0,L,H) :-
'$compile'(G,L),
'$$compile_stat'(G,G0,L,H, Mod) :-
'$compile'(G,L,Mod),
% first occurrence of this predicate in this file,
% check if we need to erase the source and if
% it is a multifile procedure.
'$flags'(H,Fl,Fl),
'$flags'(H,Mod,Fl,Fl),
( '$get_value'('$abol',true)
->
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true )
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H, Mod) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
;
true
),
@ -354,42 +363,40 @@ repeat :- '$repeat'.
true
;
% and store our clause
'$store_stat_clause'(G0, H, L)
'$store_stat_clause'(G0, H, L, Mod)
).
'$store_stat_clause'(G0, H, L) :-
'$store_stat_clause'(G0, H, L, M) :-
'$head_and_body'(G0,H0,B0),
'$record_stat_source'(H,(H0:-B0),L,R),
functor(H, Na, Ar),
( '$is_multifile'(Na,Ar) ->
'$record_stat_source'(M:H,(H0:-B0),L,R),
( '$is_multifile'(H,M) ->
'$get_value'('$consulting_file',F),
'$current_module'(M),
functor(H, Na, Ar),
'$recordz'('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), _)
;
true
).
'$erase_source'(G) :- functor(G, Na, A),
'$is_multifile'(Na,A), !,
'$erase_mf_source'(Na,A).
'$erase_source'(G) :- '$recordedp'(G,_,R), erase(R), fail.
'$erase_source'(_).
'$erase_source'(G, M) :-
'$is_multifile'(G, M), !,
functor(G, Na, Ar),
'$erase_mf_source'(Na, Ar, M).
'$erase_source'(G, M) :- '$recordedp'(M:G,_,R), erase(R), fail.
'$erase_source'(_, _).
'$erase_mf_source'(Na,A) :-
'$erase_mf_source'(Na, Ar, M) :-
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorded'('$multifile'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1),
erase(R),
fail.
'$erase_mf_source'(Na,A) :-
'$erase_mf_source'(Na, A, M) :-
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1),
erase(R),
fail.
'$erase_mf_source'(_,_).
'$erase_mf_source'(_,_,_).
'$check_if_reconsulted'(N,A) :-
'$recorded'('$reconsulted',X,_),
@ -416,9 +423,9 @@ repeat :- '$repeat'.
% ***************************
'$query'(G,V) :-
\+ '$undefined'('$yapor_on'),
\+ '$undefined'('$yapor_on', prolog),
'$yapor_on',
\+ '$undefined'('$start_yapor'),
\+ '$undefined'('$start_yapor', prolog),
'$parallelizable'(G), !,
'$parallel_query'(G,V),
fail.
@ -614,31 +621,31 @@ incore(G) :- '$execute'(G).
%
% standard meta-call, called if $execute could not do everything.
%
'$meta_call'(G) :-
'$meta_call'(G, M) :-
'$save_current_choice_point'(CP),
'$call'(G, CP, G).
'$call'(G, CP, G, M).
%
% do it in ISO mode.
%
'$meta_call'(G,_ISO) :-
'$meta_call'(G,_ISO,M) :-
'$iso_check_goal'(G,G),
'$save_current_choice_point'(CP),
'$call'(G, CP, G).
'$call'(G, CP, G, M).
'$meta_call'(G, CP, G0) :-
'$call'(G, CP,G0).
'$meta_call'(G, CP, G0, M) :-
'$call'(G, CP, G0, M).
'$spied_meta_call'(G) :-
'$spied_meta_call'(G, M) :-
'$save_current_choice_point'(CP),
'$spied_call'(G, CP, G).
'$spied_call'(G, CP, G, M).
'$spied_meta_call'(G, CP, G0) :-
'$spied_call'(G, CP, G0).
'$spied_meta_call'(G, CP, G0, M) :-
'$spied_call'(G, CP, G0, M).
'$call'(G, CP, G0, _) :- /* iso version */
'$call'(G, CP, G0, _, M) :- /* iso version */
'$iso_check_goal'(G,G0),
'$call'(G, CP,G0).
'$call'(G, CP, G0, M).
','(A,B) :-
@ -663,115 +670,110 @@ incore(G) :- '$execute'(G).
not(A) :-
\+ '$execute_within'(A).
Mod:G :- '$mod_switch'(Mod,'$execute_within'(G)).
'$call'(M:_,_,G0) :- var(M), !,
'$call'(M:_,_,G0,_) :- var(M), !,
throw(error(instantiation_error,call(G0))).
'$call'(M:G,CP,G0) :- !,
'$mod_switch'(M,'$call'(G,CP,G0)).
'$call'((X->Y),CP,G0) :- !,
'$call'(M:G,CP,G0,_) :- !,
'$call'(G,CP,G0,M).
'$call'((X,Y),CP,G0,M) :- !,
'$execute_within'(X,CP,G0,M),
'$execute_within'(Y,CP,G0,M).
'$call'((X->Y),CP,G0,M) :- !,
(
'$execute_within'(X,CP,G0)
'$execute_within'(X,CP,G0,M)
->
'$execute_within'(Y,CP,G0)
'$execute_within'(Y,CP,G0,M)
).
'$call'((X->Y; Z),CP,G0) :- !,
'$call'((X->Y; Z),CP,G0,M) :- !,
(
'$execute_within'(X,CP,G0)
'$execute_within'(X,CP,G0,M)
->
'$execute_within'(Y,CP,G0)
'$execute_within'(Y,CP,G0,M)
;
'$execute_within'(Z,CP,G0)
'$execute_within'(Z,CP,G0,M)
).
'$call'((A;B),CP,G0) :- !,
'$call'((A;B),CP,G0,M) :- !,
(
'$execute_within'(A,CP,G0)
'$execute_within'(A,CP,G0,M)
;
'$execute_within'(B,CP,G0)
'$execute_within'(B,CP,G0,M)
).
'$call'((A|B),CP, G0) :- !,
'$call'((A|B),CP, G0,M) :- !,
(
'$execute_within'(A,CP,G0)
'$execute_within'(A,CP,G0,M)
;
'$execute_within'(B,CP,G0)
'$execute_within'(B,CP,G0,M)
).
'$call'(\+ X, _, _) :- !,
'$call'(\+ X, _, _,_) :- !,
\+ '$execute'(X).
'$call'(not(X), _, _) :- !,
'$call'(not(X), _, _,_) :- !,
\+ '$execute'(X).
'$call'(!, CP, _) :- !,
'$call'(!, CP, _,_) :- !,
'$$cut_by'(CP).
'$call'([A|B],_, _) :- !,
'$call'([A|B],_, _,_) :- !,
'$csult'([A|B]).
'$call'(A, _, _) :-
'$call'(A, _, _,CurMod) :-
(
% goal_expansion is defined, or
'$pred_goal_expansion_on'
;
% this is a meta-predicate
'$flags'(A,F,_), F /\ 0x200000 =:= 0x200000
'$flags'(A,CurMod,F,_), F /\ 0x200000 =:= 0x200000
), !,
'$current_module'(CurMod),
'$exec_with_expansion'(A, CurMod, CurMod).
'$call'(A, _, _) :-
'$execute0'(A).
'$call'(A, _, _, M) :-
'$execute0'(A, M).
'$spied_call'(M:_,_,G0) :- var(M), !,
throw(error(instantiation_error,call(G0))).
'$spied_call'(M:G,CP,G0) :- !,
'$mod_switch'(M,'$spied_call'(G,CP,G0)).
'$spied_call'((A,B),CP,G0) :- !,
'$execute_within'(A,CP,G0),
'$execute_within'(B,CP,G0).
'$spied_call'((X->Y),CP,G0) :- !,
'$spied_call'((A,B),CP,G0,M) :- !,
'$execute_within'(A,CP,G0,M),
'$execute_within'(B,CP,G0,M).
'$spied_call'((X->Y),CP,G0,M) :- !,
(
'$execute_within'(X,CP,G0)
'$execute_within'(X,CP,G0,M)
->
'$execute_within'(Y,CP,G0)
'$execute_within'(Y,CP,G0,M)
).
'$spied_call'((X->Y; Z),CP,G0) :- !,
'$spied_call'((X->Y; Z),CP,G0,M) :- !,
(
'$execute_within'(X,CP,G0)
'$execute_within'(X,CP,G0,M)
->
'$execute_within'(Y,CP,G0)
'$execute_within'(Y,CP,G0,M)
;
'$execute_within'(Z,CP,G0)
'$execute_within'(Z,CP,G0,M)
).
'$spied_call'((A;B),CP,G0) :- !,
'$spied_call'((A;B),CP,G0,M) :- !,
(
'$execute_within'(A,CP,G0)
'$execute_within'(A,CP,G0,M)
;
'$execute_within'(B,CP,G0)
'$execute_within'(B,CP,G0,M)
).
'$spied_call'((A|B),CP,G0) :- !,
'$spied_call'((A|B),CP,G0,M) :- !,
(
'$execute_within'(A,CP,G0)
'$execute_within'(A,CP,G0,M)
;
'$execute_within'(B,CP,G0)
'$execute_within'(B,CP,G0,M)
).
'$spied_call'(\+ X,_,_) :- !,
'$spied_call'(\+ X,_,_,M) :- !,
\+ '$execute'(X).
'$spied_call'(not X,_,_) :- !,
'$spied_call'(not X,_,_,_) :- !,
\+ '$execute'(X).
'$spied_call'(!,CP,_) :-
'$spied_call'(!,CP,_,_) :-
'$$cut_by'(CP).
'$spied_call'([A|B],_,_) :- !,
'$spied_call'([A|B],_,_,_) :- !,
'$csult'([A|B]).
'$spied_call'(A, _CP, _G0) :-
'$spied_call'(A, _CP, _G0, CurMod) :-
(
% goal_expansion is defined, or
'$pred_goal_expansion_on'
;
% this is a meta-predicate
'$flags'(A,F,_), F /\ 0x200000 =:= 0x200000
'$flags'(A,CurMod,F,_), F /\ 0x200000 =:= 0x200000
), !,
'$current_module'(CurMod),
'$exec_with_expansion'(A, CurMod, CurMod).
'$spied_call'(A,CP,G0) :-
( '$undefined'(A) ->
functor(A,F,N), '$current_module'(M),
'$spied_call'(A, CP, G0, M) :-
( '$undefined'(A, M) ->
functor(A,F,N),
( '$recorded'('$import','$import'(S,M,F,N),_) ->
'$spied_call'(S:A,CP,G0) ;
'$spied_call'(S:A,CP,G0,M) ;
'$spy'(A)
)
;
@ -797,10 +799,10 @@ Mod:G :- '$mod_switch'(Mod,'$execute_within'(G)).
!,
'$exec_with_expansion'(G, S, M).
'$undefp'([M|G]) :-
\+ '$undefined'(user:unknown_predicate_handler(_,_,_)),
\+ '$undefined'(unknown_predicate_handler(_,_,_), user),
user:unknown_predicate_handler(G,M,NG), !,
'$execute'(M:NG).
'$undefp'([_|G]) :- '$is_dynamic'(G), !, fail.
'$undefp'([M|G]) :- '$is_dynamic'(G, M), !, fail.
'$undefp'([M|G]) :-
'$recorded'('$unknown','$unknown'(M:G,US),_), !,
'$execute'(user:US).
@ -857,7 +859,11 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
throw(error(permission_error(input,stream,Y),consult(X)))
).
'$consult'(M:X) :- !,
'$mod_switch'(M,'$consult'(X)).
% set the type-in module
'$current_module'(Mod),
module(M),
'$consult'(X),
'$current_module'(Mod).
'$consult'(library(X)) :- !,
'$find_in_path'(library(X),Y),
( '$open'(Y,'$csult',Stream,0), !,
@ -1058,19 +1064,19 @@ remove_from_path(New) :- '$check_path'(New,Path),
% return two arguments: Expanded0 is the term after "USER" expansion.
% Expanded is the final expanded term.
%
'$precompile_term'(Term, Expanded0, Expanded) :-
'$precompile_term'(Term, Expanded0, Expanded, Mod) :-
(
'$access_yap_flags'(9,1) /* strict_iso on */
->
'$expand_term_modules'(Term, Expanded0, Expanded),
'$expand_term_modules'(Term, Expanded0, Expanded, Mod),
'$check_iso_strict_clause'(Expanded0)
;
'$expand_term_modules'(Term, Expanded0, ExpandedI),
'$expand_term_modules'(Term, Expanded0, ExpandedI, Mod),
'$expand_array_accesses_in_term'(ExpandedI,Expanded)
).
expand_term(Term,Expanded) :-
( \+ '$undefined'(user:term_expansion(_,_)),
( \+ '$undefined'(term_expansion(_,_), user),
user:term_expansion(Term,Expanded)
;
'$expand_term_grammar'(Term,Expanded)
@ -1105,8 +1111,8 @@ expand_term(Term,Expanded) :-
%
% Module system expansion
%
'$expand_term_modules'(A,B,C) :- '$module_expansion'(A,B,C), !.
'$expand_term_modules'(A,A,A).
'$expand_term_modules'(A,B,C,M) :- '$module_expansion'(A,B,C,M), !.
'$expand_term_modules'(A,A,A,_).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -1164,7 +1170,7 @@ catch(G,C,A) :-
%
% system_catch is like catch, but it avoids the overhead of a full
% meta-call by calling '$execute0' and '$mod_switch' instead of $execute.
% meta-call by calling '$execute0' instead of $execute.
% This way it
% also avoids module preprocessing and goal_expansion
%
@ -1189,8 +1195,8 @@ catch(G,C,A) :-
'$db_clean_queues'(Lev),
'$erase_catch_elements'(Lev),
( C=X ->
'$current_module'(_,M0),
(A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A))
(A = M:G -> '$execute'(A) ;
'$current_module'(_,M0), '$execute'(M0:A) )
;
throw(X)
).
@ -1212,7 +1218,8 @@ catch(G,C,A) :-
'$system_catch_call'(X,G,I, NX) :-
array_element('$catch_queue', 0, OldCatch),
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
'$execute0'(G),
'$current_module'(M),
'$execute0'(G,M),
NX is '$last_choice_pt',
( % on exit remove the catch
array_element('$catch_queue', 0, catch(X,I,Catch)),

116
pl/checker.yap
View File

@ -65,12 +65,14 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$check_term'(T,_) :-
'$get_value'('$syntaxcheckdiscontiguous',on),
'$xtract_head'(T,_,F,A),
'$handle_discontiguous'(F,A), fail.
'$current_module'(M),
'$xtract_head'(T,M,NM,H,F,A),
'$handle_discontiguous'(F,A,NM), fail.
'$check_term'(T,_) :-
'$get_value'('$syntaxcheckmultiple',on),
'$xtract_head'(T,_,F,A),
'$handle_multiple'(F,A), fail.
'$current_module'(M),
'$xtract_head'(T,M,NM,H,F,A),
'$handle_multiple'(F,A,NM), fail.
'$check_term'(T,VL) :-
'$get_value'('$syntaxchecksinglevar',on),
( '$chk_binding_vars'(T),
@ -99,8 +101,9 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$sv_warning'([],_) :- !.
'$sv_warning'(SVs,T) :-
'$xtract_head'(T,H,Name,Arity),
'$sv_warning'(SVs,T) :-
'$current_module'(OM),
'$xtract_head'(T,OM,M,H,Name,Arity),
write(user_error,'[ Warning: singleton variable'),
'$write_svs'(SVs),
write(user_error,' in '),
@ -111,22 +114,24 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
( '$get_value'('$consulting',false),
'$first_clause_in_file'(Name,Arity) ->
ClN = 1 ;
'$number_of_clauses'(H,ClN0),
'$number_of_clauses'(H,M,ClN0),
ClN is ClN0+1
),
write(user_error,ClN),
write(user_error,') ]'),
nl(user_error).
'$xtract_head'((H:-_),H,Name,Arity) :- !,
functor(H,Name,Arity).
'$xtract_head'((H,_),H1,Name,Arity) :- !,
'$xtract_head'(H,H1,Name,Arity).
'$xtract_head'((H-->_),HL,Name,Arity) :- !,
'$xtract_head'(H,_,Name,A1),
'$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !,
'xtract_head'(H,OM,M,NH,Name,Arity).
'$xtract_head'((H,_),OM,M,H1,Name,Arity) :- !,
'$xtract_head'(H,OM,M,H1,Name,Arity).
'$xtract_head'((H-->_),OM,M,HL,Name,Arity) :- !,
'$xtract_head'(H,OM,M,Name,A1),
Arity is A1+2,
functor(HL,Name,Arity).
'$xtract_head'(H,H,Name,Arity) :-
'$xtract_head'(M:H,_,NM,NH,Name,Arity) :- !,
'$xtract_head'(H,M,NM,NH,Name,Arity).
'$xtract_head'(H,M,M,H,Name,Arity) :-
functor(H,Name,Arity).
'$write_svs'([H]) :- !, write(user_error,' '), '$write_svs1'([H]).
@ -145,10 +150,9 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$write_str_in_stderr'(T).
'$handle_discontiguous'(F,A) :-
'$current_module'(M),
'$handle_discontiguous'(F,A,M) :-
'$recorded'('$discontiguous_defs','$df'(F,A,M),_), !.
'$handle_discontiguous'(F,A) :-
'$handle_discontiguous'(F,A,_) :-
'$in_this_file_before'(F,A),
write(user_error,'[ Warning: discontiguous definition of '),
write(user_error,F/A), write(user_error,' (line '),
@ -156,22 +160,21 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
write(user_error,') ]'),
nl(user_error).
'$handle_multiple'(F,A) :-
\+ '$first_clause_in_file'(F,A), !.
'$handle_multiple'(_,_) :-
'$handle_multiple'(F,A,_) :-
\+ '$first_clause_in_file'(F,A,M), !.
'$handle_multiple'(_,_,_) :-
'$get_value'('$consulting',true), !.
'$handle_multiple'(F,A) :-
'$current_module'(M),
'$handle_multiple'(F,A,M) :-
'$recorded'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !,
'$multiple_has_been_defined'(Fil,F/A), !.
'$handle_multiple'(F,A) :-
'$multiple_has_been_defined'(Fil, F/A, M), !.
'$handle_multiple'(F,A,M) :-
( '$recorded'('$reconsulting',Fil,_) -> true ),
'$current_module'(M),
'$recorda'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_).
'$multiple_has_been_defined'(_,F/A) :-
'$is_multifile'(F,A), !.
'$multiple_has_been_defined'(Fil,P) :-
'$multiple_has_been_defined'(_, F/A, M) :-
functor(S, F, A),
'$is_multifile'(S, M), !.
'$multiple_has_been_defined'(Fil,P,_) :-
'$recorded'('$reconsulting',F,_), !,
'$test_if_well_reconsulting'(F,Fil,P).
@ -184,59 +187,52 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
write(user_error,') ]'),
nl(user_error).
'$multifile'(V) :- var(V), !,
'$multifile'(V, _) :- var(V), !,
throw(error(instantiation_error,multifile(V))).
'$multifile'((X,Y)) :- '$multifile'(X), '$multifile'(Y).
'$multifile'(Mod:PredSpec) :- !,
( '$current_module'(Mod) ->
'$multifile'(PredSpec)
;
'$mod_switch'(Mod,'$multifile'(PredSpec))
).
'$multifile'(N/A) :-
'$multifile'((X,Y), M) :- '$multifile'(X, M), '$multifile'(Y, M).
'$multifile'(Mod:PredSpec, _) :- !,
'$multifile'(PredSpec, Mod).
'$multifile'(N/A, M) :-
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recordzifnot'('$multifile_defs','$defined'(F,N,A,M),_),
fail.
'$multifile'(N/A) :-
'$is_multifile'(N,A), !.
'$multifile'(N/A) :- !,
'$new_multifile'(N,A).
'$multifile'(P) :-
throw(error(type_error(predicate_indicator,P),multifile(P))).
'$multifile'(N/A, M) :-
functor(S,N,A),
'$is_multifile'(S, M), !.
'$multifile'(N/A, M) :- !,
'$new_multifile'(N,A,M).
'$multifile'(P, M) :-
throw(error(type_error(predicate_indicator,P),multifile(M:P))).
'$discontiguous'(V) :- var(V), !,
throw(error(instantiation_error,discontiguous(V))).
'$discontiguous'((X,Y)) :- !,
'$discontiguous'(X),
'$discontiguous'(Y).
'$discontiguous'(M:A) :- !,
'$mod_switch'(M,'$discontiguous'(A)).
'$discontiguous'(N/A) :- !,
'$current_module'(M),
'$discontiguous'(V,M) :- var(V), !,
throw(error(instantiation_error,M:discontiguous(V))).
'$discontiguous'((X,Y),M) :- !,
'$discontiguous'(X,M),
'$discontiguous'(Y,M).
'$discontiguous'(M:A,_) :- !,
'$discontiguous'(A,M).
'$discontiguous'(N/A, M) :- !,
( '$recordzifnot'('$discontiguous_defs','$df'(N,A,M),_) ->
true
;
true
).
'$discontiguous'(P) :-
throw(error(type_error(predicate_indicator,P),discontiguous(P))).
'$discontiguous'(P,M) :-
throw(error(type_error(predicate_indicator,P),M:discontiguous(P))).
%
% did we declare multifile properly?
%
'$check_multifile_pred'(Hd, _) :-
'$check_multifile_pred'(Hd, M, _) :-
functor(Hd,Na,Ar),
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorded'('$multifile_defs','$defined'(F,Na,Ar,M),_), !.
% oops, we did not.
'$check_multifile_pred'(Hd, Fl) :-
'$check_multifile_pred'(Hd, M, Fl) :-
% so this is not a multi-file predicate any longer.
functor(Hd,Na,Ar),
NFl is \(16'040000 ) /\ Fl,
'$flags'(Hd,Fl,NFl),
'$current_module'(M),
'$flags'(Hd,M,Fl,NFl),
'$clear_multifile_pred'(Na,Ar,M),
'$warn_mfile'(Na,Ar).

12
pl/consult.yap
View File

@ -24,6 +24,11 @@ ensure_loaded(V) :-
'$ensure_loaded'([F|Fs]) :- !,
'$ensure_loaded'(F),
'$ensure_loaded'(Fs).
'$ensure_loaded'(M:X) :- !,
'$current_module'(M0),
'$change_module'(M),
'$ensure_loaded'(X),
'$change_module'(M0).
'$ensure_loaded'(X) :- atom(X), !,
'$find_in_path'(X,Y),
( open(Y,'$csult',Stream), !,
@ -43,8 +48,6 @@ ensure_loaded(V) :-
throw(error(permission_error(input,stream,X),ensure_loaded(X)))
).
'$ensure_loaded'(M:X) :- !,
'$mod_switch'(M,'$ensure_loaded'(X)).
'$ensure_loaded'(library(X)) :- !,
'$find_in_path'(library(X),Y),
( open(Y,'$csult',Stream), !,
@ -106,7 +109,10 @@ reconsult(Fs) :-
throw(error(permission_error(input,stream,X),reconsult(X)))
).
'$reconsult'(M:X) :- !,
'$mod_switch'(M,'$reconsult'(X)).
'$current_module'(M0),
'$change_module'(M),
'$reconsult'(X),
'$change_module'(M0).
'$reconsult'(library(X)) :- !,
'$find_in_path'(library(X),Y),
( open(Y,'$csult',Stream), !,

25
pl/corout.yap
View File

@ -32,6 +32,7 @@
%
% Tell the system how to present frozen goals.
%
:- assert((extensions_to_present_answer(Level) :-
'$show_frozen_goals'(Level))).
@ -75,17 +76,18 @@
'$do_continuation'('$restore_regs'(X,Y), _) :- !,
'$restore_regs'(X,Y).
'$do_continuation'(Continuation, Module1) :-
'$mod_switch'(Module1,'$execute_continuation'(Continuation,Module1)).
'$execute_continuation'(Continuation,Module1).
'$execute_continuation'(Continuation, Module1) :-
'$undefined'(Continuation), !,
'$undefined'(Continuation, Module1), !,
'$undefp'([Module1|Continuation]).
'$execute_continuation'(Continuation, _) :-
'$execute_continuation'(Continuation, Mod) :-
% do not do meta-expansion nor any fancy stuff.
'$execute0'(Continuation).
'$module_number'(Mod,_),
'$execute0'(Continuation, Mod).
'$execute_woken_system_goals'([]).
'$execute_woken_system_goals'([]).
'$execute_woken_system_goals'([G|LG]) :-
'$execute_woken_system_goal'(G, G),
'$execute_woken_system_goals'(LG).
@ -252,7 +254,8 @@ when(_,Goal) :-
%
'$declare_when'(Cond, G) :-
'$generate_code_for_when'(Cond, G, Code),
'$$compile'(Code, Code, 5), fail.
'$current_module'(Module),
'$$compile'(Code, Code, 5, Module), fail.
'$declare_when'(_,_).
%
@ -378,7 +381,8 @@ when(_,Goal) :-
%
'$block'(Conds) :-
'$generate_blocking_code'(Conds, _, Code),
'$$compile'(Code, Code, 5), fail.
'$current_module'(Mod),
'$$compile'(Code, Code, 5, Module), fail.
'$block'(_).
'$generate_blocking_code'(Conds, G, Code) :-
@ -458,7 +462,8 @@ when(_,Goal) :-
'$wait'(Na/Ar) :-
functor(S, Na, Ar),
arg(1, S, A),
'$$compile'((S :- var(A), !, freeze(A, S)), (S :- var(A), !, freeze(A, S)), 5), fail.
'$current_module'(M),
'$$compile'((S :- var(A), !, freeze(A, S)), (S :- var(A), !, freeze(A, S)), 5, M), fail.
'$wait'(_).
frozen(V, G) :- nonvar(V), !, G = true.
@ -606,7 +611,7 @@ call_residue(Goal,Residue) :-
'$project'(true,_,_,Gs,Gs) :- !.
'$project'(_,_,_,Gs,Gs) :-
'$undefined'(attributes:modules_with_attributes(_)), !.
'$undefined'(modules_with_attributes(_), attributes), !.
'$project'(_,LIV,LAV,Gs,Gs0) :-
attributes:modules_with_attributes(LMods),
(LAV = [] ->
@ -626,7 +631,7 @@ call_residue(Goal,Residue) :-
'$project_module'([], _, _).
'$project_module'([Mod|LMods], LIV, LAV) :-
\+ '$undefined'(Mod:project_attributes(LIV, LAV)),
\+ '$undefined'(project_attributes(LIV, LAV), Mod),
'$execute'(Mod:project_attributes(LIV, LAV)), !,
'$all_attvars'(NLAV),
'$project_module'(LMods,LIV,NLAV).

542
pl/debug.yap
View File

@ -26,75 +26,73 @@
% First part : setting and reseting spy points
% $suspy does most of the work
'$suspy'(V,S) :- var(V) , !,
throw(error(instantiation_error,spy(V,S))).
'$suspy'((M:S),P) :- !,
'$mod_switch'(M, '$suspy'(S,P)).
'$suspy'([],_) :- !.
'$suspy'([F|L],M) :- !, ( '$suspy'(F,M) ; '$suspy'(L,M) ).
'$suspy'(F/N,M) :- !, functor(T,F,N),
'$suspy'(V,S,M) :- var(V) , !,
throw(error(instantiation_error,M:spy(V,S))).
'$suspy'((M:S),P,_) :- !,
'$suspy'(S,P,M).
'$suspy'([],_,_) :- !.
'$suspy'([F|L],S,M) :- !, ( '$suspy'(F,S,M) ; '$suspy'(L,S,M) ).
'$suspy'(F/N,S,M) :- !, functor(T,F,N),
( '$system_predicate'(T) ->
throw(error(permission_error(access,private_procedure,F/N),spy(F/N,S)));
'$undefined'(T) ->
'$undefined'(T,M) ->
throw(error(existence_error(procedure,F/N),spy(F/N,S)));
'$suspy2'(M,F,N,T) ).
'$suspy'(A,S) :- \+ atom(A) , !,
'$suspy2'(S,F,N,T,M) ).
'$suspy'(A,S,_) :- \+ atom(A) , !,
throw(error(type_error(predicate_indicator,A),spy(A,S))).
'$suspy'(A,spy) :- '$noclausesfor'(A), !,
'$suspy'(A,spy,M) :- '$noclausesfor'(A,M), !,
throw(error(existence_error(procedure,A),spy(A))).
'$suspy'(A,nospy) :- '$noclausesfor'(A), !,
'$suspy'(A,nospy,M) :- '$noclausesfor'(A,M), !,
throw(error(existence_error(procedure,A),nospy(A))).
'$suspy'(A,M) :- current_predicate(A,T),
\+ '$undefined'(T), \+ '$system_predicate'(T),
'$suspy'(A,S,M) :- current_predicate(A,M:T),
\+ '$undefined'(T,M), \+ '$system_predicate'(T),
functor(T,F,N),
'$suspy2'(M,F,N,T).
'$suspy2'(S,F,N,T,M).
'$noclausesfor'(A) :- current_predicate(A,T),
\+ '$undefined'(T) , \+ '$system_predicate'(T) ,
'$noclausesfor'(A,M) :- current_predicate(A,M:T),
\+ '$undefined'(T,M) , \+ '$system_predicate'(T) ,
!, fail .
'$noclausesfor'(_).
'$noclausesfor'(_,_).
'$suspy2'(spy,F,N,T) :-
'$current_module'(M),
'$suspy2'(spy,F,N,T,M) :-
'$recorded'('$spy','$spy'(T,M),_), !,
format('[ Warning: there is already a spy point on ~w ]~n',M:F/N).
'$suspy2'(spy,F,N,T) :- !,
'$warn_if_undef'(T,F,N),
'$current_module'(M),
'$format'(user_error, "[ Warning: there is already a spy point on ~w:~w/~w ]~n",[M,F,N]).
'$suspy2'(spy,F,N,T,M) :- !,
'$warn_if_undef'(T,F,N,M),
'$recorda'('$spy','$spy'(T,M),_),
'$set_value'('$spypoint_added', true),
'$set_spy'(T),
write(user_error,'[ Spy point set on '), write(user_error,F/N),
write(user_error,' ]'), nl(user_error).
'$suspy2'(nospy,F,N,T) :-
'$current_module'(M),
'$set_spy'(T,M),
'$format'(user_error,"[ Spy point set on ~w:~w/~w ]~n", [M,F,N]).
'$suspy2'(nospy,F,N,T,M) :-
'$recorded'('$spy','$spy'(T,M),R), !,
erase(R),
'$rm_spy'(T),
write(user_error,'[ Spy point on '), write(user_error,F/N), write(user_error,' removed ]'),
nl(user_error).
'$suspy2'(nospy,F,N,_) :-
write(user_error,'[ Warning: there is no spy-point on '),
write(user_error,F/N), write(user_error,' ]'), nl(user_error).
'$rm_spy'(T,M),
'$format'(user_error,"[ Spy point on ~w:~w/~w removed ]~n", [M,F,N]).
'$suspy2'(nospy,F,N,_,M) :-
'$format'(user_error,"[ Warning: there is no spy point on ~w:~w/~w ]~n", [M,F,N]).
'$warn_if_undef'(T,F,N) :- '$undefined'(T), !,
'$warn_if_undef'(T,F,N,M) :- '$undefined'(T,M), !,
write(user_error,'[ Warning: you have no clauses for '),
write(user_error,F/N), write(user_error,' ]'), nl(user_error).
'$warn_if_undef'(_,_,_).
write(user_error,M:F/N), write(user_error,' ]'), nl(user_error).
'$warn_if_undef'(_,_,_,_).
'$pred_being_spied'(G) :-
'$current_module'(M),
'$pred_being_spied'(G, M) :-
'$recorded'('$spy','$spy'(G,M),_), !.
spy _ :- '$set_value'('$spypoint_added', false), fail.
spy L :- '$suspy'(L,spy), fail.
spy L :-
'$current_module'(M),
'$suspy'(L, spy, M), fail.
spy _ :- '$get_value'('$spypoint_added', false), !.
spy _ :- debug.
nospy L :- '$suspy'(L,nospy), fail.
nospy L :-
'$current_module'(M),
'$suspy'(L, nospy, M), fail.
nospy _.
nospyall :- '$recorded'('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(M:F/N,nospy), fail.
nospyall :-
'$recorded'('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(F/N,nospy,M), fail.
nospyall.
% debug mode -> debug flag = 1
@ -249,7 +247,7 @@ debugging :-
'$awoken_goals'(LG), !,
'$creep',
'$wake_up_goal'(G, LG).
'$spy'([_Module|G]) :-
'$spy'([Module|G]) :-
% '$format'(user_error,"$spym(~w,~w)~n",[Module,G]),
( '$hidden'(G)
;
@ -258,41 +256,37 @@ debugging :-
),
!,
/* called from prolog module */
'$execute0'(G),
'$execute0'(G,Module),
'$creep'.
'$spy'(G) :-
'$do_spy'(G).
'$spy'([Mod|G]) :-
'$do_spy'(G,Mod).
'$direct_spy'(G) :-
'$awoken_goals'(LG), !,
'$creep',
'$wake_up_goal'(G, LG).
'$direct_spy'([_|G]) :-
'$direct_spy'([M|G]) :-
'$hidden'(G),
!,
/* called from prolog module */
'$execute0'(G),
'$execute0'(G,M),
'$creep'.
'$direct_spy'(G) :-
'$do_spy'(G).
'$direct_spy'([Mod|G]) :-
'$do_spy'(G, Mod).
'$do_spy'([Module|G]) :- !,
( Module=prolog -> '$do_spy'(G);
'$mod_switch'(Module, '$do_spy'(G))
).
'$do_spy'(true) :- !, '$creep'.
'$do_spy'('$cut_by'(M)) :- !, '$cut_by'(M).
'$do_spy'(G) :-
'$do_spy'(true, _) :- !, '$creep'.
'$do_spy'('$cut_by'(M), _) :- !, '$cut_by'(M).
'$do_spy'(G, Module) :-
% write(user_error,$spy(G)), nl,
'$get_value'(debug,1), /* ditto if debug off */
'$get_value'(spy_fs,0), /* ditto if fast skipping */
( '$access_yap_flags'(10,0) -> /* if not creeping ... */
'$pred_being_spied'(G) /* ... spy only if at a spy-point */
'$pred_being_spied'(G,M) /* ... spy only if at a spy-point */
; true
),
% ( \+ '$undefined'(user_error_spy(_)) -> user_error_spy(G) ;
% ( \+ '$undefined'(user_error_spy(_), user) -> user_error_spy(G) ;
% true );
!, /* you sure want to spy this ... */
'$get_value'(spy_gn,L), /* get goal no. */
@ -301,16 +295,14 @@ debugging :-
'$access_yap_flags'(10,SC),
'$set_yap_flags'(10,1), /* set creep on */
'$get_value'(spy_cl,CL), /* save global clause no. */
'$current_module'(Module),
repeat, /* we need this to be able to implement retry */
'$init_spy_cl'(G),
'$trace'(call,G,L), /* inform about call port */
'$init_spy_cl'(G,Module),
'$trace'(call,G,Module,L), /* inform about call port */
/* the following choice point is where the predicate is called */
( '$get_value'(spy_sp,0), /* make sure we are not skipping*/
'$current_module'(_,Module),
'$spycalls'(G,Res) /* go execute the predicate */
'$spycalls'(G,Module,Res) /* go execute the predicate */
; /* we get here when the predicate fails */
'$trace'(fail,G,L), /* inform at fail port */
'$trace'(fail,G,Module,L), /* inform at fail port */
'$get_value'(spy_sl,L2),/* make sure we are not ... */
L2 \= L, /* ... skiping to this level */
!, /* if not prepare to exit spy */
@ -320,7 +312,7 @@ debugging :-
'$cont_creep', fail ), /* and exit */
'$get_value'(spy_cl,Cla), /* save no. of clause to try */
( var(Res), /* check not redoing */
'$trace'(exit,G,L), /* output message at exit */
'$trace'(exit,G,Module,L), /* output message at exit */
'$get_value'(spy_sp,0), /* check not skipping */
'$set_creep'(SC), /* restore creep value */
'$set_value'(spy_cl,CL), /* restore clause no. */
@ -328,11 +320,11 @@ debugging :-
'$cont_creep'; /* exit */
/* we get here when we want to redo a goal */
'$set_value'(spy_cl,Cla),/* restore clause no. to try */
'$current_module'(_,Module),
'$trace'(redo,G,L), /* inform user_error */
'$trace'(redo,G,Module,L), /* inform user_error */
fail /* to backtrack to spycalls */
).
'$do_spy'(G) :- '$execute0'(G). /* this clause applies when we do not want
'$do_spy'(G,Mod) :-
'$execute0'(G,Mod). /* this clause applies when we do not want
to spy the goal */
'$cont_creep' :- '$get_value'('$trace',1), '$set_yap_flags'(10,1), fail.
@ -343,79 +335,79 @@ debugging :-
'$set_creep'(_).
%'$spycalls'(G,_) :- write(user_error,'$spycalls'(G)), nl(user_error), fail.
'$spycalls'([_|_],_) :- !, fail.
'$spycalls'('!'(CP),_) :-
'$call'(!, CP, !).
'$spycalls'(Mod:G,Res) :-
'$spycalls'([_|_],_,_) :- !, fail.
'$spycalls'('!'(CP),Mod,_) :-
'$call'(!, CP, !,Mod).
'$spycalls'(Mod:G,_,Res) :-
!,
'$mod_switch'(Mod,'$spycalls'(G,Res)).
'$spycalls'(repeat,_) :-
'$spycalls'(G,Mod,Res).
'$spycalls'(repeat,_,_) :-
!,
repeat.
'$spycalls'(fail,_) :-
'$spycalls'(fail,_,_) :-
!,
fail.
'$spycalls'(false,_) :-
'$spycalls'(false,_,_) :-
!,
false.
'$spycalls'(true,_) :-
'$spycalls'(true,_,_) :-
!.
'$spycalls'(otherwise,_) :-
'$spycalls'(otherwise,_,_) :-
!.
'$spycalls'(\+ G,Res) :-
'$spycalls'(\+ G,Mod,Res) :-
!,
CP is '$last_choice_pt',
'$spycalls'('$call'((\+ G), CP, (\+ G)),Res).
'$spycalls'(not(G),Res) :-
'$spycalls'('$call'((\+ G), CP, (\+ G),Mod),Mod,Res).
'$spycalls'(not(G),Mod,Res) :-
!,
CP is '$last_choice_pt',
'$spycalls'('$call'(not(G), CP, not(G)),Res).
'$spycalls'(G,Res) :- % undefined predicate
'$undefined'(G), !,
functor(G,F,N), '$current_module'(M),
'$spycalls'('$call'(not(G), CP, not(G),Mod),Mod,Res).
'$spycalls'(G,M,Res) :- % undefined predicate
'$undefined'(G, M), !,
functor(G,F,N),
( '$recorded'('$import','$import'(S,M,F,N),_) ->
'$spycalls'(S:G,Res) ;
'$spycalls'(G,S,Res) ;
'$undefp'([M|G])
).
'$spycalls'(G,_) :-
'$flags'(G,F,_), F /\ 8'50000 =\= 0, % Standard and C pred
'$spycalls'(G,M,_) :-
'$flags'(G,M,F,_), F /\ 8'50000 =\= 0, % Standard and C pred
!,
'$catch_spycall_stdpred'(G),
'$catch_spycall_stdpred'(G,M),
(true;
'$get_value'(spy_sp,P), P \= 0, !, fail),
( true;
'$get_value'(spy_sp,P1), P1 \= 0, !, fail)
.
'$spycalls'(G,Res) :- % asserts and retracts can complicate live
'$spycalls'(G,M,Res) :- % asserts and retracts can complicate live
( '$get_value'(spy_sp,0) -> true ; !, fail ),
'$flags'(G,F,F),
'$flags'(G,M,F,F),
F /\ 16'2000 =\= 0, !, % dynamic procedure, immediate semantics
repeat,
'$db_last_age'(G,Max),
'$db_last_age'(M:G,Max),
'$get_value'(spy_cl,Cl),
'$get_value'(spy_gn,L),
Maxx is Max+1,
'$set_value'(spy_cl,Maxx),
( Cl > Max -> !, fail ; true ),
( '$spycall_dynamic'(G,Cl) ;
( '$spycall_dynamic'(G,M,Cl) ;
('$get_value'(spy_gn,L) -> '$leave_creep', fail ;
Res = redo )
),
( true ;
'$get_value'(spy_sp,P), P \= 0, !, fail )
.
'$spycalls'(G,Res) :-
'$spycalls'(G,M,Res) :-
( '$get_value'(spy_sp,0) -> true ; !, fail ),
'$flags'(G,F,F),
'$flags'(G,M,F,F),
F /\ 16'8 =\= 0, !, % dynamic procedure, logical update semantics
'$hold_index'(G, Index, Max), % hold an index on the procedure state when we called this goal
'$hold_index'(M:G, Index, Max), % hold an index on the procedure state when we called this goal
repeat,
'$get_value'(spy_cl,Cl),
'$get_value'(spy_gn,L),
Maxx is Max+1,
'$set_value'(spy_cl,Maxx),
( Cl > Max -> !, fail ; true),
( '$log_upd_spycall'(G,Cl,Index) ;
( '$log_upd_spycall'(G,M,Cl,Index) ;
('$get_value'(spy_gn,L) ->
'$leave_creep', fail ; % to backtrack to repeat
Res = redo )
@ -424,16 +416,16 @@ debugging :-
'$get_value'(spy_sp,P), P \= 0, !, fail
)
.
'$spycalls'(G,Res) :-
'$spycalls'(G,M,Res) :-
( '$get_value'(spy_sp,0) -> true ; !, fail ),
repeat,
'$number_of_clauses'(G,Max),
'$number_of_clauses'(G,M,Max),
'$get_value'(spy_cl,Cl),
'$get_value'(spy_gn,L),
Maxx is Max+1,
'$set_value'(spy_cl,Maxx),
( Cl > Max -> !, fail ; true),
( '$spycall'(G,Cl) ;
( '$spycall'(G,M,Cl) ;
('$get_value'(spy_gn,L) ->
'$leave_creep', fail ; % to backtrack to repeat
Res = redo )
@ -442,149 +434,149 @@ debugging :-
'$get_value'(spy_sp,P), P \= 0, !, fail )
.
'$spycall'(G,Cl) :-
'$spycall'(G,M,Cl) :-
'$access_yap_flags'(10,0),
!,
'$setflop'(0),
'$call_clause'(G,Cl).
'$spycall'(G,Cl) :-
'$call_clause'(G,M,Cl).
'$spycall'(G,M,Cl) :-
'$setflop'(0),
'$creepcallclause'(G,Cl).
'$creepcallclause'(G,M,Cl).
'$log_upd_spycall'(G,Cl,Index) :-
'$log_upd_spycall'(G,M,Cl,Index) :-
'$access_yap_flags'(10,0),
!,
'$setflop'(0),
'$call_log_updclause'(G,Cl,Index).
'$log_upd_spycall'(G,Cl,Index) :-
'$call_log_updclause'(G,M,Cl,Index).
'$log_upd_spycall'(G,M,Cl,Index) :-
'$setflop'(0),
'$creepcall_log_upd_clause'(G,Cl,Index).
'$creepcall_log_upd_clause'(G,M,Cl,Index).
% this is to be used only for dynamic predicates
'$spycall_dynamic'(G,Cl) :-
'$spycall_dynamic'(G,M,Cl) :-
'$access_yap_flags'(10,0),
!,
'$setflop'(0),
'$call_dynamic_clause'(G,Cl).
'$spycall_dynamic'(G,Cl) :-
'$call_dynamic_clause'(G,M,Cl).
'$spycall_dynamic'(G,M,Cl) :-
'$setflop'(0),
'$creepcall_dynamic_clause'(G,Cl).
'$creepcall_dynamic_clause'(G,M,Cl).
'$catch_spycall_stdpred'(G) :-
'$system_catch'('$spycall_stdpred'(G), Error, user:'$DebugError'(Error)).
'$catch_spycall_stdpred'(G,M) :-
'$system_catch'('$spycall_stdpred'(G,M), Error, user:'$DebugError'(Error)).
'$spycall_stdpred'(G) :-
'$spycall_stdpred'(G,M) :-
functor(G,F,N),
(
'$recorded'('$meta_predicate','$meta_predicate'(_,F,N,_),_) ->
user:'$meta_predicate'(F,M,N,_) ->
'$setflop'(1),
'$creep',
'$execute0'(G)
'$execute0'(G,M)
;
'$setflop'(1),
'$execute0'(G)
'$execute0'(G,M)
),
'$setflop'(0).
'$call_clause'(G,Cl) :-
'$system_catch'('$do_execute_clause'(G,Cl),Error,user:'$DebugError'(Error)).
'$call_clause'(G,M,Cl) :-
'$system_catch'('$do_execute_clause'(G,M,Cl),Error,user:'$DebugError'(Error)).
'$do_execute_clause'(G,Cl) :-
'$some_recordedp'(G), !,
'$do_execute_clause'(G,M,Cl) :-
'$some_recordedp'(M:G), !,
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
CP is '$last_choice_pt',
(
'$fetch_clause'(G,Cl,Clause),
(Clause = true -> true ; '$debug_catch_call'(Clause,CP) )
'$fetch_clause'(G,M,Cl,Clause),
(Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) )
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
).
'$do_execute_clause'(G,Cl) :-
'$execute'(G,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail.
'$do_execute_clause'(G,M,Cl) :-
'$execute'(G,M,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail.
'$call_log_updclause'(G,Cl,Index) :-
'$system_catch'('$do_execute_log_upd_clause'(G,Cl,Index),Error,user:'$DebugError'(Error)).
'$call_log_updclause'(G,M,Cl,Index) :-
'$system_catch'('$do_execute_log_upd_clause'(G,M,Cl,Index),Error,user:'$DebugError'(Error)).
'$do_execute_log_upd_clause'(G,Cl,Index) :-
'$do_execute_log_upd_clause'(G,M,Cl,Index) :-
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
CP is '$last_choice_pt',
(
(Index = [] ->
/* We have a single clause */
Cl = 1,
clause(G, Clause)
'$clause'(G, M, Clause)
;
Cl1 is Cl-1,
'$fetch_reference_from_index'(Index, Cl1, Ref),
instance(Ref, (G :- Clause))
),
(Clause = true -> true ; '$debug_catch_call'(Clause,CP) )
(Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) )
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
).
'$check_depth_for_interpreter'(10000000) :-
'$undefined'(get_depth_limit(_)), !.
'$undefined'(get_depth_limit(_), prolog), !.
'$check_depth_for_interpreter'(D1) :-
get_depth_limit(D0),
D0 =\= 0,
D1 is D0-1.
'$debug_catch_call'(Clause,CP) :-
'$system_catch'('$call'(Clause,CP,Clause),Error,user:'$DebugError'(Error)).
'$debug_catch_call'(Clause,M,CP) :-
'$system_catch'('$call'(Clause,CP,Clause,M),Error,user:'$DebugError'(Error)).
'$call_dynamic_clause'(G,Cl) :-
'$system_catch'('$do_execute_dynamic_clause'(G,Cl),Error,user:'$DebugError'(Error)).
'$call_dynamic_clause'(G,M,Cl) :-
'$system_catch'('$do_execute_dynamic_clause'(G,M,Cl),Error,user:'$DebugError'(Error)).
'$do_execute_dynamic_clause'(G,Cl) :-
'$do_execute_dynamic_clause'(G,M,Cl) :-
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
CP is '$last_choice_pt',
(
'$db_nb_to_ref'(Cl,G,Ref),
'$db_nb_to_ref'(Cl,M:G,Mod,Ref),
instance(Ref, (G :- Clause)),
(Clause = true -> true ; '$debug_catch_call'(Clause,CP) )
(Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) )
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
).
'$creepcallclause'(G,Cl) :-
'$system_catch'('$do_creep_execute'(G,Cl),Error,user:'$DebugError'(Error)).
'$creepcallclause'(G,M,Cl) :-
'$system_catch'('$do_creep_execute'(G,M,Cl),Error,user:'$DebugError'(Error)).
'$do_creep_execute'(G,Cl) :-
'$do_creep_execute'(G,M,Cl) :-
% fast skip should ignore source mode
'$get_value'(spy_fs,0),
'$some_recordedp'(G),
'$some_recordedp'(M:G),
!,
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
CP is '$last_choice_pt',
(
'$fetch_clause'(G,Cl,Clause),
'$fetch_clause'(G,M,Cl,Clause),
(Clause = true -> true ;
'$catch_creep_call'(Clause,CP)
'$catch_creep_call'(Clause,M,CP)
)
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
).
'$do_creep_execute'(G,Cl) :-
'$creep_execute'(G,Cl) ;
'$do_creep_execute'(G,M,Cl) :-
'$creep_execute'(G,M,Cl) ;
Next is Cl+1, '$set_value'(spy_cl,Next), fail.
'$creepcall_log_upd_clause'(G,Cl,Index) :-
'$system_catch'('$do_creep_log_upd_execute'(G,Cl,Index),Error,user:'$DebugError'(Error)).
'$creepcall_log_upd_clause'(G,M,Cl,Index) :-
'$system_catch'('$do_creep_log_upd_execute'(G,M,Cl,Index),Error,user:'$DebugError'(Error)).
'$do_creep_log_upd_execute'(G,Cl,Index) :-
'$do_creep_log_upd_execute'(G,M,Cl,Index) :-
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
( CP is '$last_choice_pt',
(Index = [] ->
/* We have a single clause */
Cl = 1,
clause(G, Clause)
'$clause'(G, M, Clause)
;
Cl1 is Cl-1,
'$fetch_reference_from_index'(Index, Cl1, Ref),
@ -592,30 +584,30 @@ debugging :-
),
(Clause = true -> true ;
% otherwise fast skip may try to interpret assembly builtins.
'$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,CP) ;
'$catch_creep_call'(Clause,CP)
'$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,M,CP) ;
'$catch_creep_call'(Clause,M,CP)
)
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
).
'$catch_creep_call'(Clause,CP) :-
'$system_catch'('$creep_call'(Clause,CP),Error,user:'$DebugError'(Error)).
'$catch_creep_call'(Clause,M,CP) :-
'$system_catch'('$creep_call'(Clause,M,CP),Error,user:'$DebugError'(Error)).
'$creepcall_dynamic_clause'(G,Cl) :-
'$system_catch'('$do_creep_execute_dynamic'(G,Cl),Error,user:'$DebugError'(Error)).
'$creepcall_dynamic_clause'(G,M,Cl) :-
'$system_catch'('$do_creep_execute_dynamic'(G,M,Cl),Error,user:'$DebugError'(Error)).
'$do_creep_execute_dynamic'(G,Cl) :-
'$do_creep_execute_dynamic'(G,M,Cl) :-
'$check_depth_for_interpreter'(D),
('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)),
('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)),
CP is '$last_choice_pt',
(
'$db_nb_to_ref'(Cl,G,Ref),
'$db_nb_to_ref'(Cl,M:G,Ref),
instance(Ref, (G :- Clause)),
(Clause = true -> true ;
% otherwise fast skip may try to interpret assembly builtins.
'$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,CP) ;
'$catch_creep_call'(Clause,CP)
'$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,M,CP) ;
'$catch_creep_call'(Clause,M,CP)
)
;
Next is Cl+1, '$set_value'(spy_cl,Next), fail
@ -623,14 +615,14 @@ debugging :-
'$leave_creep'.
'$creep_execute'(G,Cl) :-
'$creep_execute'(G,M,Cl) :-
'$creep',
'$execute'(G,Cl).
'$execute'(G,M,Cl).
'$fetch_clause'(G,ClNum,Body) :-
'$fetch_clause'(G,M,ClNum,Body) :-
% I'd like an easier way to keep a counter
'$set_value'('$fetching_clauses',1),
'$recordedp'(G,Clause,_),
'$recordedp'(M:G,Clause,_),
'$get_value'('$fetching_clauses',Num),
( Num = ClNum ->
!,
@ -643,140 +635,106 @@ debugging :-
%'$creep_call'(G,_) :- write(user_error,'$creepcall'(G)), nl(user_error), fail.
'$creep_call'(V,_) :- var(V), !,
throw(error(instantiation_error,meta_call(V))).
'$creep_call'(A,_) :- number(A), !,
throw(error(type_error(callable,A),meta_call(A))).
'$creep_call'(R,_) :- db_reference(R), !,
throw(error(type_error(callable,R),meta_call(R))).
'$creep_call'(M:G,CP) :- !,
'$mod_switch'(M, '$creep_call'(G,CP)),
'$current_module'(Module),
'$creep_call'(V,M,_) :- var(V), !,
throw(error(instantiation_error,meta_call(M:V))).
'$creep_call'(A,M,_) :- number(A), !,
throw(error(type_error(callable,A),meta_call(M:A))).
'$creep_call'(R,M,_) :- db_reference(R), !,
throw(error(type_error(callable,R),meta_call(M:R))).
'$creep_call'(M:G,_,CP) :- !,
'$creep_call'(G,M,CP).
'$creep_call'(fail,Module,_) :- !,
'$direct_spy'([Module|fail]).
'$creep_call'(fail,_) :- !,
'$current_module'(Module),
'$direct_spy'([Module|fail]).
'$creep_call'(false,_) :- !,
'$current_module'(Module),
'$creep_call'(false,Module,_) :- !,
'$direct_spy'([Module|false]).
'$creep_call'(true,_) :- !,
'$current_module'(Module),
'$creep_call'(true,Module,_) :- !,
'$direct_spy'([Module|true]).
'$creep_call'(otherwise,_) :- !,
'$current_module'(Module),
'$creep_call'(otherwise,Module,_) :- !,
'$direct_spy'([Module|otherwise]).
'$creep_call'((A,B),CP) :- !,
'$creep_call'(A,CP), '$creep_call'(B,CP).
'$creep_call'((X->Y; Z),CP) :- !,
( '$creep_call'(X,CP), !, '$creep_call'(Y,CP); '$creep_call'(Z,CP)).
'$creep_call'((A;B),CP) :- !,
('$creep_call'(A,CP) ; '$creep_call'(B,CP)).
'$creep_call'((A|B),CP) :- !,
('$creep_call'(A,CP) ; '$creep_call'(B,CP)).
'$creep_call'(atom(A),_) :- !,
'$current_module'(Module),
'$creep_call'((A,B),Module,CP) :- !,
'$creep_call'(A,Module,CP), '$creep_call'(B,Module,CP).
'$creep_call'((X->Y; Z),Module,CP) :- !,
( '$creep_call'(X,Module,CP), !, '$creep_call'(Y,Module,CP); '$creep_call'(Z,Module,CP)).
'$creep_call'((A;B),Module,CP) :- !,
('$creep_call'(A,Module,CP) ; '$creep_call'(B,Module,CP)).
'$creep_call'((A|B),Module,CP) :- !,
('$creep_call'(A,Module,CP) ; '$creep_call'(B,Module,CP)).
'$creep_call'(atom(A),Module,_) :- !,
'$direct_spy'([Module|atom(A)]).
'$creep_call'(atomic(A),_) :- !,
'$current_module'(Module),
'$creep_call'(atomic(A),Module,_) :- !,
'$direct_spy'([Module|atomic(A)]).
'$creep_call'(integer(A),_) :- !,
'$current_module'(Module),
'$creep_call'(integer(A),Module,_) :- !,
'$direct_spy'([Module|integer(A)]).
'$creep_call'(nonvar(A),_) :- !,
'$current_module'(Module),
'$creep_call'(nonvar(A),Module,_) :- !,
'$direct_spy'([Module|nonvar(A)]).
'$creep_call'(var(A),_) :- !,
'$current_module'(Module),
'$creep_call'(var(A),Module,_) :- !,
'$direct_spy'([Module|var(A)]).
'$creep_call'(number(A),_) :- !,
'$current_module'(Module),
'$creep_call'(number(A),Module,_) :- !,
'$direct_spy'([Module|number(A)]).
'$creep_call'(prismitive(A),_) :- !,
'$current_module'(Module),
'$creep_call'(prismitive(A),Module,_) :- !,
'$direct_spy'([Module|primitive(A)]).
'$creep_call'(compound(A),_) :- !,
'$current_module'(Module),
'$creep_call'(compound(A),Module,_) :- !,
'$direct_spy'([Module|compound(A)]).
'$creep_call'(float(A),_) :- !,
'$current_module'(Module),
'$creep_call'(float(A),Module,_) :- !,
'$direct_spy'([Module|float(A)]).
'$creep_call'(db_reference(A),_) :- !,
'$current_module'(Module),
'$creep_call'(db_reference(A),Module,_) :- !,
'$direct_spy'([Module|db_reference(A)]).
'$creep_call'(\+ X,_) :- !,
'$current_module'(Module),
'$creep_call'(\+ X,Module,_) :- !,
'$direct_spy'([Module|(\+ X)]).
'$creep_call'(not X,_) :- !,
'$current_module'(Module),
'$creep_call'(not X,Module,_) :- !,
'$direct_spy'([Module|not(X)]).
'$creep_call'(X=Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X=Y,Module,_) :- !,
'$direct_spy'([Module|X=Y]).
'$creep_call'(X\=Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X\=Y,Module,_) :- !,
'$direct_spy'([Module|X\=Y]).
'$creep_call'(X==Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X==Y,Module,_) :- !,
'$direct_spy'([Module|X==Y]).
'$creep_call'(X>Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X>Y,Module,_) :- !,
'$direct_spy'([Module|X>Y]).
'$creep_call'(X>=Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X>=Y,Module,_) :- !,
'$direct_spy'([Module|X>=Y]).
'$creep_call'(X<Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X<Y,Module,_) :- !,
'$direct_spy'([Module|X<Y]).
'$creep_call'(X=<Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X=<Y,Module,_) :- !,
'$direct_spy'([Module|X=<Y]).
'$creep_call'(X=:=Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X=:=Y,Module,_) :- !,
'$direct_spy'([Module|X=:=Y]).
'$creep_call'(X=\=Y,_) :- !,
'$current_module'(Module),
'$creep_call'(X=\=Y,Module,_) :- !,
'$direct_spy'([Module|X=\=Y]).
'$creep_call'(arg(X,Y,Z),_) :- !,
'$current_module'(Module),
'$creep_call'(arg(X,Y,Z),Module,_) :- !,
'$direct_spy'([Module|arg(X,Y,Z)]).
'$creep_call'(functor(X,Y,Z),_) :- !,
'$current_module'(Module),
'$creep_call'(functor(X,Y,Z),Module,_) :- !,
'$direct_spy'([Module|functor(X,Y,Z)]).
'$creep_call'((X->Y),CP) :- !,
'$creep_call'((X->Y),Module,CP) :- !,
CP1 is '$last_choice_pt',
'$creep_call'(X,CP),
'$creep_call'(X,Module,CP),
'$$cut_by'(CP1),
'$creep_call'(Y,CP).
'$creep_call'(!,CP) :- !,
'$current_module'(M),
'$direct_spy'([M|'!'(CP)]),
'$creep_call'(Y,Module,CP).
'$creep_call'(!,Module,CP) :- !,
'$direct_spy'([Module|'!'(CP)]),
% clean up any garbage left here by the debugger.
'$$cut_by'(CP).
'$creep_call'('$cut_by'(X),_) :- !,
'$creep_call'('$cut_by'(X),Module,_) :- !,
'$$cut_by'(X).
'$creep_call'(repeat,_) :- !,
'$current_module'(Module),
'$creep_call'(repeat,Module,_) :- !,
'$direct_spy'([Module|repeat]).
'$creep_call'([A|B],_) :- !,
'$current_module'(Module),
'$creep_call'([A|B],Module,_) :- !,
'$direct_spy'([Module|[A|B]]).
'$creep_call'(A,CP) :-
'$undefined'(A), !,
'$creep_call_undefined'(A,CP).
'$creep_call'(A,_) :-
'$current_module'(Module),
'$creep_call'(A,Module,CP) :-
'$undefined'(A,Module), !,
'$creep_call_undefined'(A,Module,CP).
'$creep_call'(A,Module,_) :-
'$direct_spy'([Module|A]).
'$creep_call_undefined'(A,CP) :-
'$creep_call_undefined'(A,M,CP) :-
functor(A,F,N),
'$current_module'(M),
'$recorded'('$import','$import'(S,M,F,N),_), !,
'$creep_call'(S:A,CP).
'$creep_call_undefined'(G, _) :-
( \+ '$undefined'(user:unknown_predicate_handler(_,_,_)),
user:unknown_predicate_handler(G,M,NG) ->
'$creep_call'(M:NG) ;
'$is_dynamic'(G) -> fail ;
'$creep_call_undefined'(G, M, _) :-
( \+ '$undefined'(unknown_predicate_handler(_,_,_), user),
user:unknown_predicate_handler(G,NM,NG) ->
'$creep_call'(NM:NG) ;
'$is_dynamic'(G, M) -> fail ;
'$recorded'('$unknown','$unknown'(M:G,US),_),
'$creep_call'(user:US,_)
).
@ -796,35 +754,31 @@ debugging :-
'$get_value'('$throw', true), !,
'$set_value'('$throw', false),
abort.
'$creep'([Module|'$trace'(P,G,L)]) :- !,
( Module=prolog -> '$trace'(P,G,L);
'$mod_switch'(Module, '$trace'(P,G,L))
).
'$creep'([Module|'$creep_call'(G,CP)]) :- !,
( Module=prolog -> '$creep_call'(G,CP);
'$mod_switch'(Module, '$creep_call'(G,CP) )
).
'$creep'([_|'$trace'(P,G,Module,L)]) :- !,
'$trace'(P,G,Module,L).
'$creep'([_|'$creep_call'(G,Mod,CP)]) :- !,
'$creep_call'(G,Mod,CP).
'$creep'([_|'$leave_creep']) :- !.
'$creep'(G) :- '$direct_spy'(G).
'$trace'(P,'!'(_),L) :- !,
'$trace'(P,!,L).
'$trace'(P,G,L) :-
'$chk'(P,L,G,SL),
'$msg'(P,G,L,SL).
'$trace'(_,_,_).
'$trace'(P,'!'(_),Mod,L) :- !,
'$trace'(P,!,Mod,L).
'$trace'(P,G,Mod,L) :-
'$chk'(P,L,G,Mod,SL),
'$msg'(P,G,Mod,L,SL).
'$trace'(_,_,_,_).
'$msg'(P,G,L,SL):-
'$msg'(P,G,Module,L,SL):-
flush_output(user_output),
flush_output(user_error),
'$get_value'(debug,1),
repeat,
('$pred_being_spied'(G) -> write(user_error,'*') ; write(user_error,' ')),
('$pred_being_spied'(G,Module) -> write(user_error,'*') ; write(user_error,' ')),
( SL = L -> write(user_error,'>') ; write(user_error,' ')),
write(user_error,' ('), write(user_error,L), write(user_error,') '),
write(user_error,P), write(user_error,': '),
( '$current_module'(Module), Module\=prolog,
Module\=user -> write(user_error,Module),write(user_error,':');
( Module\=prolog,
Module\=user -> write(user_error,Module),write(user_error,':');
true
),
'$debugger_write'(user_error,G),
@ -868,16 +822,16 @@ debugging :-
write(user_error,[chk,L,P,Leap,SP,SC,SL,FS,CL,G]), nl(user_error),
fail.
*/
'$chk'(_,_,[_|_],_) :- !, fail.
'$chk'(P,L,G,SL) :-
'$chk'(_,_,[_|_],_,_) :- !, fail.
'$chk'(P,L,G,Mod,SL) :-
'$get_value'(spy_leap,Leap),
(Leap = 0 -> true; % not leaping
('$pred_being_spied'(G) ; Leap = L), % leaping or quasileaping
('$pred_being_spied'(G,Mod) ; Leap = L), % leaping or quasileaping
'$set_value'(spy_leap,0) ),
'$get_value'(spy_sp,SP),
(SP = 0; SP = P), % the current skipport or no skipport
'$access_yap_flags'(10,SC),
(SC = 1; '$pred_being_spied'(G)),
(SC = 1; '$pred_being_spied'(G,Mod)),
'$get_value'(spy_sl,SL),
(SL = 0; SL = L, '$set_value'(spy_sl,0), '$set_value'(spy_fs,0)),
'$set_value'(spy_sp,0), !.
@ -1029,13 +983,13 @@ debugging :-
'$DebugError'(T) :- !,
throw(T).
'$init_spy_cl'(G) :-
'$init_spy_cl'(G,M) :-
% dynamic, immediate update procedure.
'$flags'(G,F,F), F /\ 16'2000 =\= 0, !,
( '$db_first_age'(G,A) ->
'$flags'(G,M,F,F), F /\ 16'2000 =\= 0, !,
( '$db_first_age'(M:G,A) ->
'$set_value'(spy_cl, A) ;
% no clauses for pred.
'$set_value'(spy_cl, 1) ).
'$init_spy_cl'(_) :-
'$init_spy_cl'(_,_) :-
'$set_value'(spy_cl, 1).

183
pl/depth_bound.yap
View File

@ -20,186 +20,3 @@
depth_bound_call(A,D) :-
'$execute_under_depth_limit'(A,D).
'$old_depth_bound_call'(A,D) :-
'$check_callable'(A,A),
'$user_call_depth_limited'(A, D).
'$user_call_depth_limited'(V,_) :- var(V), !,
throw(error(instantiation_error,V)).
'$user_call_depth_limited'(A,_) :- number(A), !,
throw(error(type_error(callable,A),A)).
'$user_call_depth_limited'(R,_) :- db_reference(R), !,
throw(error(type_error(callable,R),R)).
'$user_call_depth_limited'(A,D) :-
'$access_yap_flags'(10,V),
V \= 0, !,
'$save_current_choice_point'(CP),
'$spied_call_depth_limited'(A,CP,D).
'$user_call_depth_limited'(A,D) :-
'$save_current_choice_point'(CP),
'$call_depth_limited'(A,CP,D).
'$call_depth_limited'(M:G,CP,D) :- !,
( '$current_module'(M) ->
'$check_callable'(G,M:G),
'$call_depth_limited'(G,CP,D)
;
'$check_callable'(G,M:G),
'$mod_switch'(M,'$call_depth_limited'(G,CP,D) )
).
'$call_depth_limited'(fail,_,_) :- !, fail.
'$call_depth_limited'(false,_,_) :- !, false.
'$call_depth_limited'(true,_,_) :- !.
'$call_depth_limited'(otherwise,_,_) :- !.
'$call_depth_limited'((A,B),CP,D) :- !,
'$check_callable'(A,(A,B)),
D1 is D+1,
'$call_depth_limited'(A,CP,D1),
'$check_callable'(B,(A,B)),
'$call_depth_limited'(B,CP,D1).
'$call_depth_limited'((X->Y),CP,D) :- !,
'$check_callable'(X,(X->Y)),
CP1 is local_sp,
D1 is D+1,
'$call_depth_limited'(X,CP,D1),
'$$cut_by'(CP1),
'$check_callable'(Y,(X->Y)),
'$call_depth_limited'(Y,CP,D1).
'$call_depth_limited'((X->Y; Z),CP,D) :- !,
'$check_callable'(X,(X->Y;Z)),
D1 is D+1,
(
'$call_depth_limited'(X,CP,D1), !,
'$check_callable'(Y,(X->Y;Z)),
'$call_depth_limited'(Y,CP,D1)
;
'$check_callable'(Z,(X->Y;Z)),
'$call_depth_limited'(Z,CP,D1)
).
'$call_depth_limited'((A;B),CP,D) :- !,
'$check_callable'(A,(A;B)),
D1 is D+1,
(
'$call_depth_limited'(A,CP,D1)
;
'$check_callable'(B,(A;B)),
'$call_depth_limited'(B,CP,D1)
).
'$call_depth_limited'((A|B),CP,D) :- !,
'$check_callable'(A,(A|B)),
D1 is D+1,
(
'$call_depth_limited'(A,CP,D1)
;
'$check_callable'(B,(A|B)),
'$call_depth_limited'(B,CP,D1)
).
'$call_depth_limited'(\+ X,CP,D) :- !,
'$check_callable'(X, \+ X),
\+ '$call_depth_limited'(X,CP,D).
'$call_depth_limited'(not X,CP,D) :- !,
'$check_callable'(X, not X),
\+ '$call_depth_limited'(X,CP,D).
'$call_depth_limited'(!,CP,_) :- '$$cut_by'(CP).
'$call_depth_limited'(repeat,_,_) :- !, '$repeat'.
'$call_depth_limited'([A|B],_,_) :- !, '$csult'([A|B]).
'$call_depth_limited'(A,CP,D) :-
( '$undefined'(A) ->
functor(A,F,N), '$current_module'(M),
( '$recorded'('$import','$import'(S,M,F,N),_) ->
'$call_depth_limited'(S:A,CP,D) ;
get_depth_limit(D0),
'$set_depth_limit'(D),
'$undefp'([M|A]),
'$set_depth_limit'(D0),
'$ensure_env_for_call_depth_limited'
)
;
get_depth_limit(D0),
'$set_depth_limit'(D),
'$execute0'(A),
'$set_depth_limit'(D0),
'$ensure_env_for_call_depth_limited'
).
'$spied_call_depth_limited'(M:G,CP,D) :- !,
'$check_callable'(G,M:G),
'$mod_switch'(M,'$spied_call_depth_limited'(G,CP,D)).
'$spied_call_depth_limited'(fail,_,_) :- !, fail.
'$spied_call_depth_limited'(false,_,_) :- !, false.
'$spied_call_depth_limited'(true,_,_) :- !.
'$spied_call_depth_limited'(otherwise,_,_) :- !.
'$spied_call_depth_limited'((A,B),CP,D) :- !,
'$check_callable'(A,(A,B)),
D1 is D+1,
'$spied_call_depth_limited'(A,CP,D1),
'$check_callable'(B,(A,B)),
'$spied_call_depth_limited'(B,CP,D1).
'$spied_call_depth_limited'((X->Y),CP,D) :- !,
'$check_callable'(X,(X->Y)),
CP1 is local_sp,
D1 is D+1,
'$spied_call_depth_limited'(X,CP,D1),
'$$cut_by'(CP1),
'$check_callable'(Y,(X->Y)),
'$spied_call_depth_limited'(Y,CP,D1).
'$spied_call_depth_limited'((X->Y; Z),CP, D) :- !,
'$check_callable'(X,(X->Y;Z)),
D1 is D+1,
(
'$spied_call_depth_limited'(X,CP,D1), !,
'$check_callable'(Y,(X->Y;Z)),
'$spied_call_depth_limited'(Y,CP,D1)
;
'$check_callable'(Z,(X->Y;Z)),
'$spied_call_depth_limited'(Z,CP,D1)
).
'$spied_call_depth_limited'((A;B),CP,D) :- !,
'$check_callable'(A,(A;B)),
D1 is D+1,
(
'$spied_call_depth_limited'(A,CP,D1)
;
'$check_callable'(B,(A;B)),
'$spied_call_depth_limited'(B,CP,D1)
).
'$spied_call_depth_limited'((A|B),CP,D) :- !,
'$check_callable'(A,(A|B)),
D1 is D+1,
(
'$spied_call_depth_limited'(A,CP,D1)
;
'$check_callable'(B,(A|B)),
'$spied_call_depth_limited'(B,CP,D1)
).
'$spied_call_depth_limited'(\+ X,CP,D) :- !,
'$check_callable'(X, \+ X),
\+ '$spied_call_depth_limited'(X,CP,D).
'$spied_call_depth_limited'(not X,CP,D) :- !,
'$check_callable'(X, not X),
\+ '$spied_call_depth_limited'(X,CP,D).
'$spied_call_depth_limited'(!,CP,_) :- '$$cut_by'(CP).
'$spied_call_depth_limited'(repeat,_,_) :- !, '$repeat'.
'$spied_call_depth_limited'([A|B],_,_) :- !, '$csult'([A|B]).
'$spied_call_depth_limited'(A,CP,D) :-
( '$undefined'(A) ->
functor(A,F,N), '$current_module'(M),
( '$recorded'('$import','$import'(S,M,F,N),_) ->
'$spied_call_depth_limited'(S:A,CP,D) ;
get_depth_limit(D0),
'$set_depth_limit'(D),
'$spy'(A),
'$set_depth_limit'(D0),
'$ensure_env_for_call_depth_limited'
)
;
get_depth_limit(D0),
'$set_depth_limit'(D),
'$spy'(A),
'$set_depth_limit'(D0),
'$ensure_env_for_call_depth_limited'
).
'$ensure_env_for_call_depth_limited'.

74
pl/directives.yap
View File

@ -37,58 +37,60 @@
'$directive'(block(_)).
'$directive'(wait(_)).
'$exec_directive'(multifile(D), _) :-
'$system_catch'('$multifile'(D),
'$exec_directive'(multifile(D), _, M) :-
'$system_catch'('$multifile'(D, M),
Error,
user:'$LoopError'(Error)).
'$exec_directive'(discontiguous(D), _) :-
'$discontiguous'(D).
'$exec_directive'(op(D), _) :-
'$discontiguous'(D).
'$exec_directive'(initialization(D), _) :-
'$initialization'(D).
'$exec_directive'(parallel, _) :-
'$exec_directive'(discontiguous(D), _, M) :-
'$discontiguous'(D,M).
'$exec_directive'(initialization(D), _, M) :-
'$initialization'(M:D).
'$exec_directive'(parallel, _, _) :-
'$parallel'.
'$exec_directive'(sequential, _) :-
'$exec_directive'(sequential, _, _) :-
'$sequential'.
'$exec_directive'(sequential(G), _) :-
'$sequential_directive'(G).
'$exec_directive'(include(F), Status) :-
'$exec_directive'(sequential(G), _, M) :-
'$sequential_directive'(G, M).
'$exec_directive'(parallel(G), _, M) :-
'$parallel_directive'(G, M).
'$exec_directive'(include(F), Status, _) :-
'$include'(F, Status).
'$exec_directive'(module(N,P), Status) :-
'$exec_directive'(module(N,P), Status, _) :-
'$module'(Status,N,P).
'$exec_directive'(module(N,P,Op), Status) :-
'$exec_directive'(module(N,P,Op), Status, _) :-
'$module'(Status,N,P,Op).
'$exec_directive'(meta_predicate(P), _) :-
'$meta_predicate'(P).
'$exec_directive'(dynamic(P), _) :-
'$dynamic'(P).
'$exec_directive'(op(P,OPSEC,OP), _) :-
'$exec_directive'(meta_predicate(P), _, M) :-
'$meta_predicate'(P, M).
'$exec_directive'(dynamic(P), _, M) :-
'$dynamic'(P, M).
'$exec_directive'(op(P,OPSEC,OP), _, _) :-
op(P,OPSEC,OP).
'$exec_directive'(set_prolog_flag(F,V), _) :-
'$exec_directive'(set_prolog_flag(F,V), _, _) :-
set_prolog_flag(F,V).
'$exec_directive'(ensure_loaded(F), _) :-
'$exec_directive'(ensure_loaded(F), _, _) :-
'$ensure_loaded'(F).
'$exec_directive'(char_conversion(IN,OUT), _) :-
'$exec_directive'(char_conversion(IN,OUT), _, _) :-
char_conversion(IN,OUT).
'$exec_directive'(public(P), _) :-
'$public'(P).
'$exec_directive'(compile(F), _) :-
'$exec_directive'(public(P), _, M) :-
'$public'(P, M).
'$exec_directive'(compile(F), _, _) :-
'$compile'(F).
'$exec_directive'(reconsult(Fs), _) :-
'$exec_directive'(reconsult(Fs), _, _) :-
'$reconsult'(Fs).
'$exec_directive'(consult(Fs), _) :-
'$exec_directive'(consult(Fs), _, _) :-
'$consult'(Fs).
'$exec_directive'(block(BlockSpec), _) :-
'$exec_directive'(block(BlockSpec), _, _) :-
'$block'(BlockSpec).
'$exec_directive'(wait(BlockSpec), _) :-
'$exec_directive'(wait(BlockSpec), _, _) :-
'$wait'(BlockSpec).
'$exec_directive'(table(PredSpec), _, M) :-
'$table'(PredSpec, M).
'$exec_directives'((G1,G2), Mode) :- !,
'$exec_directives'(G1, Mode),
'$exec_directives'(G2, Mode).
'$exec_directives'(G, Mode) :-
'$exec_directive'(G, Mode).
'$exec_directives'((G1,G2), Mode, M) :- !,
'$exec_directives'(G1, Mode, M),
'$exec_directives'(G2, Mode, M).
'$exec_directives'(G, Mode, M) :-
'$exec_directive'(G, Mode, M).
@ -397,7 +399,7 @@ yap_flag(toplevel_hook,G) :- !,
yap_flag(typein_module,X) :-
var(X), !,
current_module(X).
'$current_module'(X).
yap_flag(typein_module,X) :-
module(X).

4
pl/errors.yap
View File

@ -59,8 +59,8 @@
print_message(force(_Severity), Msg) :- !,
print(user_error,Msg).
print_message(Severity, Msg) :-
\+ '$undefined'(user: portray_message(Severity, Msg)),
user: portray_message(Severity, Msg), !.
\+ '$undefined'(portray_message(Severity, Msg), user),
user:portray_message(Severity, Msg), !.
print_message(error,error(Msg,Where)) :-
'$output_error_message'(Msg, Where), !.
print_message(error,Throw) :-

7
pl/grammar.yap
View File

@ -64,10 +64,9 @@
'$t_body'((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
'$t_body'(T, ToFill, not_last, S, SR1, Tt),
'$t_body'(R, ToFill, Last, SR1, SR, Rt).
'$t_body'((T;R), ToFill, _Last, S, SR, (Tt;Rt)) :- !,
copy_term(ToFill,OtherToFill),
'$t_body'(T, OtherToFill, last, S, SR, Tt),
'$t_body'(R, ToFill, last, S, SR, Rt).
'$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
'$t_body'(T, _, last, S, SR, Tt),
'$t_body'(R, _, last, S, SR, Rt).
'$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !,
'$t_body'(G, ToFill, Last, S, SR, NG).
'$t_body'(T, filled_in, _, S, SR, Tt) :-

6
pl/init.yap
View File

@ -110,15 +110,17 @@ system_mode(verbose,off) :- '$set_value'('$verbose',off).
:- module(user).
:- multifile library_directory/1.
:- dynamic_predicate(library_directory/1, logical).
:- multifile goal_expansion/3.
:- dynamic_predicate(goal_expansion/3, logical).
:- multifile term_expansion/3.
:- multifile term_expansion/2.
:- dynamic_predicate(term_expansion/3, logical).
:- dynamic_predicate(term_expansion/2, logical).
:- get_value(system_library_directory,D), assert(library_directory(D)).

42
pl/listing.yap
View File

@ -20,39 +20,41 @@
*/
listing :-
'$current_predicate_no_modules'(_,Pred),
'$list_clauses'(Pred).
'$current_module'(Mod),
'$current_predicate_no_modules'(Mod,_,Pred),
'$list_clauses'(Mod,Pred).
listing.
listing(V) :- var(V), !. % ignore variables
listing(M:V) :- !,
'$mod_switch'(M,'$listing'(V)).
listing([]) :- !.
listing([X|Rest]) :-
!,
listing(X),
listing(Rest).
listing(X) :-
'$listing'(X).
listing(V) :-
'$current_module'(M),
'$listing'(V,M).
'$listing'(X) :-
'$listing'(V,_) :- var(V), !. % ignore variables
'$listing'(M:V,_) :- !,
'$listing'(V,M).
'$listing'([],_) :- !.
'$listing'([X|Rest], M) :-
!,
'$listing'(X, M),
'$listing'(Rest, M).
'$listing'(X, M) :-
'$funcspec'(X,Name,Arity),
'$current_predicate_no_modules'(Name,Pred),
'$current_predicate_no_modules'(M,Name,Pred),
functor(Pred,Name,Arity),
'$list_clauses'(Pred).
'$listing'(_).
'$list_clauses'(M,Pred).
'$listing'(_,_).
'$funcspec'(Name/Arity,Name,Arity) :- !, atom(Name).
'$funcspec'(Name,Name,_) :- atom(Name), !.
'$funcspec'(Name,_,_) :- write('! Invalid procedure specification : '),
write(Name), nl.
'$list_clauses'(Pred) :-
( '$recordedp'(Pred,_,_) -> nl ),
'$list_clauses'(M,Pred) :-
( '$recordedp'(M:Pred,_,_) -> nl ),
fail.
'$list_clauses'(Pred) :-
'$recordedp'(Pred,(Pred:-Body),_),
'$list_clauses'(M,Pred) :-
'$recordedp'(M:Pred,(Pred:-Body),_),
'$beautify_vars'((Pred:-Body)),
'$write_clause'(Pred,Body),
fail.

67
pl/modules.yap
View File

@ -202,9 +202,9 @@ module(N) :-
'$import'([N/K|L],M,T) :-
integer(K), atom(N), !,
( '$check_import'(M,T,N,K) ->
% format(user_error,'[Importing ~w to ~w]~n',[M:N/K,T]),
% format(user_error,'[vsc1: Importing ~w to ~w]~n',[M:N/K,T]),
( T = user ->
recordz('$import','$import'(M,_,N,K),_)
recordz('$import','$import'(M,user,N,K),_)
;
recorda('$import','$import'(M,T,N,K),_)
)
@ -241,8 +241,9 @@ module(N) :-
( '$check_import'(M,Mod,N,K) ->
% format(user_error,'[ Importing ~w to ~w]~n',[M:N/K,Mod]),
% '$trace_module'(importing(M:N/K,Mod)),
% format(user_error,'[vsc2: Importing ~w to ~w]~n',[M:N/K,T]),
(Mod = user ->
recordz('$import','$import'(M,_,N,K),_)
recordz('$import','$import'(M,user,N,K),_)
;
recorda('$import','$import'(M,Mod,N,K),_)
)
@ -250,7 +251,6 @@ module(N) :-
true
).
'$abolish_module_data'(M) :-
'$current_module'(T),
( '$recorded'('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true),
@ -261,16 +261,14 @@ module(N) :-
% expand module names in a clause
'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO)) :- !,
'$current_module'(M),
'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !,
'$prepare_body_with_correct_modules'(B, M, B0),
'$module_u_vars'(H,UVars), % collect head variables in
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$module_expansion'(B0,B1,BO,M,M,M,UVars). % expand body
'$module_expansion'((H:-B),(H:-B1),(H:-BO)) :-
'$module_u_vars'(H,UVars), % collect head variables in
'$module_expansion'((H:-B),(H:-B1),(H:-BO),M) :-
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$current_module'(M),
'$module_expansion'(B,B1,BO,M,M,M,UVars). % expand body
% $trace_module((H:-B),(H:-B1)).
@ -317,16 +315,16 @@ module(N) :-
%
'$exec_with_expansion'(G0, GoalMod, CurMod) :-
'$meta_expansion'(GoalMod, CurMod, G0, GF, []), !,
'$mod_switch'(GoalMod,'$exec_with_expansion2'(GF,GoalMod)).
'$exec_with_expansion2'(GF,GoalMod).
'$exec_with_expansion'(G, GoalMod, _) :-
'$mod_switch'(GoalMod,'$exec_with_expansion2'(G,GoalMod)).
'$exec_with_expansion2'(G,GoalMod).
'$exec_with_expansion2'(G, M) :-
'$pred_goal_expansion_on',
user:goal_expansion(G,M,GF), !,
'$execute'(M:GF).
'$exec_with_expansion2'(G, _) :- !,
'$execute0'(G).
'$exec_with_expansion2'(G, M) :- !,
'$execute0'(G, M).
% expand module names in a body
@ -385,7 +383,7 @@ module(N) :-
'$imported_pred'(G, ImportingMod, ExportingMod) :-
'$undefined'(ImportingMod:G),
'$undefined'(G, ImportingMod),
functor(G,F,N),
'$recorded'('$import','$import'(ExportingMod,ImportingMod,F,N),_),
ExportingMod \= ImportingMod.
@ -412,30 +410,31 @@ module(N) :-
% directive now meta_predicate Ps :- $meta_predicate(Ps).
'$meta_predicate'((P,Ps)) :- !,
'$meta_predicate'(P),
'$meta_predicate'(Ps).
'$meta_predicate'(P) :-
:- dynamic user:'$meta_predicate'/4.
'$meta_predicate'((P,Ps), M) :- !,
'$meta_predicate'(P, M),
'$meta_predicate'(Ps, M).
'$meta_predicate'(M:D, _) :- !,
'$meta_predicate'(D, M).
'$meta_predicate'(P, M1) :-
functor(P,F,N),
'$current_module'(M1),
( M1 = prolog -> M = _ ; M1 = M),
( retractall('$meta_predicate'(F,M,N,_)), fail ; true),
asserta('$meta_predicate'(F,M,N,P)),
'$flags'(P, Fl, Fl),
( retractall(user:'$meta_predicate'(F,M,N,_)), fail ; true),
asserta(user:'$meta_predicate'(F,M,N,P)),
'$flags'(P, M1, Fl, Fl),
NFlags is Fl \/ 0x200000,
'$flags'(P, Fl, NFlags).
'$flags'(P, M1, Fl, NFlags).
% return list of vars in expanded positions on the head of a clause.
%
% these variables should not be expanded by meta-calls in the body of the goal.
%
'$module_u_vars'(H,UVars) :-
'$module_u_vars'(H,UVars,M) :-
functor(H,F,N),
'$current_module'(M),
% '$recorded'('$meta_predicate','$meta_predicate'(M,F,N,D),_), !,
'$meta_predicate'(F,M,N,D), !,
user:'$meta_predicate'(F,M,N,D), !,
'$module_u_vars'(N,D,H,UVars).
'$module_u_vars'(_,[]).
'$module_u_vars'(_,[],_).
'$module_u_vars'(0,_,_,[]) :- !.
'$module_u_vars'(I,D,H,[Y|L]) :-
@ -452,8 +451,7 @@ module(N) :-
'$meta_expansion'(Mod,MP,G,G1,HVars) :-
functor(G,F,N),
% '$recorded'('$meta_predicate','$meta_predicate'(Mod,F,N,D),_), !,
'$meta_predicate'(F,Mod,N,D), !,
user:'$meta_predicate'(F,Mod,N,D), !,
functor(G1,F,N),
% format(user_error,'[expanding ~w:~w in ~w',[Mod,G,MP]),
'$meta_expansion_loop'(N,D,G,G1,HVars,MP).
@ -493,10 +491,6 @@ source_module(Mod) :-
'$member'(X,[X|_]) :- !.
'$member'(X,[_|L]) :- '$member'(X,L).
%
% this declaration should only be here, as meta_predicates should belong
% to the user module, not to the prolog module
:- meta_predicate
% [:,:],
abolish(:),
@ -560,7 +554,7 @@ source_module(Mod) :-
% a:assert(g :- user:b))
%
'$preprocess_clause_before_mod_change'((H:-B),M,M1,(H:-B1)) :-
'$mod_switch'(M1,'$module_u_vars'(H,UVars)),
'$module_u_vars'(H,UVars,M1),
'$preprocess_body_before_mod_change'(B,M,UVars,B1).
'$preprocess_body_before_mod_change'(V,M,_,call(M:V)) :- var(V), !.
@ -583,6 +577,5 @@ source_module(Mod) :-
'$system_predicate'(G), !.
'$preprocess_body_before_mod_change'(G,M,_,M:G).
:- '$switch_log_upd'(0).

558
pl/preds.yap
View File

@ -20,69 +20,75 @@
asserta(V) :- var(V), !,
throw(error(instantiation_error,asserta(V))).
asserta(C) :- '$assert'(C,first,_,asserta(C)).
asserta(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,first,_,asserta(C)).
assertz(V) :- var(V), !,
throw(error(instantiation_error,assertz(V))).
assertz(C) :- '$assert'(C,last,_,assertz(C)).
assertz(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,last,_,assertz(C)).
assert(V) :- var(V), !,
throw(error(instantiation_error,assert(V))).
assert(C) :- '$assert'(C,last,_,assert(C)).
assert(C) :-
'$current_module'(Mod),
'$assert'(C,Mod,last,_,assert(C)).
'$assert'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert'(C,Where,R,P)).
'$assert'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
'$current_module'(M1),
'$assert'(V,Mod,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(Mod:V))).
'$assert'(M:C,_,Where,R,P) :- !,
'$assert'(C,M,Where,R,P).
'$assert'((H:-G),M1,Where,R,P) :-
(var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
( M1 = M ->
'$assert'((C:-G),Where,R,P)
'$assert'((C:-G),M1,Where,R,P)
;
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
'$mod_switch'(M,'$assert'(C1,Where,R,P))
'$assert'(C1,M,Where,R,P)
).
'$assert'(CI,Where,R,P) :-
'$expand_clause'(CI,C0,C),
'$assert'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod),
'$check_head_and_body'(C,H,B,P),
( '$is_dynamic'(H) ->
'$assertat_d'(Where,H,B,C0,R)
( '$is_dynamic'(H, Mod) ->
'$assertat_d'(Where, H, B, C0, Mod, R)
;
'$undefined'(H) ->
'$undefined'(H,Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar),
'$assertat_d'(Where,H,B,C0,R)
'$assertat_d'(Where,H,B,C0,Mod,R)
;
'$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode
'$assert1'(Where,C,C0,H)
'$assert1'(Where,C,C0,Mod,H)
;
functor(H, Na, Ar),
throw(error(permission_error(modify,static_procedure,Na/Ar),P))
).
'$assert_dynamic'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert_dynamic'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert_dynamic'(C,Where,R,P)).
'$assert_dynamic'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
'$current_module'(M1),
'$assert_dynamic'(V,Mod,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(Mod:V))).
'$assert_dynamic'(M:C,_,Where,R,P) :- !,
'$assert_dynamic'(C,Mod,Where,R,P).
'$assert_dynamic'((H:-G),M1,Where,R,P) :-
(var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
( M1 = M ->
'$assert_dynamic'((C:-G),Where,R,P)
'$assert_dynamic'((C:-G),M1,Where,R,P)
;
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
'$mod_switch'(M,'$assert_dynamic'(C1,Where,R,P))
'$assert_dynamic'(C1,M,Where,R,P)
).
'$assert_dynamic'(CI,Where,R,P) :-
'$expand_clause'(CI,C0,C),
'$assert_dynamic'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod),
'$check_head_and_body'(C,H,B,P),
( '$is_dynamic'(H) ->
'$assertat_d'(Where,H,B,C0,R)
( '$is_dynamic'(H, Mod) ->
'$assertat_d'(Where,H,B,C0,Mod,R)
;
'$undefined'(H) ->
'$undefined'(H, Mod) ->
functor(H, Na, Ar),
'$dynamic'(Na/Ar),
'$assertat_d'(Where,H,B,C0,R)
'$assertat_d'(Where,H,B,C0,Mod,R)
;
functor(H,Na,Ar),
throw(error(permission_error(modify,static_procedure,Na/Ar),P))
@ -90,197 +96,223 @@ assert(C) :- '$assert'(C,last,_,assert(C)).
assert_static(V) :- var(V), !,
throw(error(instantiation_error,assert_static(V))).
assert_static(C) :- '$assert_static'(C,last,_,assert_static(C)).
assert_static(C) :-
'$current_module'(Mod),
'$assert_static'(C,Mod,last,_,assert_static(C)).
asserta_static(V) :- var(V), !,
throw(error(instantiation_error,asserta_static(V))).
asserta_static(C) :- '$assert_static'(C,first,_,asserta_static(C)).
asserta_static(C) :-
'$current_module'(Mod),
'$assert_static'(C,Mod,first,_,asserta_static(C)).
assertz_static(V) :- var(V), !,
throw(error(instantiation_error,assertz_static(V))).
assertz_static(C) :-
'$assert_static'(C,last,_,assertz_static(C)).
'$current_module'(Mod),
'$assert_static'(C,Mod,last,_,assertz_static(C)).
'$assert_static'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert_static'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert_static'(C,Where,R,P)).
'$assert_static'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
'$current_module'(M1),
'$assert_static'(V,M,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(M:V))).
'$assert_static'(M:C,_,Where,R,P) :- !,
'$assert_static'(C,M,Where,R,P).
'$assert_static'((H:-G),M1,Where,R,P) :-
(var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
( M1 = M ->
'$assert_static'((C:-G),Where,R,P)
'$assert_static'((C:-G),M1,Where,R,P)
;
'$preprocess_clause_before_mod_change'((C:-G),M1,M,C1),
'$mod_switch'(M,'$assert_static'(C1,Where,R,P))
'$assert_static'(C1,M,Where,R,P)
).
'$assert_static'(CI,Where,R,P) :-
'$expand_clause'(CI,C0,C),
'$assert_static'(CI,Mod,Where,R,P) :-
'$expand_clause'(CI,C0,C,Mod),
'$check_head_and_body'(C,H,B,P),
( '$is_dynamic'(H) ->
( '$is_dynamic'(H, Mod) ->
throw(error(permission_error(modify,dynamic_procedure,Na/Ar),P))
;
'$undefined'(H), '$get_value'('$full_iso',true) ->
functor(H,Na,Ar), '$dynamic'(Na/Ar), '$assertat_d'(Where,H,B,C0,R)
'$undefined'(H,Mod), '$get_value'('$full_iso',true) ->
functor(H,Na,Ar), '$dynamic'(Na/Ar), '$assertat_d'(Where,H,B,C0,Mod,R)
;
'$assert1'(Where,C,C0,H)
'$assert1'(Where,C,C0,Mod,H)
).
'$assertat_d'(first,Head,Body,C0,R) :- !,
'$compile_dynamic'((Head:-Body),2,CR),
'$assertat_d'(first,Head,Body,C0,Mod,R) :- !,
'$compile_dynamic'((Head:-Body), 2, Mod, CR),
( '$get_value'('$abol',true)
->
'$flags'(H,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true )
'$flags'(H,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordap'(Head,(H0 :- B0),R,CR),
functor(Head,Na,Ar),
( '$is_multifile'(Na,Ar) ->
'$recordap'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(Head, Mod) ->
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), _)
functor(H0, Na, Ar),
'$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$assertat_d'(last,Head,Body,C0,R) :-
'$compile_dynamic'((Head:-Body),0,CR),
'$assertat_d'(last,Head,Body,C0,Mod,R) :-
'$compile_dynamic'((Head:-Body), 0, Mod, CR),
( '$get_value'('$abol',true)
->
'$flags'(H,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true )
'$flags'(H,Mod,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordzp'(Head,(H0 :- B0),R,CR),
functor(H0,Na,Ar),
( '$is_multifile'(Na,Ar) ->
'$recordzp'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(H0, Mod) ->
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), _)
functor(H0, Na, Ar),
'$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$assert1'(last,C,C0,H) :- '$$compile_stat'(C,C0,0,H).
'$assert1'(first,C,C0,H) :- '$$compile_stat'(C,C0,2,H).
'$assert1'(last,C,C0,Mod,H) :- '$$compile_stat'(C,C0,0,H,Mod).
'$assert1'(first,C,C0,Mod,H) :- '$$compile_stat'(C,C0,2,H,Mod).
'$assertz_dynamic'(X,C,C0) :- (X/\4)=:=0, !,
'$assertz_dynamic'(X, C, C0, Mod) :- (X/\4)=:=0, !,
'$head_and_body'(C,H,B),
'$assertat_d'(last,H,B,C0,_).
'$assertz_dynamic'(X,C,C0) :-
'$assertat_d'(last,H,B,C0,Mod,_).
'$assertz_dynamic'(X,C,C0,Mod) :-
'$head_and_body'(C,H,B), functor(H,N,A),
('$check_if_reconsulted'(N,A) ->
true
;
(X/\8)=:=0 ->
'$inform_as_reconsulted'(N,A),
'$remove_all_d_clauses'(H)
'$remove_all_d_clauses'(H,Mod)
;
true
),
'$assertat_d'(last,H,B,C0,_).
'$assertat_d'(last,H,B,C0,Mod,_).
'$remove_all_d_clauses'(H) :-
'$remove_all_d_clauses'(H,M) :-
'$is_multifile'(H, M), !,
functor(H, Na, A),
'$is_multifile'(Na,A), !,
'$erase_all_mf_dynamic'(Na,A).
'$remove_all_d_clauses'(H) :-
'$recordedp'(H,_,R), erase(R), fail.
'$remove_all_d_clauses'(_).
'$erase_all_mf_dynamic'(Na,A,M).
'$remove_all_d_clauses'(H,M) :-
'$recordedp'(M:H,_,R), erase(R), fail.
'$remove_all_d_clauses'(_,_).
'$erase_all_mf_dynamic'(Na,A) :-
'$erase_all_mf_dynamic'(Na,A,M) :-
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1),
erase(R),
fail.
'$erase_all_mf_dynamic'(_,_).
'$erase_all_mf_dynamic'(_,_,_).
asserta(V,R) :- var(V), !,
throw(error(instantiation_error,asserta(V,R))).
asserta(C,R) :- '$assert_dynamic'(C,first,R,asserta(C,R)).
asserta(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,first,R,asserta(C,R)).
assertz(V,R) :- var(V), !,
throw(error(instantiation_error,assertz(V,R))).
assertz(C,R) :- '$assert_dynamic'(C,last,R,assertz(C,R)).
assertz(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,last,R,assertz(C,R)).
assert(V,R) :- var(V), !,
throw(error(instantiation_error,assert(V,R))).
assert(C,R) :- '$assert_dynamic'(C,last,R,assert(C,R)).
assert(C,R) :-
'$current_module'(M),
'$assert_dynamic'(C,M,last,R,assert(C,R)).
clause(V,Q) :- var(V), !,
throw(error(instantiation_error,clause(V,Q))).
clause(C,Q) :- number(C), !,
throw(error(type_error(callable,C),clause(C,Q))).
clause(R,Q) :- db_reference(R), !,
throw(error(type_error(callable,R),clause(R,Q))).
clause(M:P,Q) :- !,
'$mod_switch'(M,clause(P,Q)).
clause(P,Q) :- '$is_dynamic'(P), !,
'$recordedp'(P,(P:-Q),_).
clause(P,Q) :-
'$some_recordedp'(P), !,
'$recordedp'(P,(P:-Q),_).
clause(P,Q) :-
clause(V,Q) :-
'$current_module'(M),
'$clause'(V,M,Q).
'$clause'(V,M,Q) :- var(V), !,
throw(error(instantiation_error,M:clause(V,Q))).
'$clause'(C,M,Q) :- number(C), !,
throw(error(type_error(callable,C),M:clause(C,Q))).
'$clause'(R,Q) :- db_reference(R), !,
throw(error(type_error(callable,R),M:clause(R,Q))).
'$clause'(M:P,_,Q) :- !,
'$clause'(P,M,Q).
'$clause'(P,Mod,Q) :- '$is_dynamic'(P, Mod), !,
'$recordedp'(Mod:P,(P:-Q),_).
'$clause'(P,M,Q) :-
'$some_recordedp'(M:P), !,
'$recordedp'(M:P,(P:-Q),_).
'$clause'(P,M,Q) :-
( '$system_predicate'(P) -> true ;
'$number_of_clauses'(P,N), N > 0 ),
'$number_of_clauses'(P,M,N), N > 0 ),
functor(P,Name,Arity),
throw(error(permission_error(access,private_procedure,Name/Arity),
clause(P,Q))).
throw(error(permission_error(access,private_procedure,M:Name/Arity),
M:clause(P,Q))).
clause(V,Q,R) :- var(V), !,
throw(error(instantiation_error,clause(V,Q,R))).
clause(C,Q,R) :- number(C), !,
throw(error(type_error(callable,C),clause(C,Q,R))).
clause(R,Q,R1) :- db_reference(R), !,
clause(V,Q,R) :-
'$current_module'(V,M,Q,R),
'$clause'(V,M,Q,R).
'$clause'(V,M,Q,R) :- var(V), !,
throw(error(instantiation_error,M:clause(V,Q,R))).
'$clause'(C,M,Q,R) :- number(C), !,
throw(error(type_error(callable,C),clause(C,M:Q,R))).
'$clause'(R,M,Q,R1) :- db_reference(R), !,
throw(error(type_error(callable,R),clause(R,Q,R1))).
clause(M:P,Q,R) :- !,
'$mod_switch'(M,clause(P,Q,R)).
clause(P,Q,R) :-
( '$is_dynamic'(P) ->
'$recordedp'(P,(P:-Q),R)
'$clause'(M:P,_,Q,R) :- !,
'$clause'(P,M,Q,R).
'$clause'(P,Mod,Q,R) :-
( '$is_dynamic'(P, Mod) ->
'$recordedp'(Mod:P,(P:-Q),R)
;
functor(P,N,A),
throw(error(permission_error(access,private_procedure,N/A),
throw(error(permission_error(access,private_procedure,Mod:N/A),
clause(P,Q,R)))
).
retract(V) :- var(V), !,
throw(error(instantiation_error,retract(V))).
retract(M:C) :- !,
'$mod_switch'(M,retract(C)).
retract(C) :-
'$check_head_and_body'(C,H,B,retract(C)),
'$is_dynamic'(H), !,
'$recordedp'(H,(H:-B),R), erase(R).
retract(C) :-
'$current_module'(M),
'$retract'(C,M).
'$retract'(V,_) :- var(V), !,
throw(error(instantiation_error,retract(V))).
'$retract'(M:C,_) :- !,
'$retract'(C,M).
'$retract'(C,M) :-
'$check_head_and_body'(C,H,B,retract(C)),
'$is_dynamic'(H, M), !,
'$recordedp'(M:H,(H:-B),R), erase(R).
'$retract'(C,M) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
throw(error(permission_error(modify,static_procedure,PI),retract(C))).
throw(error(permission_error(modify,static_procedure,PI),retract(M:C))).
retract(V,R) :- var(V), !,
throw(error(instantiation_error,retract(V,R))).
retract(M:C,R) :- !,
'$mod_switch'(M,retract(C,R)).
retract(C,R) :-
retract(C,R) :- !,
'$current_module'(M),
'$retract'(C,M,R).
'$retract'(V,M,R) :- var(V), !,
throw(error(instantiation_error,retract(M:V,R))).
'$retract'(M:C,_,R) :- !,
'$retract'(C,M,R).
'$retract'(C, M, R) :-
'$check_head_and_body'(C,H,B,retract(C,R)),
db_reference(R), '$is_dynamic'(H), !,
db_reference(R), '$is_dynamic'(H,M), !,
instance(R,(H:-B)), erase(R).
retract(C,R) :-
'$retract'(C,M,R) :-
'$head_and_body'(C,H,B,retract(C,R)),
'$is_dynamic'(H), !,
'$is_dynamic'(H,M), !,
var(R),
'$recordedp'(H,(H:-B),R),
'$recordedp'(M:H,(H:-B),R),
erase(R).
retract(C,_) :-
'$retract'(C,M,_) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
throw(error(permission_error(modify,static_procedure,PI),retract(C))).
throw(error(permission_error(modify,static_procedure,PI),retract(M:C))).
'$fetch_predicate_indicator_from_clause'((C :- _), Na/Ar) :- !,
functor(C, Na, Ar).
@ -288,66 +320,75 @@ retract(C,_) :-
functor(C, Na, Ar).
retractall(V) :- var(V), !,
throw(error(instantiation_error,retract(V))).
retractall(M:V) :- !,
'$mod_switch'(M,retractall(V)).
retractall(T) :- '$undefined'(T),
functor(T, Na, Ar),
'$dynamic'(Na/Ar),
retractall(V) :- !,
'$current_module'(M),
'$retractall'(V,M).
'$retractall'(V,M) :- var(V), !,
throw(error(instantiation_error,retract(M:V))).
'$retractall'(M:V,_) :- !,
'$retractall'(V,M).
'$retractall'(T,M) :-
'$undefined'(T,M),
functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !,
fail.
retractall(T) :- \+ '$is_dynamic'(T), !,
'$retractall'(T,M) :-
\+ '$is_dynamic'(T,M), !,
functor(T,Na,Ar),
throw(error(permission_error(modify,static_procedure,Na/Ar),retractall(T))).
retractall(T) :-
'$erase_all_clauses_for_dynamic'(T).
'$retractall'(T,M) :-
'$erase_all_clauses_for_dynamic'(T, M).
'$erase_all_clauses_for_dynamic'(T) :-
'$recordedp'(T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T) :-
'$recordedp'(T,_,_), fail.
'$erase_all_clauses_for_dynamic'(_).
'$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T,M) :-
'$recordedp'(M:T,_,_), fail.
'$erase_all_clauses_for_dynamic'(_,_).
abolish(N,A) :- var(N), !,
throw(error(instantiation_error,abolish(N,A))).
abolish(N,A) :- var(A), !,
throw(error(instantiation_error,abolish(N,A))).
abolish(M:N,A) :- !,
'$mod_switch'(M,abolish(N,A)).
abolish(N,A) :-
abolish(N,A) :-
'$current_module'(Mod),
'$abolish'(N,A,Mod).
'$abolish'(N,A,M) :- var(N), !,
throw(error(instantiation_error,abolish(M:N,A))).
'$abolish'(N,A,M) :- var(A), !,
throw(error(instantiation_error,abolish(M:N,A))).
throw(error(instantiation_error,abolish(M:N,A))).
'$abolish'(N,A,M) :-
( '$recorded'('$predicate_defs','$predicate_defs'(N,A,_),R) -> erase(R) ),
fail.
abolish(N,A) :- functor(T,N,A),
( '$is_dynamic'(T) -> '$abolishd'(T) ;
/* else */ '$abolishs'(T) ).
'$abolish'(N,A,M) :- functor(T,N,A),
( '$is_dynamic'(T) -> '$abolishd'(T,M) ;
/* else */ '$abolishs'(T,M) ).
abolish(X) :-
'$access_yap_flags'(8, 2), !,
'$new_abolish'(X).
abolish(X) :-
'$old_abolish'(X).
'$new_abolish'(V) :- var(V), !,
'$abolish_all'.
'$new_abolish'(M:PS) :- !,
'$mod_switch'(M,'$new_abolish'(PS)).
'$new_abolish'(Na/Ar) :-
functor(H, Na, Ar),
'$is_dynamic'(H), !,
'$abolishd'(H).
'$new_abolish'(Na/Ar) :- % succeed for undefined procedures.
functor(T, Na, Ar),
'$undefined'(T), !.
'$new_abolish'(Na/Ar) :-
'$current_module'(M),
'$new_abolish'(X,M).
abolish(X,M) :-
'$old_abolish'(X,M).
'$new_abolish'(V,M) :- var(V,N), !,
'$abolish_all'(M).
'$new_abolish'(M:PS,_) :- !,
'$new_abolish'(PS,M).
'$new_abolish'(Na/Ar, M) :-
functor(H, Na, Ar),
'$is_dynamic'(H, M), !,
'$abolishd'(H, M).
'$new_abolish'(Na/Ar, M) :- % succeed for undefined procedures.
functor(T, Na, Ar),
'$undefined'(T, M), !.
'$new_abolish'(Na/Ar, M) :-
throw(error(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar))).
'$abolish_all' :-
current_predicate(_,P),
'$abolish_all'(M) :-
'$current_predicate'(M,_,P),
functor(P, Na, Ar),
'$new_abolish'(Na/Ar),
'$new_abolish'(Na/Ar, M),
fail.
'$abolish_all'.
'$abolish_all'(_).
'$check_error_in_predicate_indicator'(V, Msg) :-
var(V), !,
@ -385,92 +426,93 @@ abolish(X) :-
\+ atom(M), !,
throw(error(type_error(atom,M), Msg)).
'$old_abolish'(V) :- var(V), !,
'$abolish_all_old'.
'$old_abolish'(M:N) :- !,
'$mod_switch'(M,'$old_abolish'(N)).
'$old_abolish'([]) :- !.
'$old_abolish'([H|T]) :- !, abolish(H), abolish(T).
'$old_abolish'(N/A) :- abolish(N,A).
'$old_abolish'(V,M) :- var(V), !,
'$abolish_all_old'(M).
'$old_abolish'(M:N,_) :- !,
'$old_abolish'(N,M).
'$old_abolish'([], _) :- !.
'$old_abolish'([H|T], M) :- !, '$old_abolish'(H, M), '$old_abolish'(T, M).
'$old_abolish'(N/A, M) :-
'$abolish'(N, A, M).
'$abolish_all_old' :-
current_predicate(_,P),
'$abolish_all_old'(M) :-
'$current_predicate'(Mod,_,P),
functor(P, Na, Ar),
'$abolish_old'(Na/Ar),
'$old_abolish'(Na/Ar, Mod),
fail.
'$abolish_all_old'.
'$abolishd'(T) :- '$recordedp'(T,_,R), erase(R), fail.
'$abolishd'(T) :- '$kill_dynamic'(T), fail.
'$abolishd'(_).
'$abolishd'(T, M) :- '$recordedp'(M:T,_,R), erase(R), fail.
'$abolishd'(T, M) :- '$kill_dynamic'(T,M), fail.
'$abolishd'(_, _).
'$abolishs'(G) :- '$in_use'(G), !,
'$abolishs'(G, M) :- '$in_use'(G, M), !,
functor(G,Name,Arity),
throw(error(permission_error(modify,static_procedure_in_use,Name/Arity),abolish(G))).
'$abolishs'(G) :- '$system_predicate'(G), !,
throw(error(permission_error(modify,static_procedure_in_use,M:Name/Arity),abolish(G))).
'$abolishs'(G, _) :- '$system_predicate'(G), !,
functor(G,Name,Arity),
throw(error(permission_error(modify,static_procedure,Name/Arity),abolish(G))).
'$abolishs'(G) :-
throw(error(permission_error(modify,static_procedure,M:Name/Arity),abolish(G))).
'$abolishs'(G, Module) :-
'$access_yap_flags'(8, 2), % only do this in sicstus mode
'$undefined'(G),
'$undefined'(G, Module),
functor(G,Name,Arity),
'$current_module'(Module),
format(user_error,'[ Warning: abolishing undefined predicate (~w:~w/~w) ]~n',[Module,Name,Arity]),
fail.
% I cannot allow modifying static procedures in YAPOR
% this code has to be here because of abolish/2
'$abolishs'(G) :-
'$abolishs'(G, Module) :-
'$has_yap_or', !,
functor(G,A,N),
throw(error(permission_error(modify,static_procedure,A/N),abolish(G))).
'$abolishs'(G) :-
'$purge_clauses'(G),
'$recordedp'(G,_,R), erase(R), fail.
'$abolishs'(_).
throw(error(permission_error(modify,static_procedure,Module:A/N),abolish(G))).
'$abolishs'(G, M) :-
'$purge_clauses'(G, M),
'$recordedp'(M:G,_,R), erase(R), fail.
'$abolishs'(_, _).
%
% can only do as goal in YAP mode.
%
dynamic(X) :- '$access_yap_flags'(8, 0), !,
'$dynamic'(X).
'$current_module'(M),
'$dynamic'(X, M).
dynamic(X) :-
throw(error(context_error(dynamic(X),declaration),query)).
'$dynamic'(X) :- var(X), !,
throw(error(instantiation_error,dynamic(X))).
'$dynamic'(Mod:Spec) :- !,
'$mod_switch'(Mod,'$dynamic'(Spec)).
'$dynamic'((A,B)) :- !, '$dynamic'(A), '$dynamic'(B).
'$dynamic'([]) :- !.
'$dynamic'([H|L]) :- !, '$dynamic'(H), '$dynamic'(L).
'$dynamic'(A) :-
'$dynamic2'(A).
'$dynamic'(X,_) :- var(X), !,
throw(error(instantiation_error,dynamic(M:X))).
'$dynamic'(Mod:Spec,_) :- !,
'$dynamic'(Spec,Mod).
'$dynamic'([], _) :- !.
'$dynamic'([H|L], M) :- !, '$dynamic'(H, M), '$dynamic'(L, M).
'$dynamic'((A,B),M) :- !, '$dynamic'(A,M), '$dynamic'(B,M).
'$dynamic'(X,M) :- !,
'$dynamic2'(X,M).
'$dynamic2'(X) :- '$log_upd'(Stat), Stat\=0, !,
'$logical_updatable'(X).
'$dynamic2'(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'2000, '$flags'(T, F, NF);
'$is_dynamic'(T) -> true;
F /\ 16'400 =:= 16'400, '$undefined'(T) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,F,NF);
'$dynamic2'(X, Mod) :- '$log_upd'(Stat), Stat\=0, !,
'$logical_updatable'(X, Mod).
'$dynamic2'(A/N, Mod) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,Mod,F,F),
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'2000, '$flags'(T, Mod, F, NF);
'$is_dynamic'(T,Mod) -> true;
F /\ 16'400 =:= 16'400, '$undefined'(T,Mod) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,Mod,F,NF);
F/\16'8 =:= 16'8 -> true ;
throw(error(permission_error(modify,static_procedure,A/N),dynamic(A/N)))
), '$flags'(T,F1,F1).
'$dynamic2'(X) :-
throw(error(type_error(callable,X),dynamic(X))).
throw(error(permission_error(modify,static_procedure,Mod:A/N),dynamic(A/N)))
).
'$dynamic2'(X,Mod) :-
throw(error(type_error(callable,X),dynamic(Mod:X))).
'$logical_updatable'(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,F,NF);
'$is_dynamic'(T) -> true;
F /\ 16'400 =:= 16'400 , '$undefined'(T) -> NF is F \/ 0x8, '$flags'(T,F,NF);
'$logical_updatable'(A/N,Mod) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,Mod,F,F),
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,Mod,F,NF);
'$is_dynamic'(T,Mod) -> true;
F /\ 16'400 =:= 16'400 , '$undefined'(T,Mod) -> NF is F \/ 0x8, '$flags'(T,Mod,F,NF);
F /\ 16'8=:= 16'8 -> true ;
throw(error(permission_error(modify,static_procedure,A/N),dynamic(A/N)))
).
'$logical_updatable'(X) :-
throw(error(type_error(callable,X),dynamic(X))).
'$logical_updatable'(X,Mod) :-
throw(error(type_error(callable,X),dynamic(Mod:X))).
dynamic_predicate(P,Sem) :-
@ -478,7 +520,8 @@ dynamic_predicate(P,Sem) :-
dynamic_predicate(P,Sem) :-
'$log_upd'(OldSem),
( Sem = logical -> '$switch_log_upd'(1) ; '$switch_log_upd'(0) ),
'$dynamic'(P),
'$current_module'(M),
'$dynamic'(P, M),
'$switch_log_upd'(OldSem).
'$bad_if_is_semantics'(Sem, Goal) :-
@ -489,37 +532,36 @@ dynamic_predicate(P,Sem) :-
throw(error(domain_error(semantics_indicator,Sem),Goal)).
'$expand_clause'(C0,C1,C2) :-
'$expand_term_modules'(C0, C1, C2),
'$expand_clause'(C0,C1,C2,Mod) :-
'$expand_term_modules'(C0, C1, C2, Mod),
( '$get_value'('$strict_iso',on) ->
'$check_iso_strict_clause'(C1)
;
true
).
'$public'(X) :- var(X), !,
'$public'(X, _) :- var(X), !,
throw(error(instantiation_error,public(X))).
'$public'(Mod:Spec) :- !,
'$mod_switch'(Mod,'$public'(Spec)).
'$public'((A,B)) :- !, '$public'(A), '$public'(B).
'$public'([]) :- !.
'$public'([H|L]) :- !, '$public'(H), '$public'(L).
'$public'(A/N) :- integer(N), atom(A), !,
functor(T,A,N),
'$do_make_public'(T).
'$public'(X) :-
throw(error(type_error(callable,X),dynamic(X))).
'$public'(Mod:Spec, _) :- !,
'$public'(Spec,Mod).
'$public'((A,B), M) :- !, '$public'(A,M), '$public'(B,M).
'$public'([],_) :- !.
'$public'([H|L], M) :- !, '$public'(H, M), '$public'(L, M).
'$public'(A/N, Mod) :- integer(N), atom(A), !,
'$do_make_public'(T, Mod).
'$public'(X, Mod) :-
throw(error(type_error(callable,X),dynamic(Mod:X))).
'$do_make_public'(T) :-
'$is_dynamic'(T), !. % all dynamic predicates are public.
'$do_make_public'(T) :-
'$flags'(T,F,F),
'$do_make_public'(T, Mod) :-
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
'$do_make_public'(T, Mod) :-
'$flags'(T,Mod,F,F),
NF is F\/16'400000,
'$flags'(T,F,NF).
'$flags'(T,Mod,F,NF).
'$is_public'(T) :-
'$is_dynamic'(T), !. % all dynamic predicates are public.
'$is_public'(T) :-
'$flags'(T,F,F),
'$is_public'(T, Mod) :-
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
'$is_public'(T, Mod) :-
'$flags'(T,Mod,F,F),
F\/16'400000 \== 0.

53
pl/tabling.yap
View File

@ -15,73 +15,88 @@
* *
*************************************************************************/
table(X) :- var(X), !,
table(X) :-
current_module(M),
'$table'(X, M).
'$table'(X, _) :- var(X), !,
write(user_error, '[ Error: argument to table/1 should be a predicate ]'),
nl(user_error),
fail.
table((A,B)) :- !, table(A), table(B).
table(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
'$table'(M:A, _) :- !, '$table'(A, M).
'$table'((A,B), M) :- !, '$table'(A, M), '$table'(B, M).
'$table'(A/N, M) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,M,F,F),
(
X is F /\ 8'000100, X =\= 0, !,
write(user_error, '[ Warning: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' is already declared as table ]'),
nl(user_error)
;
X is F /\ 8'170000, X =:= 0, !, '$table'(T)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' cannot be declared as table ]'),
nl(user_error),
fail
).
table(X) :- write(user_error, '[ Error: '),
'$table'(X, _) :- write(user_error, '[ Error: '),
write(user_error, X),
write(user_error, ' is an invalid argument to table/1 ]'),
nl(user_error),
fail.
show_trie(X) :-
'$current_module'(M),
'$show_trie'(X, M).
show_trie(X) :- var(X), !,
'$show_trie'(X, M) :- var(X), !,
write(user_error, '[ Error: argument to trie/1 should be a predicate ]'),
nl(user_error),
fail.
show_trie(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
'$show_trie'((A,B), _) :- !, '$show_trie'(A, M), '$show_trie'(B, M).
'$show_trie'(M:A, _) :- !, '$show_trie'(A, M).
'$show_trie'(A/N, M) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,M,F,F),
(
X is F /\ 8'000100, X =\= 0, !, '$show_trie'(T,_)
X is F /\ 8'000100, X =\= 0, !, '$show_trie'(T,M,_)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' is not declared as table ]'),
nl(user_error),
fail
).
show_trie(X) :- write(user_error, '[ Error: '),
'$show_trie'(X, M) :- write(user_error, '[ Error: '),
write(user_error, X),
write(user_error, ' is an invalid argument to trie/1 ]'),
nl(user_error),
fail.
abolish_trie(X) :-
'$current_module'(M),
'$abolish_trie'(X, M).
abolish_trie(X) :- var(X), !,
'$abolish_trie'(X, M) :- var(X), !,
write(user_error, '[ Error: argument to abolish_trie/1 should be a predicate ]'),
nl(user_error),
fail.
abolish_trie(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
'$abolish_trie'((A,B), _) :- !, '$abolish_trie'(A, M), '$abolish_trie'(B, M).
'$abolish_trie'(M:A, _) :- !, '$abolish_trie'(A, M).
'$abolish_trie'(A/N, M) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,M,F,F),
(
X is F /\ 8'000100, X =\= 0, !, '$abolish_trie'(T)
X is F /\ 8'000100, X =\= 0, !, '$do_abolish_trie'(T,M)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' is not declared as table ]'),
nl(user_error),
fail
).
abolish_trie(X) :- write(user_error, '[ Error: '),
'$abolish_trie'(X,M) :- write(user_error, '[ Error: '),
write(user_error, X),
write(user_error, ' is an invalid argument to abolish_trie/1 ]'),
nl(user_error),

308
pl/utils.yap
View File

@ -29,15 +29,10 @@ if(_X,_Y,Z) :-
call_with_args(V) :- var(V), !,
throw(error(instantiation_error,call_with_args(V))).
call_with_args(M:A) :- !,
( '$current_module'(M) ->
call_with_args(A)
;
'$current_module'(Old,M),
( call_with_args(A); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,M).
call_with_args(A) :- atom(A), !,
'$call_with_args'(A).
'$current_module'(M),
'$call_with_args'(A,M).
call_with_args(A) :-
throw(error(type_error(atom,A),call_with_args(A))).
@ -45,135 +40,90 @@ call_with_args(A) :-
call_with_args(V,A1) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1))).
call_with_args(M:A,A1) :- !,
( '$current_module'(M) ->
call_with_args(A,A1)
;
'$current_module'(Old,M),
( call_with_args(A,A1); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,M).
call_with_args(A,A1) :- atom(A), !,
'$call_with_args'(A,A1).
'$current_module'(M),
'$call_with_args'(A,A1,M).
call_with_args(A,A1) :-
throw(error(type_error(atom,A),call_with_args(A,A1))).
call_with_args(V,A1,A2) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2))).
call_with_args(M:A,A1,A2) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,M).
call_with_args(A,A1,A2) :- atom(A), !,
'$call_with_args'(A,A1,A2).
'$current_module'(M),
'$call_with_args'(A,A1,A2,M).
call_with_args(A,A1,A2) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2))).
call_with_args(V,A1,A2,A3) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3))).
call_with_args(M:A,A1,A2,A3) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,M).
call_with_args(A,A1,A2,A3) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,M).
call_with_args(A,A1,A2,A3) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3))).
call_with_args(V,A1,A2,A3,A4) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4))).
call_with_args(M:A,A1,A2,A3,A4) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,M).
call_with_args(A,A1,A2,A3,A4) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,M).
call_with_args(A,A1,A2,A3,A4) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4))).
call_with_args(V,A1,A2,A3,A4,A5) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5))).
call_with_args(M:A,A1,A2,A3,A4,A5) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,A5,M).
call_with_args(A,A1,A2,A3,A4,A5) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,M).
call_with_args(A,A1,A2,A3,A4,A5) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5))).
call_with_args(V,A1,A2,A3,A4,A5,A6) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6))).
call_with_args(M:A,A1,A2,A3,A4,A5,A6) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5,A6)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5,A6); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,M).
call_with_args(A,A1,A2,A3,A4,A5,A6) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5,A6).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,M).
call_with_args(A,A1,A2,A3,A4,A5,A6) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6))).
call_with_args(V,A1,A2,A3,A4,A5,A6,A7) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7))).
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5,A6,A7)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7))).
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8))).
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8))).
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9))).
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9).
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9))).
@ -181,15 +131,10 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :-
call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- var(V), !,
throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))).
call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- !,
( '$current_module'(M) ->
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10)
;
'$current_module'(Old,M),
( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- atom(A), !,
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10).
'$current_module'(M),
'$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,M).
call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :-
throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))).
@ -342,46 +287,56 @@ current_atom(A) :- % generate
'$current_atom'(A).
current_predicate(A,T) :- var(T), !, % only for the predicate
'$current_predicate_no_modules'(A,T).
'$current_module'(M),
'$current_predicate_no_modules'(M,A,T).
current_predicate(A,M:T) :- % module specified
var(M), !,
current_module(M),
M \= prolog,
'$mod_switch'(M,'$current_predicate_no_modules'(A,T)).
'$current_predicate_no_modules'(M,A,T).
current_predicate(A,M:T) :- % module specified
nonvar(T),
!,
'$pred_exists'(T,M).
current_predicate(A,M:T) :- % module specified
!,
'$mod_switch'(M,'$current_predicate_no_modules'(A,T)).
'$current_predicate_no_modules'(M,A,T).
current_predicate(A,T) :- % only for the predicate
'$current_predicate_no_modules'(A,T).
'$current_module'(M),
'$current_predicate_no_modules'(M,A,T).
current_predicate(F) :- var(F), !, % only for the predicate
'$current_predicate3'(F).
'$current_module'(M),
'$current_predicate3'(M,F).
current_predicate(M:F) :- % module specified
var(M), !,
current_module(M),
'$current_module'(M),
M \= prolog,
'$mod_switch'(M,'$current_predicate3'(F)).
'$current_predicate3'(M,F).
current_predicate(M:F) :- % module specified
!,
'$mod_switch'(M,'$current_predicate3'(F)).
'$current_predicate3'(M,F).
current_predicate(F) :- % only for the predicate
'$current_predicate3'(F).
'$current_module'(M),
'$current_predicate3'(M,F).
system_predicate(A,P) :-
'$mod_switch'(prolog,'$current_predicate_no_modules'(A,P)),
'$current_predicate_no_modules'(prolog,A,P),
\+ '$hidden'(A).
system_predicate(P) :- '$system_predicate'(P).
'$current_predicate_no_modules'(A,T) :-
'$current_predicate'(A,Arity),
'$current_predicate_no_modules'(M,A,T) :-
'$current_predicate'(M,A,Arity),
\+ '$hidden'(A),
functor(T,A,Arity),
'$pred_exists'(T).
'$pred_exists'(T,M).
'$current_predicate3'(A/Arity) :-
'$current_predicate'(A,Arity),
'$current_predicate3'(M,A/Arity) :-
'$current_predicate'(M,A,Arity),
\+ '$hidden'(A),
functor(T,A,Arity),
'$pred_exists'(T).
'$pred_exists'(T,M).
%%% User interface for statistics
@ -472,44 +427,43 @@ statistics(stack_shifts,[NOfHO,NOfSO,NOfTO]) :-
% informs about what the user wants to be done when
% there are no clauses for a certain predicate */
unknown(V0,V) :-
'$current_module'(M),
'$unknown'(V0,V,M).
% query mode
unknown(V0,V) :- var(V), !,
'$unknown'(V0,V,_) :- var(V), !,
'$ask_unknown_flag'(V),
V = V0.
% handle modules.
unknown(V0,Mod:Handler) :-
( '$current_module'(Mod) ->
unknown(V0,Handler)
;
'$mod_switch'(Mod,unknown(V0,Handler))
).
'$unknown'(V0,Mod:Handler,_) :-
'$unknown'(V0,Handler,Mod).
% check if we have one we like.
unknown(_,New) :-
'$valid_unknown_handler'(New), fail.
'$unknown'(_,New,Mod) :-
'$valid_unknown_handler'(New,Mod), fail.
% clean up previous unknown predicate handlers
unknown(Old,New) :-
'$unknown'(Old,New,Mod) :-
'$recorded'('$unknown','$unknown'(_,MyOld),Ref), !,
erase(Ref),
'$cleanup_unknown_handler'(MyOld,Old),
'$new_unknown'(New).
'$new_unknown'(New, Mod).
% store the new one.
unknown(fail,New) :-
'$new_unknown'(New).
'$unknown'(fail,New,Mod) :-
'$new_unknown'(New, Mod).
'$valid_unknown_handler'(V) :-
'$valid_unknown_handler'(V,_) :-
var(V), !,
throw(error(instantiation_error,yap_flag(unknown,V))).
'$valid_unknown_handler'(fail) :- !.
'$valid_unknown_handler'(error) :- !.
'$valid_unknown_handler'(warning) :- !.
'$valid_unknown_handler'(S) :-
'$valid_unknown_handler'(fail,_) :- !.
'$valid_unknown_handler'(error,_) :- !.
'$valid_unknown_handler'(warning,_) :- !.
'$valid_unknown_handler'(S,M) :-
functor(S,_,1),
arg(1,S,A),
var(A),
\+ '$undefined'(S),
\+ '$undefined'(S,M),
!.
'$valid_unknown_handler'(S) :-
'$valid_unknown_handler'(S,_) :-
throw(error(domain_error(flag_value,unknown+S),yap_flag(unknown,S))).
'$ask_unknown_flag'(Old) :-
@ -521,14 +475,13 @@ unknown(fail,New) :-
'$cleanup_unknown_handler'('$unknown_warning'(_),warning) :- !.
'$cleanup_unknown_handler'(Handler, Handler).
'$new_unknown'(fail) :- !.
'$new_unknown'(error) :- !,
'$new_unknown'(fail,_) :- !.
'$new_unknown'(error,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_error'(P)),_).
'$new_unknown'(warning) :- !,
'$new_unknown'(warning,_) :- !,
'$recorda'('$unknown','$unknown'(P,'$unknown_warning'(P)),_).
'$new_unknown'(X) :-
'$new_unknown'(X,M) :-
arg(1,X,A),
'$current_module'(M),
'$recorda'('$unknown','$unknown'(A,M:X),_).
'$unknown_error'(P) :-
@ -542,44 +495,40 @@ unknown(fail,New) :-
fail.
predicate_property(Mod:Pred,Prop) :- !,
( '$current_module'(Mod) ->
'$predicate_property2'(Pred,Prop)
;
'$mod_switch'(Mod,'$predicate_property2'(Pred,Prop))
).
'$predicate_property2'(Pred,Prop,Mod).
predicate_property(Pred,Prop) :-
'$predicate_property2'(Pred,Prop).
'$current_module'(Mod),
'$predicate_property2'(Pred,Prop,Mod).
'$predicate_property2'(Pred,Prop) :- var(Pred), !,
'$current_predicate'(_,Pred),
'$pred_exists'(Pred),
'$predicate_property'(Pred,Prop).
'$predicate_property2'(Pred,Prop) :-
'$predicate_property'(Pred,Prop),
'$pred_exists'(Pred).
'$predicate_property2'(Pred,Prop,M) :- var(Pred), !,
'$current_predicate'(M,_,Pred),
'$pred_exists'(Pred,M),
'$predicate_property'(Pred,M,Prop).
'$predicate_property2'(M:Pred,Prop,_) :-
'$predicate_property'(Pred,Prop,M).
'$predicate_property2'(Pred,Prop,Mod) :-
'$predicate_property'(Pred,Mod,Prop),
'$pred_exists'(Pred,Mod).
'$predicate_property'(P,built_in) :-
'$predicate_property'(P,M,built_in) :-
'$system_predicate'(P), !.
'$predicate_property'(P,dynamic) :-
'$is_dynamic'(P).
'$predicate_property'(P,static) :-
\+ '$is_dynamic'(P).
'$predicate_property'(P,meta_predicate(P)) :-
'$current_module'(M),
'$predicate_property'(P,M,dynamic) :-
'$is_dynamic'(P,M).
'$predicate_property'(P,M,static) :-
\+ '$is_dynamic'(P,M).
'$predicate_property'(P,M,meta_predicate(P)) :-
functor(P,Na,Ar),
recorded('$meta_predicate','$meta_predicate'(M,Na,Ar,P),_).
'$predicate_property'(P,multifile) :-
functor(P,N,A),
'$is_multifile'(N,A).
'$predicate_property'(P,imported_from(Mod)) :-
user:'$meta_predicate'(M,Na,Ar,P).
'$predicate_property'(P,M,multifile) :-
'$is_multifile'(P,M).
'$predicate_property'(P,_,imported_from(Mod)) :-
functor(P,N,A),
'$recorded'('$module','$module'(_TFN,Mod,Publics),_),
'$member'(N/A,Publics). /* defined in modules.yap */
'$predicate_property'(P,public) :-
'$is_public'(P).
'$predicate_property'(P,exported) :-
'$predicate_property'(P,M,public) :-
'$is_public'(P,M).
'$predicate_property'(P,M,exported) :-
functor(P,N,A),
'$current_module'(M),
'$recorded'('$module','$module'(_TFN,M,Publics),_),
'$member'(N/A,Publics). /* defined in modules.yap */
@ -589,8 +538,8 @@ predicate_property(Pred,Prop) :-
% this predicate shows the code produced by the compiler
'$show_code' :- '$debug'(0'f).
'$pred_exists'(Pred) :- '$is_dynamic'(Pred), !.
'$pred_exists'(Pred) :- \+ '$undefined'(Pred).
'$pred_exists'(Pred,M) :- '$is_dynamic'(Pred,M), !.
'$pred_exists'(Pred,M) :- \+ '$undefined'(Pred,M).
grow_heap(X) :- '$grow_heap'(X).
@ -611,22 +560,27 @@ nogc :-
'$force_environment_for_gc'.
profile_data(P, Parm, Data) :- var(P), !,
'$profile_data_for_var'(P, Parm, Data).
profile_data(M:P, Parm, Data) :- var(M), !,
throw(error(instantiation_error,profile_data(M:P, Parm, Data))).
profile_data(M:P, Parm, Data) :- var(M), !,
'$mod_switch'(M,'$profile_data'(P, Parm, Data)).
profile_data(P, Parm, Data) :-
'$profile_data'(P, Parm, Data).
'$current_module'(M),
'$profile_data'(P, Parm, Data, M).
'$profile_data'(Na/Ar,Parm,Data) :-
'$profile_info'(Na, Ar, Stats),
'$profile_data'(P, Parm, Data,M) :- var(P), !,
'$profile_data_for_var'(P, Parm, Data,M).
'$profile_data'(M:P, Parm, Data, _) :- var(M), !,
throw(error(instantiation_error,profile_data(M:P, Parm, Data))).
'$profile_data'(M:P, Parm, Data, _) :-
'$profile_data'(P, Parm, Data, M).
'$profile_data'(P, Parm, Data, M) :-
'$profile_data2'(P, Parm, Data, M).
'$profile_data2'(Na/Ar,Parm,Data, M) :-
functor(P, Na, Ar),
'$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data).
'$profile_data_for_var'(Name/Arity, Parm, Data) :-
'$current_predicate'(_,P),
'$profile_data_for_var'(Name/Arity, Parm, Data, M) :-
'$current_predicate'(M,_,P),
functor(P, Name, Arity),
'$profile_info'(Name, Arity, Stats),
'$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data).
@ -635,9 +589,9 @@ profile_data(P, Parm, Data) :-
'$profile_say'('$profile'(_, _, Backtracks), retries, Backtracks).
profile_reset :-
current_predicate(_,P0),
functor(P0, Name, Arity),
'$profile_reset'(Name, Arity),
current_module(M),
'$current_predicate'(M,_,P0),
'$profile_reset'(M, P0),
fail.
profile_reset.
@ -798,8 +752,10 @@ user_defined_directive(Dir,_) :-
user_defined_directive(Dir,Action) :-
functor(Dir,Na,Ar),
functor(NDir,Na,Ar),
'$current_module'(M, prolog),
assert_static('$directive'(NDir)),
assert_static(('$exec_directive'(Dir, _) :- Action)).
assert_static(('$exec_directive'(Dir, _, _) :- Action)),
'$current_module'(_, M).
'$set_toplevel_hook'(_) :-
'$recorded'('$toplevel_hooks',_,R),

39
pl/yapor.yap
View File

@ -37,58 +37,65 @@ default_sequential(_).
'$initialization'('$default_sequential'(X)),
'$default_sequential'(off).
'$sequential_directive'(X) :- var(X), !,
'$sequential_directive'(X,_) :- var(X), !,
write(user_error, '[ Error: argument to sequential/1 should be a predicate ]'),
nl(user_error),
fail.
'$sequential_directive'((A,B)) :- !, sequential(A), sequential(B).
'$sequential_directive'(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
'$sequential_directive'((A,B),M) :- !,
'$sequential_directive'(A,M), '$sequential_directive'(B,M).
'$sequential_directive'(M:A,_) :- !,
'$sequential_directive'(A,M).
'$sequential_directive'(A/N,M) :- integer(N), atom(A), !,
functor(T,A,N),
'$flags'(T,M,F,F),
(
X is F /\ 8'000040, X =\= 0, !,
write(user_error, '[ Warning: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' is already declared as sequential ]'),
nl(user_error)
;
X is F /\ 8'170000, X =:= 0, !, '$sequential'(T)
X is F /\ 8'170000, X =:= 0, !, '$sequential'(T,M)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' cannot be declared as sequential ]'),
nl(user_error),
fail
).
'$sequential_directive'(X) :- write(user_error, '[ Error: '),
'$sequential_directive'(X,_) :- write(user_error, '[ Error: '),
write(user_error, X),
write(user_error, ' is an invalid argument to sequential/1 ]'),
nl(user_error),
fail.
parallel(X) :- var(X), !,
'$parallel_directive'(X,M) :- var(X), !,
write(user_error, '[ Error: argument to parallel/1 should be a predicate ]'),
nl(user_error),
fail.
parallel((A,B)) :- !, parallel(A), parallel(B).
parallel(A/N) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,F,F),
'$parallel_directive'((A,B),M) :- !,
'$parallel_directive'(A,M),
'parallel_directive'(B,M).
'$parallel_directive'(M:A,_) :- !,
'$parallel_directive'(A,M).
'$parallel_directive'(A/N,M) :- integer(N), atom(A), !,
functor(T,A,N), '$flags'(T,M,F,F),
(
NF is F /\ \(8'000040), '$flags'(T,F,NF) ;
write(user_error, '[ Warning: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' is already declared as sequential ]'),
nl(user_error)
;
X is F /\ 8'170000, X =:= 0, !, '$sequential'(T)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
write(user_error, M:A/N),
write(user_error, ' cannot be declared as parallel ]'),
nl(user_error),
fail
).
sequential(X) :- write(user_error, '[ Error: '),
'$parallel_directive'(X,_) :- write(user_error, '[ Error: '),
write(user_error, X),
write(user_error, ' is an invalid argument to parallel/1 ]'),
nl(user_error),

4
pl/yio.yap
View File

@ -500,8 +500,8 @@ format(Stream, S, A) :- '$format'(Stream, S, A).
/* interface to user portray */
'$portray'(T) :-
\+ '$undefined'(portray(_)),
portray(T), !,
\+ '$undefined'(portray(_),user),
user:portray(T), !,
'$set_value'('$portray',true), fail.
'$portray'(_) :- '$set_value'('$portray',false), fail.