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

102
C/adtdefs.c
View File

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

4
C/amasm.c
View File

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

68
C/bb.c
View File

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

10
C/c_interface.c
View File

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

517
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(void recover_log_upd_clause, (Clause *));
STATIC_PROTO(PredEntry *NextPred, (PredEntry *,AtomEntry *)); STATIC_PROTO(PredEntry *NextPred, (PredEntry *,AtomEntry *));
STATIC_PROTO(Int p_number_of_clauses, (void)); 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, (void));
STATIC_PROTO(Int p_compile_dynamic, (void)); STATIC_PROTO(Int p_compile_dynamic, (void));
STATIC_PROTO(Int p_purge_clauses, (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_in_use, (void));
STATIC_PROTO(Int p_new_multifile, (void)); STATIC_PROTO(Int p_new_multifile, (void));
STATIC_PROTO(Int p_is_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_on, (void));
STATIC_PROTO(Int p_optimizer_off, (void)); STATIC_PROTO(Int p_optimizer_off, (void));
STATIC_PROTO(Int p_in_this_f_before, (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_info, (void));
STATIC_PROTO(Int p_profile_reset, (void)); STATIC_PROTO(Int p_profile_reset, (void));
STATIC_PROTO(Int p_toggle_static_predicates_in_use, (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 PredArity(p) (p->ArityOfPE)
#define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G) #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 void
addclause(Term t, CODEADDR cp, int mode) addclause(Term t, CODEADDR cp, int mode, int mod)
/* /*
* mode 0 assertz 1 consult 2 asserta * mode 0 assertz 1 consult 2 asserta
*/ */
{ {
AtomEntry *ap;
Int Arity;
PredEntry *p; PredEntry *p;
int spy_flag = FALSE; int spy_flag = FALSE;
SMALLUNSGN mod = CurrentModule; Atom at;
UInt Arity;
if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert) if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
t = ArgOfTerm(1, t); t = ArgOfTerm(1, t);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
p = RepPredProp(PredPropByAtom(at, mod));
Arity = 0; Arity = 0;
ap = RepAtom(AtomOfTerm(t));
} else { } else {
Functor f = FunctorOfTerm(t); Functor f = FunctorOfTerm(t);
ap = RepAtom(NameOfFunctor(f));
Arity = ArityOfFunctor(f); Arity = ArityOfFunctor(f);
at = NameOfFunctor(f);
p = RepPredProp(PredPropByFunc(f, mod));
} }
p = RepPredProp(PredProp(AbsAtom(ap), Arity));
PutValue(AtomAbol, TermNil); PutValue(AtomAbol, TermNil);
WRITE_LOCK(p->PRWLock); WRITE_LOCK(p->PRWLock);
/* we are redefining a prolog module predicate */ /* we are redefining a prolog module predicate */
if (mod != 0 && p->ModuleOfPred == 0) { if (mod != 0 && p->ModuleOfPred == 0) {
addcl_permission_error(ap, Arity); WRITE_UNLOCK(p->PRWLock);
addcl_permission_error(RepAtom(at), Arity);
return; return;
} }
/* The only problem we have now is when we need to throw away /* 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)) { if (!RemoveIndexation(p)) {
/* should never happen */ /* should never happen */
WRITE_UNLOCK(p->PRWLock); WRITE_UNLOCK(p->PRWLock);
addcl_permission_error(ap,Arity); addcl_permission_error(RepAtom(at),Arity);
return; return;
} }
} }
@ -877,12 +874,13 @@ addclause(Term t, CODEADDR cp, int mode)
static Int static Int
p_in_this_f_before(void) p_in_this_f_before(void)
{ /* '$in_this_file_before'(N,A) */ { /* '$in_this_file_before'(N,A,M) */
unsigned int arity; unsigned int arity;
Atom at; Atom at;
Term t; Term t;
register consult_obj *fp; register consult_obj *fp;
Prop p0; Prop p0;
SMALLUNSGN mod;
if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t)) if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t))
return (FALSE); return (FALSE);
@ -892,7 +890,14 @@ p_in_this_f_before(void)
return (FALSE); return (FALSE);
else else
arity = IntOfTerm(t); 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) if (ConsultSp == ConsultBase || (fp = ConsultSp)->p == p0)
return (FALSE); return (FALSE);
else else
@ -908,12 +913,14 @@ p_in_this_f_before(void)
static Int static Int
p_first_cl_in_f(void) p_first_cl_in_f(void)
{ /* '$first_cl_in_file'(+N,+Ar) */ { /* '$first_cl_in_file'(+N,+Ar,+Mod) */
unsigned int arity; unsigned int arity;
Atom at; Atom at;
Term t; Term t;
register consult_obj *fp; register consult_obj *fp;
Prop p0; Prop p0;
SMALLUNSGN mod;
if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t)) if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t))
return (FALSE); return (FALSE);
@ -923,7 +930,14 @@ p_first_cl_in_f(void)
return (FALSE); return (FALSE);
else else
arity = IntOfTerm(t); 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) for (fp = ConsultSp; fp < ConsultBase; ++fp)
if (fp->p == p0) if (fp->p == p0)
break; break;
@ -948,7 +962,10 @@ p_mk_cl_not_first(void)
return (FALSE); return (FALSE);
else else
arity = IntOfTerm(t); arity = IntOfTerm(t);
p0 = PredProp(at, arity); if (arity)
p0 = PredPropByFunc(MkFunctor(at, arity),CurrentModule);
else
p0 = PredPropByAtom(at, CurrentModule);
--ConsultSp; --ConsultSp;
ConsultSp->p = p0; ConsultSp->p = p0;
return (TRUE); return (TRUE);
@ -991,18 +1008,23 @@ where_new_clause(pred_prop, mode)
static Int static Int
p_compile(void) p_compile(void)
{ /* '$compile'(+C,+Flags) */ { /* '$compile'(+C,+Flags, Mod) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t1 = Deref(ARG2); Term t1 = Deref(ARG2);
Term t3 = Deref(ARG3);
CODEADDR codeadr; CODEADDR codeadr;
Int mod;
if (IsVarTerm(t1) || !IsIntTerm(t1)) if (IsVarTerm(t1) || !IsIntTerm(t1))
return (FALSE); 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 */ to cclause in case there is overflow */
t = Deref(ARG1); /* just in case there was an heap overflow */ t = Deref(ARG1); /* just in case there was an heap overflow */
if (!ErrorMessage) if (!ErrorMessage)
addclause(t, codeadr, (int) (IntOfTerm(t1) & 3)); addclause(t, codeadr, (int) (IntOfTerm(t1) & 3), mod);
if (ErrorMessage) { if (ErrorMessage) {
if (IntOfTerm(t1) & 4) { if (IntOfTerm(t1) & 4) {
Error(Error_TYPE, Error_Term, Error(Error_TYPE, Error_Term,
@ -1016,25 +1038,30 @@ p_compile(void)
static Int static Int
p_compile_dynamic(void) p_compile_dynamic(void)
{ /* '$compile_dynamic'(+C,+Flags,-Ref) */ { /* '$compile_dynamic'(+C,+Flags,Mod,-Ref) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t1 = Deref(ARG2); Term t1 = Deref(ARG2);
Term t3 = Deref(ARG3);
Clause *cl; Clause *cl;
CODEADDR code_adr; CODEADDR code_adr;
int old_optimize; int old_optimize;
Int mod;
if (IsVarTerm(t1) || !IsIntTerm(t1)) if (IsVarTerm(t1) || !IsIntTerm(t1))
return (FALSE); return (FALSE);
if (IsVarTerm(t3) || !IsAtomTerm(t3))
return (FALSE);
old_optimize = optimizer_on; old_optimize = optimizer_on;
optimizer_on = FALSE; 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 */ cclause() in case there is a overflow */
t = Deref(ARG1); /* just in case there was an heap overflow */ t = Deref(ARG1); /* just in case there was an heap overflow */
if (!ErrorMessage) { if (!ErrorMessage) {
optimizer_on = old_optimize; optimizer_on = old_optimize;
cl = ClauseCodeToClause(code_adr); cl = ClauseCodeToClause(code_adr);
addclause(t, code_adr, (int) (IntOfTerm(t1) & 3)); addclause(t, code_adr, (int) (IntOfTerm(t1) & 3), mod);
} }
if (ErrorMessage) { if (ErrorMessage) {
if (IntOfTerm(t1) & 4) { if (IntOfTerm(t1) & 4) {
@ -1047,7 +1074,7 @@ p_compile_dynamic(void)
if (!(cl->ClFlags & LogUpdMask)) if (!(cl->ClFlags & LogUpdMask))
cl->ClFlags = DynamicMask; cl->ClFlags = DynamicMask;
t = MkIntegerTerm((Int)code_adr); t = MkIntegerTerm((Int)code_adr);
return(unify(ARG3, t)); return(unify(ARG4, t));
} }
@ -1145,17 +1172,23 @@ p_purge_clauses(void)
{ /* '$purge_clauses'(+Func) */ { /* '$purge_clauses'(+Func) */
PredEntry *pred; PredEntry *pred;
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
CODEADDR q, q1; CODEADDR q, q1;
int mod;
PutValue(AtomAbol, MkAtomTerm(AtomNil)); PutValue(AtomAbol, MkAtomTerm(AtomNil));
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return (FALSE);
}
mod = LookupModule(t2);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0)); pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); pred = RepPredProp(PredPropByFunc(fun, mod));
} else } else
return (FALSE); return (FALSE);
WRITE_LOCK(pred->PRWLock); WRITE_LOCK(pred->PRWLock);
@ -1197,24 +1230,30 @@ p_purge_clauses(void)
static Int static Int
p_setspy(void) p_setspy(void)
{ /* '$set_spy'(+Fun) */ { /* '$set_spy'(+Fun,+M) */
Atom at; Atom at;
PredEntry *pred; PredEntry *pred;
CELL fg; CELL fg;
Term t; Term t;
Term t2;
SMALLUNSGN mod;
at = FullLookupAtom("$spy"); at = FullLookupAtom("$spy");
pred = RepPredProp(PredProp(at, 1)); pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0));
SpyCode = pred; SpyCode = pred;
t = Deref(ARG1); t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0)); pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); pred = RepPredProp(PredPropByFunc(fun, mod));
} else { } else {
return (FALSE); return (FALSE);
} }
@ -1249,20 +1288,26 @@ p_setspy(void)
static Int static Int
p_rmspy(void) p_rmspy(void)
{ /* '$rm_spy'(+T) */ { /* '$rm_spy'(+T,+Mod) */
Atom at; Atom at;
PredEntry *pred; PredEntry *pred;
Term t; Term t;
Term t2;
SMALLUNSGN mod;
t = Deref(ARG1); t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
at = AtomOfTerm(t); at = AtomOfTerm(t);
pred = RepPredProp(PredProp(at, 0)); pred = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); pred = RepPredProp(PredPropByFunc(fun, mod));
} else } else
return (FALSE); return (FALSE);
WRITE_LOCK(pred->PRWLock); WRITE_LOCK(pred->PRWLock);
@ -1294,19 +1339,25 @@ p_rmspy(void)
static Int static Int
p_number_of_clauses(void) p_number_of_clauses(void)
{ /* '$number_of_clauses'(Predicate,N) */ { /* '$number_of_clauses'(Predicate,M,N) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
int ncl = 0; int ncl = 0;
Prop pe; Prop pe;
CODEADDR q; CODEADDR q;
int testing; int testing;
int mod;
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return(FALSE);
}
mod = LookupModule(t2);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t); Atom a = AtomOfTerm(t);
pe = PredProp(a, 0); pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t); register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f, *CurrentModulePtr); pe = PredPropByFunc(f, mod);
} else } else
return (FALSE); return (FALSE);
q = RepPredProp(pe)->FirstClause; q = RepPredProp(pe)->FirstClause;
@ -1328,113 +1379,29 @@ p_number_of_clauses(void)
} }
READ_UNLOCK(RepPredProp(pe)->PRWLock); READ_UNLOCK(RepPredProp(pe)->PRWLock);
t = MkIntTerm(ncl); 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)); return (unify_constant(ARG3, t));
} }
static Int static Int
p_in_use(void) p_in_use(void)
{ /* '$in_use'(+P) */ { /* '$in_use'(+P,+Mod) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
PredEntry *pe; PredEntry *pe;
Int out; Int out;
int mod;
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsVarTerm(t2) || !IsAtomTerm(t2))
return (FALSE);
mod = LookupModule(t2);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0)); pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); pe = RepPredProp(PredPropByFunc(fun, mod));
} else } else
return (FALSE); return (FALSE);
READ_LOCK(pe->PRWLock); READ_LOCK(pe->PRWLock);
@ -1445,11 +1412,12 @@ p_in_use(void)
static Int static Int
p_new_multifile(void) p_new_multifile(void)
{ /* '$new_multifile'(+N,+Ar) */ { /* '$new_multifile'(+N,+Ar,+Mod) */
Atom at; Atom at;
int arity; int arity;
PredEntry *pe; PredEntry *pe;
Term t = Deref(ARG1); Term t = Deref(ARG1);
SMALLUNSGN mod = LookupModule(Deref(ARG3));
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
@ -1464,7 +1432,10 @@ p_new_multifile(void)
arity = IntOfTerm(t); arity = IntOfTerm(t);
else else
return (FALSE); 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); WRITE_LOCK(pe->PRWLock);
pe->PredFlags |= MultiFileFlag; pe->PredFlags |= MultiFileFlag;
WRITE_UNLOCK(pe->PRWLock); WRITE_UNLOCK(pe->PRWLock);
@ -1474,28 +1445,27 @@ p_new_multifile(void)
static Int static Int
p_is_multifile(void) p_is_multifile(void)
{ /* '$is_multifile'(+N,+Ar) */ { /* '$is_multifile'(+S,+Mod) */
Atom at;
int arity;
PredEntry *pe; PredEntry *pe;
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
Int out; Int out;
int mod;
if (IsVarTerm(t)) if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsAtomTerm(t)) if (IsVarTerm(t2))
at = AtomOfTerm(t);
else
return (FALSE); return (FALSE);
t = Deref(ARG2); if (!IsAtomTerm(t2))
if (IsVarTerm(t))
return (FALSE); return (FALSE);
if (IsIntTerm(t)) mod = LookupModule(t2);
arity = IntOfTerm(t); if (IsAtomTerm(t)) {
else pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod));
return (FALSE); } else if (IsApplTerm(t)) {
pe = RepPredProp(PredProp(at, arity)); pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod));
if (pe == NIL) } else
return(FALSE);
if (EndOfPAEntr(pe))
return (FALSE); return (FALSE);
READ_LOCK(pe->PRWLock); READ_LOCK(pe->PRWLock);
out = (pe->PredFlags & MultiFileFlag); out = (pe->PredFlags & MultiFileFlag);
@ -1503,52 +1473,23 @@ p_is_multifile(void)
return(out); 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 static Int
p_is_dynamic(void) p_is_dynamic(void)
{ /* '$is_dynamic'(+P) */ { /* '$is_dynamic'(+P) */
PredEntry *pe; PredEntry *pe;
Term t = Deref(ARG1); Term t = Deref(ARG1);
Term t2 = Deref(ARG2);
Int out; Int out;
SMALLUNSGN mod = LookupModule(t2);
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
return (FALSE); return (FALSE);
} else if (IsAtomTerm(t)) { } else if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0)); pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); pe = RepPredProp(PredPropByFunc(fun, mod));
} else } else
return (FALSE); return (FALSE);
if (pe == NIL) if (pe == NIL)
@ -1562,31 +1503,40 @@ p_is_dynamic(void)
static Int static Int
p_set_pred_module(void) p_set_pred_module(void)
{ /* '$set_pred_module'(+P,+Mod) */ { /* '$set_pred_module'(+P,+Mod) */
Atom at;
int arity;
PredEntry *pe; PredEntry *pe;
Term t = Deref(ARG1); Term t = Deref(ARG1);
SMALLUNSGN mod = CurrentModule;
restart_set_pred:
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
return (FALSE); return (FALSE);
} else if (IsAtomTerm(t)) { } else if (IsAtomTerm(t)) {
at = AtomOfTerm(t); pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod));
arity = 0;
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
at = NameOfFunctor(fun); if (fun == FunctorModule) {
arity = ArityOfFunctor(fun); 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 } else
return (FALSE); return (FALSE);
pe = RepPredProp(PredProp(at, arity)); if (EndOfPAEntr(pe))
if (pe == NIL)
return (FALSE); return (FALSE);
WRITE_LOCK(pe->PRWLock); WRITE_LOCK(pe->PRWLock);
{ {
SMALLUNSGN mod = LookupModule(Deref(ARG2)); SMALLUNSGN mod = LookupModule(Deref(ARG2));
if (mod) pe->ModuleOfPred = mod;
pe->ModuleOfPred = MkIntTerm(mod);
else
pe->ModuleOfPred = 0;
} }
WRITE_UNLOCK(pe->PRWLock); WRITE_UNLOCK(pe->PRWLock);
return(TRUE); return(TRUE);
@ -1594,12 +1544,23 @@ p_set_pred_module(void)
static Int static Int
p_undefined(void) p_undefined(void)
{ /* '$undefined'(P) */ { /* '$undefined'(P,Mod) */
PredEntry *pe; PredEntry *pe;
Term t; Term t;
Term tmod = *CurrentModulePtr; Term t2;
SMALLUNSGN mod;
t = Deref(ARG1); 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: restart_undefined:
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1"); Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
@ -1607,24 +1568,24 @@ p_undefined(void)
} }
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pe = RepPredProp(GetPredPropByAtom(at,tmod)); pe = RepPredProp(GetPredPropByAtom(at,mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t); Functor funt = FunctorOfTerm(t);
if (funt == FunctorModule) { if (funt == FunctorModule) {
Term mod = ArgOfTerm(1, t); Term tmod = ArgOfTerm(1, t);
if (IsVarTerm(mod) ) { if (IsVarTerm(tmod) ) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1"); Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
return(FALSE); return(FALSE);
} }
if (!IsAtomTerm(mod) ) { if (!IsAtomTerm(tmod) ) {
Error(TYPE_ERROR_ATOM,ARG1,"undefined/1"); Error(TYPE_ERROR_ATOM,ARG1,"undefined/1");
return(FALSE); return(FALSE);
} }
tmod = MkIntTerm(LookupModule(mod)); mod = LookupModule(tmod);
t = ArgOfTerm(2, t); t = ArgOfTerm(2, t);
goto restart_undefined; goto restart_undefined;
} }
pe = RepPredProp(GetPredPropByFunc(funt, tmod)); pe = RepPredProp(GetPredPropByFunc(funt, mod));
} else { } else {
return (FALSE); return (FALSE);
} }
@ -1650,20 +1611,32 @@ p_undefined(void)
static Int static Int
p_kill_dynamic(void) p_kill_dynamic(void)
{ /* '$kill_dynamic'(P) */ { /* '$kill_dynamic'(P,M) */
PredEntry *pe; PredEntry *pe;
Term t; 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); t = Deref(ARG1);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
pe = RepPredProp(PredProp(at, 0)); pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t); Functor funt = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr)); pe = RepPredProp(PredPropByFunc(funt, mod));
} else } else
return (FALSE); return (FALSE);
if (pe == NIL) if (EndOfPAEntr(pe))
return (TRUE); return (TRUE);
WRITE_LOCK(pe->PRWLock); WRITE_LOCK(pe->PRWLock);
if (!(pe->PredFlags & DynamicPredFlag)) { if (!(pe->PredFlags & DynamicPredFlag)) {
@ -1845,43 +1818,6 @@ do_toggle_static_predicates_in_use(int mask)
#endif #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 /* This predicate is to be used by reconsult to mark all predicates
currently in use as being executed. currently in use as being executed.
@ -2039,22 +1975,30 @@ p_is_profiled(void)
static Int static Int
p_profile_info(void) p_profile_info(void)
{ {
Term tname = Deref(ARG1); Term tmod = Deref(ARG1);
Term tarity = Deref(ARG2); Term tfun = Deref(ARG2);
int mod;
Term out; Term out;
PredEntry *pe; PredEntry *pe;
Int arity;
Atom name;
Term p[3]; Term p[3];
if (IsVarTerm(tname) || !IsAtomTerm(tname)) if (IsVarTerm(tmod) || !IsAtomTerm(tmod))
return(FALSE); return(FALSE);
if (IsVarTerm(tarity) || !IsIntTerm(tarity)) mod = LookupModule(tmod);
if (IsVarTerm(tfun)) {
return(FALSE); return(FALSE);
name = AtomOfTerm(tname); } else if (IsApplTerm(tfun)) {
arity = IntOfTerm(tarity); Functor f = FunctorOfTerm(tfun);
pe = RepPredProp(GetPredProp(name, arity)); if (IsExtensionFunctor(f)) {
if (pe == NULL) 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); return(FALSE);
LOCK(pe->StatisticsForPred.lock); LOCK(pe->StatisticsForPred.lock);
if (!(pe->StatisticsForPred.NOfEntries)) { if (!(pe->StatisticsForPred.NOfEntries)) {
@ -2072,20 +2016,28 @@ p_profile_info(void)
static Int static Int
p_profile_reset(void) p_profile_reset(void)
{ {
Term tname = Deref(ARG1); Term tmod = Deref(ARG1);
Term tarity = Deref(ARG2); Term tfun = Deref(ARG2);
int mod;
PredEntry *pe; PredEntry *pe;
Int arity;
Atom name;
if (IsVarTerm(tname) || !IsAtomTerm(tname)) if (IsVarTerm(tmod) || !IsAtomTerm(tmod))
return(FALSE); return(FALSE);
if (IsVarTerm(tarity) || !IsIntTerm(tarity)) mod = LookupModule(tmod);
if (IsVarTerm(tfun)) {
return(FALSE); return(FALSE);
name = AtomOfTerm(tname); } else if (IsApplTerm(tfun)) {
arity = IntOfTerm(tarity); Functor f = FunctorOfTerm(tfun);
pe = RepPredProp(GetPredProp(name, arity)); if (IsExtensionFunctor(f)) {
if (pe == NULL) 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); return(FALSE);
LOCK(pe->StatisticsForPred.lock); LOCK(pe->StatisticsForPred.lock);
pe->StatisticsForPred.NOfEntries = 0; pe->StatisticsForPred.NOfEntries = 0;
@ -2124,21 +2076,23 @@ p_parent_pred(void)
unify(ARG3, MkIntTerm(arity))); unify(ARG3, MkIntTerm(arity)));
} }
static Int /* $parent_pred(Module, Name, Arity) */ static Int /* $system_predicate(P) */
p_system_pred(void) p_system_pred(void)
{ {
PredEntry *pe; PredEntry *pe;
Term mod = *CurrentModulePtr;
Term t1 = Deref(ARG1); Term t1 = Deref(ARG1);
restart: restart_system_pred:
if (IsVarTerm(t1)) if (IsVarTerm(t1))
return (FALSE); return (FALSE);
if (IsAtomTerm(t1)) { if (IsAtomTerm(t1)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)); pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(t1), 0));
} else if (IsApplTerm(t1)) { } else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1); Functor funt = FunctorOfTerm(t1);
if (funt == FunctorModule) { if (IsExtensionFunctor(funt)) {
return(FALSE);
}
while (funt == FunctorModule) {
Term nmod = ArgOfTerm(1, t1); Term nmod = ArgOfTerm(1, t1);
if (IsVarTerm(nmod)) { if (IsVarTerm(nmod)) {
Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1"); Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
@ -2148,13 +2102,14 @@ p_system_pred(void)
Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1"); Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
return(FALSE); return(FALSE);
} }
mod = MkIntTerm(LookupModule(nmod));
t1 = ArgOfTerm(2, t1); t1 = ArgOfTerm(2, t1);
goto restart; goto restart_system_pred;
} }
pe = RepPredProp(PredPropByFunc(funt, mod)); pe = RepPredProp(GetPredPropByFunc(funt, 0));
} else } else
return (FALSE); return (FALSE);
if (EndOfPAEntr(pe))
return(FALSE);
return(pe->ModuleOfPred == 0); return(pe->ModuleOfPred == 0);
} }
@ -2165,33 +2120,29 @@ InitCdMgr(void)
InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag); InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag);
InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag); InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag);
InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag); InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag);
InitCPred("$set_spy", 1, p_setspy, SafePredFlag|SyncPredFlag); InitCPred("$set_spy", 2, p_setspy, SafePredFlag|SyncPredFlag);
InitCPred("$rm_spy", 1, p_rmspy, SafePredFlag|SyncPredFlag); InitCPred("$rm_spy", 2, p_rmspy, SafePredFlag|SyncPredFlag);
/* gc() may happen during compilation, hence these predicates are /* gc() may happen during compilation, hence these predicates are
now unsafe */ now unsafe */
InitCPred("$compile", 2, p_compile, SyncPredFlag); InitCPred("$compile", 3, p_compile, SyncPredFlag);
InitCPred("$compile_dynamic", 3, p_compile_dynamic, SyncPredFlag); InitCPred("$compile_dynamic", 4, p_compile_dynamic, SyncPredFlag);
InitCPred("$purge_clauses", 1, p_purge_clauses, SafePredFlag|SyncPredFlag); InitCPred("$purge_clauses", 2, p_purge_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$in_use", 1, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag); InitCPred("$in_use", 2, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag);
InitCPred("$is_logical_updatable", 1, p_is_logical_updatable, TestPredFlag | SafePredFlag); InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag);
InitCPred("$is_dynamic", 1, p_is_dynamic, TestPredFlag | SafePredFlag); InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$number_of_clauses", 2, p_number_of_clauses, SafePredFlag|SyncPredFlag); InitCPred("$undefined", 2, p_undefined, SafePredFlag|TestPredFlag);
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("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag); InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag);
InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag); InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag);
InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag); InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag);
InitCPred("$kill_dynamic", 1, p_kill_dynamic, SafePredFlag|SyncPredFlag); InitCPred("$kill_dynamic", 1, p_kill_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$in_this_file_before", 2, p_in_this_f_before, SafePredFlag); InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag);
InitCPred("$first_clause_in_file", 2, p_first_cl_in_f, 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("$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_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag);
InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag); InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag);
InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag); InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag);
InitCPred("$profile_reset", 2, p_profile_reset, 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("$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("$set_pred_module", 2, p_set_pred_module, SafePredFlag);
InitCPred("$parent_pred", 3, p_parent_pred, 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_args, (Term));
STATIC_PROTO(void c_eq, (Term, Term)); STATIC_PROTO(void c_eq, (Term, Term));
STATIC_PROTO(void c_test, (Int, Term)); STATIC_PROTO(void c_test, (Int, Term));
STATIC_PROTO(void c_bifun, (Int, Term, Term, Term)); STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int));
STATIC_PROTO(void c_goal, (Term)); STATIC_PROTO(void c_goal, (Term, int));
STATIC_PROTO(void get_type_info, (Term)); 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 get_cl_info, (Term));
STATIC_PROTO(void c_head, (Term)); STATIC_PROTO(void c_head, (Term));
STATIC_PROTO(int usesvar, (int)); STATIC_PROTO(int usesvar, (int));
@ -702,7 +702,7 @@ bip_cons Op,Xk,Ri,C
*/ */
static void 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 */ /* compile Z = X Op Y arithmetic function */
/* first we fetch the arguments */ /* first we fetch the arguments */
@ -821,7 +821,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
if (IsNumTerm(t1)) { if (IsNumTerm(t1)) {
/* we will always fail */ /* we will always fail */
if (i2) if (i2)
c_goal(MkAtomTerm(AtomFalse)); c_goal(MkAtomTerm(AtomFalse), mod);
} else if (!IsAtomTerm(t1)) { } else if (!IsAtomTerm(t1)) {
char s[32]; char s[32];
@ -892,7 +892,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
} else if (IsApplTerm(t2)) { } else if (IsApplTerm(t2)) {
Functor f = FunctorOfTerm(t2); Functor f = FunctorOfTerm(t2);
if (i1 < 1 || i1 > ArityOfFunctor(f)) { if (i1 < 1 || i1 > ArityOfFunctor(f)) {
c_goal(MkAtomTerm(AtomFalse)); c_goal(MkAtomTerm(AtomFalse), mod);
} else { } else {
c_eq(ArgOfTerm(i1, t2), t3); 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); c_eq(TailOfTerm(t2), t3);
return; return;
default: default:
c_goal(MkAtomTerm(AtomFalse)); c_goal(MkAtomTerm(AtomFalse), mod);
return; return;
} }
} }
@ -1066,13 +1066,13 @@ c_bifun(Int Op, Term t1, Term t2, Term t3)
} }
static void static void
c_functor(Term Goal) c_functor(Term Goal, int mod)
{ {
Term t1 = ArgOfTerm(1, Goal); Term t1 = ArgOfTerm(1, Goal);
Term t2 = ArgOfTerm(2, Goal); Term t2 = ArgOfTerm(2, Goal);
Term t3 = ArgOfTerm(3, Goal); Term t3 = ArgOfTerm(3, Goal);
if (IsVarTerm(t1) && IsNewVar(t1)) { if (IsVarTerm(t1) && IsNewVar(t1)) {
c_bifun(_functor, t2, t3, t1); c_bifun(_functor, t2, t3, t1, mod);
} else if (IsNonVarTerm(t1)) { } else if (IsNonVarTerm(t1)) {
/* just split the structure */ /* just split the structure */
if (IsAtomicTerm(t1)) { if (IsAtomicTerm(t1)) {
@ -1095,7 +1095,7 @@ c_functor(Term Goal)
c_var(t3,f_flag,(unsigned int)_functor); c_var(t3,f_flag,(unsigned int)_functor);
} else { } else {
Functor f = FunctorOfTerm(Goal); Functor f = FunctorOfTerm(Goal);
Prop p0 = PredPropByFunc(f, *CurrentModulePtr); Prop p0 = PredPropByFunc(f, mod);
if (profiling) if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero); emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero);
c_args(Goal); c_args(Goal);
@ -1122,16 +1122,14 @@ IsTrueGoal(Term t) {
} }
static void static void
c_goal(Term Goal) c_goal(Term Goal, int mod)
{ {
Functor f; Functor f;
PredEntry *p; PredEntry *p;
Prop p0; Prop p0;
int save_CurrentModule = CurrentModule;
if (IsVarTerm(Goal)) { if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal); Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
} }
if (IsNumTerm(Goal)) { if (IsNumTerm(Goal)) {
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, 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); FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal);
} else if (IsPairTerm(Goal)) { } else if (IsPairTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal); Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
} else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) { } else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) {
Term M = ArgOfTerm(1, Goal); Term M = ArgOfTerm(1, Goal);
@ -1153,19 +1150,17 @@ c_goal(Term Goal)
save_machine_regs(); save_machine_regs();
longjmp(CompilerBotch, 1); longjmp(CompilerBotch, 1);
} }
*CurrentModulePtr = MkIntTerm(LookupModule(M));
Goal = ArgOfTerm(2, Goal); Goal = ArgOfTerm(2, Goal);
mod = LookupModule(M);
} }
if (IsVarTerm(Goal)) { if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal); Goal = MkApplTerm(FunctorCall, 1, &Goal);
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
} }
if (IsAtomTerm(Goal)) { if (IsAtomTerm(Goal)) {
Atom atom = AtomOfTerm(Goal); Atom atom = AtomOfTerm(Goal);
if (atom == AtomFail || atom == AtomFalse) { if (atom == AtomFail || atom == AtomFalse) {
emit(fail_op, Zero, Zero); emit(fail_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
else if (atom == AtomTrue || atom == AtomOtherwise) { else if (atom == AtomTrue || atom == AtomOtherwise) {
@ -1178,13 +1173,12 @@ c_goal(Term Goal)
#endif /* TABLING */ #endif /* TABLING */
emit(procceed_op, Zero, Zero); emit(procceed_op, Zero, Zero);
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
else if (atom == AtomCut) { else if (atom == AtomCut) {
if (profiling) if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(PredProp(AtomCut,0)), Zero); emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero);
if (onlast) { if (onlast) {
/* never a problem here with a -> b, !, c ; d */ /* never a problem here with a -> b, !, c ; d */
emit(deallocate_op, Zero, Zero); emit(deallocate_op, Zero, Zero);
@ -1207,7 +1201,6 @@ c_goal(Term Goal)
/* needs to adjust previous commits */ /* needs to adjust previous commits */
adjust_current_commits(); adjust_current_commits();
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
#ifndef YAPOR #ifndef YAPOR
@ -1216,7 +1209,7 @@ c_goal(Term Goal)
CELL l2 = ++labelno; CELL l2 = ++labelno;
if (profiling) 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; or_found = 1;
push_branch(onbranch, TermNil); push_branch(onbranch, TermNil);
cur_branch++; cur_branch++;
@ -1247,20 +1240,17 @@ c_goal(Term Goal)
onbranch = pop_branch(); onbranch = pop_branch();
emit(pop_or_op, Zero, Zero); emit(pop_or_op, Zero, Zero);
/* --onbranch; */ /* --onbranch; */
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
#endif /* YAPOR */ #endif /* YAPOR */
else p = RepPredProp(p0 = PredPropByAtom(atom, mod));
f = MkFunctor(atom, 0);
p = RepPredProp(p0 = PredProp(atom, 0));
/* if we are profiling, make sure we register we entered this predicate */ /* if we are profiling, make sure we register we entered this predicate */
if (profiling) if (profiling)
emit(enter_profiling_op, (CELL)p, Zero); emit(enter_profiling_op, (CELL)p, Zero);
} }
else { else {
f = FunctorOfTerm(Goal); f = FunctorOfTerm(Goal);
p = RepPredProp(p0 = PredPropByFunc(f, *CurrentModulePtr)); p = RepPredProp(p0 = PredPropByFunc(f, mod));
if (f == FunctorOr) { if (f == FunctorOr) {
CELL l = ++labelno; CELL l = ++labelno;
CELL m = ++labelno; CELL m = ++labelno;
@ -1289,7 +1279,7 @@ c_goal(Term Goal)
} }
emit_3ops(push_or_op, l, Zero, Zero); emit_3ops(push_or_op, l, Zero, Zero);
if (looking_at_comit && 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 * let them think they are still the
* first * first
@ -1346,16 +1336,16 @@ c_goal(Term Goal)
} }
save = onlast; save = onlast;
onlast = FALSE; onlast = FALSE;
c_goal(ArgOfTerm(1, arg)); c_goal(ArgOfTerm(1, arg), mod);
if (!optimizing_comit) { if (!optimizing_comit) {
c_var((Term) comitvar, comit_b_flag, c_var((Term) comitvar, comit_b_flag,
1); 1);
} }
onlast = save; onlast = save;
c_goal(ArgOfTerm(2, arg)); c_goal(ArgOfTerm(2, arg), mod);
} }
else else
c_goal(ArgOfTerm(1, Goal)); c_goal(ArgOfTerm(1, Goal), mod);
if (!onlast) { if (!onlast) {
emit(jump_op, m, Zero); emit(jump_op, m, Zero);
} }
@ -1372,16 +1362,15 @@ c_goal(Term Goal)
else { else {
optimizing_comit = FALSE; /* not really necessary */ optimizing_comit = FALSE; /* not really necessary */
} }
c_goal(Goal); c_goal(Goal, mod);
/* --onbranch; */ /* --onbranch; */
onbranch = pop_branch(); onbranch = pop_branch();
if (!onlast) { if (!onlast) {
emit(label_op, m, Zero); emit(label_op, m, Zero);
if ((onlast = save)) if ((onlast = save))
c_goal(MkAtomTerm(AtomTrue)); c_goal(MkAtomTerm(AtomTrue), mod);
} }
emit(pop_or_op, Zero, Zero); emit(pop_or_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
else if (f == FunctorComma) { else if (f == FunctorComma) {
@ -1389,10 +1378,9 @@ c_goal(Term Goal)
int t2 = ArgOfTerm(2, Goal); int t2 = ArgOfTerm(2, Goal);
onlast = FALSE; onlast = FALSE;
c_goal(ArgOfTerm(1, Goal)); c_goal(ArgOfTerm(1, Goal), mod);
onlast = save; onlast = save;
c_goal(t2); c_goal(t2, mod);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
else if (f == FunctorNot || f == FunctorAltNot) { else if (f == FunctorNot || f == FunctorAltNot) {
@ -1416,7 +1404,7 @@ c_goal(Term Goal)
emit_3ops(push_or_op, label, Zero, Zero); emit_3ops(push_or_op, label, Zero, Zero);
emit_3ops(either_op, label, Zero, Zero); emit_3ops(either_op, label, Zero, Zero);
emit(restore_tmps_op, 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); c_var(comitvar, comit_b_flag, 1);
onlast = save; onlast = save;
emit(fail_op, end_label, Zero); emit(fail_op, end_label, Zero);
@ -1427,10 +1415,9 @@ c_goal(Term Goal)
onlast = save; onlast = save;
/* --onbranch; */ /* --onbranch; */
onbranch = pop_branch(); onbranch = pop_branch();
c_goal(MkAtomTerm(AtomTrue)); c_goal(MkAtomTerm(AtomTrue), mod);
++goalno; ++goalno;
emit(pop_or_op, Zero, Zero); emit(pop_or_op, Zero, Zero);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} }
else if (f == FunctorArrow) { else if (f == FunctorArrow) {
@ -1445,11 +1432,10 @@ c_goal(Term Goal)
} }
onlast = FALSE; onlast = FALSE;
c_var(comitvar, save_b_flag, 1); 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); c_var(comitvar, comit_b_flag, 1);
onlast = save; onlast = save;
c_goal(ArgOfTerm(2, Goal)); c_goal(ArgOfTerm(2, Goal), mod);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} else if (f == FunctorEq) { } else if (f == FunctorEq) {
if (profiling) if (profiling)
@ -1468,23 +1454,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock); READ_UNLOCK(CurrentPred->PRWLock);
#endif #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; return;
} else if (p->PredFlags & BasicPredFlag) { } else if (p->PredFlags & BasicPredFlag) {
int op = p->PredFlags & 0x7f; int op = p->PredFlags & 0x7f;
@ -1505,16 +1474,16 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock); READ_UNLOCK(CurrentPred->PRWLock);
#endif #endif
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} else if (op >= _plus && op <= _functor) { } else if (op >= _plus && op <= _functor) {
if (op == _functor) { if (op == _functor) {
c_functor(Goal); c_functor(Goal, mod);
} else { } else {
c_bifun(op, c_bifun(op,
ArgOfTerm(1, Goal), ArgOfTerm(1, Goal),
ArgOfTerm(2, Goal), ArgOfTerm(2, Goal),
ArgOfTerm(3, Goal)); ArgOfTerm(3, Goal),
mod);
} }
if (onlast) { if (onlast) {
emit(deallocate_op, Zero, Zero); emit(deallocate_op, Zero, Zero);
@ -1529,7 +1498,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock); READ_UNLOCK(CurrentPred->PRWLock);
#endif #endif
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} else { } else {
c_args(Goal); c_args(Goal);
@ -1604,7 +1572,6 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock); READ_UNLOCK(CurrentPred->PRWLock);
#endif #endif
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return; return;
} else { } else {
if (profiling) if (profiling)
@ -1678,7 +1645,6 @@ c_goal(Term Goal)
if (!onlast) if (!onlast)
++goalno; ++goalno;
} }
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
} }
static void static void
@ -1707,7 +1673,7 @@ get_type_info(Term Goal)
} }
static void static void
c_body(Term Body) c_body(Term Body, int mod)
{ {
onhead = FALSE; onhead = FALSE;
BodyStart = cpc; BodyStart = cpc;
@ -1728,11 +1694,11 @@ c_body(Term Body)
Body = ArgOfTerm(1, Body); Body = ArgOfTerm(1, Body);
break; break;
} }
c_goal(ArgOfTerm(1, Body)); c_goal(ArgOfTerm(1, Body), mod);
Body = t2; Body = t2;
} }
onlast = TRUE; onlast = TRUE;
c_goal(Body); c_goal(Body, mod);
} }
static void static void
@ -2739,7 +2705,7 @@ c_optimize(PInstr *pc)
} }
CODEADDR 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 */ { /* compile a prolog clause, copy of clause myst be in ARG1 */
/* returns address of code for clause */ /* returns address of code for clause */
Term head, body; Term head, body;
@ -2750,7 +2716,6 @@ cclause(Term inp_clause, int NOfArgs)
int botch_why; int botch_why;
volatile Term my_clause = inp_clause; volatile Term my_clause = inp_clause;
/* may botch while doing a different module */ /* may botch while doing a different module */
volatile int save_CurrentModule = CurrentModule;
/* first, initialise CompilerBotch to handle all cases of interruptions */ /* first, initialise CompilerBotch to handle all cases of interruptions */
ErrorMessage = NIL; ErrorMessage = NIL;
@ -2760,7 +2725,6 @@ cclause(Term inp_clause, int NOfArgs)
reset_vars(); reset_vars();
{ {
Int osize = 2*sizeof(CELL)*(ASP-H); Int osize = 2*sizeof(CELL)*(ASP-H);
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
ARG1 = my_clause; ARG1 = my_clause;
if (!gc(2, ENV, P)) { if (!gc(2, ENV, P)) {
Error_TYPE = SYSTEM_ERROR; Error_TYPE = SYSTEM_ERROR;
@ -2780,7 +2744,6 @@ cclause(Term inp_clause, int NOfArgs)
/* out of temporary cells */ /* out of temporary cells */
restore_machine_regs(); restore_machine_regs();
reset_vars(); reset_vars();
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
if (maxvnum < 16*1024) { if (maxvnum < 16*1024) {
maxvnum *= 2; maxvnum *= 2;
} else { } else {
@ -2790,7 +2753,6 @@ cclause(Term inp_clause, int NOfArgs)
/* not enough heap */ /* not enough heap */
restore_machine_regs(); restore_machine_regs();
reset_vars(); reset_vars();
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
Error_TYPE = SYSTEM_ERROR; Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil; Error_Term = TermNil;
ErrorMessage = "not enough heap space to compile clause"; ErrorMessage = "not enough heap space to compile clause";
@ -2798,7 +2760,6 @@ cclause(Term inp_clause, int NOfArgs)
} }
restart_compilation: restart_compilation:
if (ErrorMessage != NIL) { if (ErrorMessage != NIL) {
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
reset_vars(); reset_vars();
return (0); return (0);
} }
@ -2852,9 +2813,9 @@ cclause(Term inp_clause, int NOfArgs)
/* find out which predicate we are compiling for */ /* find out which predicate we are compiling for */
if (IsAtomTerm(head)) { if (IsAtomTerm(head)) {
Atom ap = AtomOfTerm(head); Atom ap = AtomOfTerm(head);
CurrentPred = RepPredProp(PredProp(ap, 0)); CurrentPred = RepPredProp(PredPropByAtom(ap, mod));
} else { } else {
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),*CurrentModulePtr)); CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),mod));
} }
/* insert extra instructions to count calls */ /* insert extra instructions to count calls */
READ_LOCK(CurrentPred->PRWLock); READ_LOCK(CurrentPred->PRWLock);
@ -2868,7 +2829,7 @@ cclause(Term inp_clause, int NOfArgs)
/* phase 1 : produce skeleton code and variable information */ /* phase 1 : produce skeleton code and variable information */
c_head(head); c_head(head);
emit(allocate_op, Zero, Zero); emit(allocate_op, Zero, Zero);
c_body(body); c_body(body, mod);
/* Insert blobs at the very end */ /* Insert blobs at the very end */
if (BlobsStart != NULL) { if (BlobsStart != NULL) {
cpc->nextInst = BlobsStart; cpc->nextInst = BlobsStart;

12
C/computils.c
View File

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

4
C/corout.c
View File

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

297
C/exec.c
View File

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

2
C/heapgc.c
View File

@ -359,7 +359,6 @@ push_registers(Int num_regs, yamop *nextop)
TrailTerm(TR+3) = DelayedVars; TrailTerm(TR+3) = DelayedVars;
TR += 4; TR += 4;
#endif #endif
TrailTerm(TR++) = AbsAppl(CurrentModulePtr-1);
for (i = 1; i <= num_regs; i++) for (i = 1; i <= num_regs; i++)
TrailTerm(TR++) = (CELL) XREGS[i]; TrailTerm(TR++) = (CELL) XREGS[i];
/* push any live registers we might have hanging around */ /* push any live registers we might have hanging around */
@ -403,7 +402,6 @@ pop_registers(Int num_regs, yamop *nextop)
DelayedVars = TrailTerm(ptr++); DelayedVars = TrailTerm(ptr++);
#endif #endif
#endif #endif
CurrentModulePtr = RepAppl(TrailTerm(ptr++))+1;
for (i = 1; i <= num_regs; i++) for (i = 1; i <= num_regs; i++)
XREGS[i] = TrailTerm(ptr++); XREGS[i] = TrailTerm(ptr++);
/* pop any live registers we might have hanging around */ /* 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]; CPredicate c_predicates[MAX_C_PREDS];
cmp_entry cmp_funcs[MAX_CMP_FUNCS]; cmp_entry cmp_funcs[MAX_CMP_FUNCS];
static CELL InitModuleAddress;
/************** declarations local to init.c ************************/ /************** declarations local to init.c ************************/
static char *optypes[] = static char *optypes[] =
{"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"}; {"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"};
@ -511,9 +509,13 @@ void
InitCPred(char *Name, int Arity, CPredicate code, int flags) InitCPred(char *Name, int Arity, CPredicate code, int flags)
{ {
Atom atom = LookupAtom(Name); Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity)); PredEntry *pe;
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); 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; pe->PredFlags = flags | StandardPredFlag | CPredFlag;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_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); p_code->opc = opcode(_procceed);
{ {
Term mod = CurrentModule; Term mod = CurrentModule;
if (mod) mod = MkIntTerm(mod);
pe->ModuleOfPred = mod; pe->ModuleOfPred = mod;
} }
if (!(flags & UserCPredFlag)) { if (!(flags & UserCPredFlag)) {
@ -542,12 +543,17 @@ void
InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int flags) InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int flags)
{ {
Atom atom = LookupAtom(Name); Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity)); PredEntry *pe;
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); 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; pe->PredFlags = flags | StandardPredFlag | CPredFlag;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
pe->ModuleOfPred = CurrentModule;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL; p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize); p_code->u.sla.s = -Signed(RealEnvSize);
@ -567,14 +573,19 @@ void
InitAsmPred(char *Name, int Arity, int code, CPredicate def, int flags) InitAsmPred(char *Name, int Arity, int code, CPredicate def, int flags)
{ {
Atom atom = LookupAtom(Name); 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); pe->PredFlags = flags | StandardPredFlag | (code);
if (def != NULL) { if (def != NULL) {
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) def; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) def;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
pe->ModuleOfPred = CurrentModule;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL; p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize); p_code->u.sla.s = -Signed(RealEnvSize);
@ -634,7 +645,10 @@ InitCPredBack(char *Name, int Arity, int Extra, CPredicate Start, CPredicate Con
PredEntry *pe; PredEntry *pe;
Atom atom = LookupAtom(Name); 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) if (pe->FirstClause != NIL)
CleanBack(pe, Start, Cont); CleanBack(pe, Start, Cont);
else { else {
@ -753,11 +767,11 @@ InitCodes(void)
heap_regs->seq_def = TRUE; heap_regs->seq_def = TRUE;
heap_regs->getworkfirsttimecode.opc = opcode(_getwork_first_time); heap_regs->getworkfirsttimecode.opc = opcode(_getwork_first_time);
heap_regs->getworkcode.opc = opcode(_getwork); 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); INIT_YAMOP_LTT(&(heap_regs->getworkcode), 0);
heap_regs->getworkcode_seq.opc = opcode(_getwork_seq); heap_regs->getworkcode_seq.opc = opcode(_getwork_seq);
INIT_YAMOP_LTT(&(heap_regs->getworkcode_seq), 0); 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 */ #endif /* YAPOR */
#ifdef TABLING #ifdef TABLING
heap_regs->tablecompletioncode.opc = opcode(_table_completion); 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_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1);
heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1); heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1);
heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_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_minus = MkFunctor (heap_regs->atom_minus, 1);
heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1); heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1);
heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2); heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2);
@ -986,12 +999,16 @@ InitCodes(void)
heap_regs->yap_lib_dir = NULL; heap_regs->yap_lib_dir = NULL;
heap_regs->size_of_overflow = 0; heap_regs->size_of_overflow = 0;
/* make sure no one else can use these two atoms */ /* 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),1));
heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),MkIntTerm(1))); CurrentModule = 0;
*CurrentModulePtr = MkIntTerm(0);
heap_regs->dead_clauses = NULL; 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)); 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 static void
@ -1032,7 +1049,7 @@ InitYaamRegs(void)
#endif #endif
at = FullLookupAtom("$undefp"); at = FullLookupAtom("$undefp");
{ {
Prop p = GetPredProp (at, 1); Prop p = GetPredPropByFunc(MkFunctor(at, 1),0);
if (p == NIL) { if (p == NIL) {
UndefCode = NULL; UndefCode = NULL;
} else { } else {
@ -1116,7 +1133,6 @@ InitStacks(int Heap,
/* the emulator will eventually copy them to its own local /* the emulator will eventually copy them to its own local
register array, but for now they exist */ register array, but for now they exist */
#endif /* PUSH_REGS */ #endif /* PUSH_REGS */
CurrentModulePtr = &InitModuleAddress;
/* Init signal handling and time */ /* Init signal handling and time */
/* also init memory page size, required by later functions */ /* also init memory page size, required by later functions */

6
C/load_foreign.c
View File

@ -121,17 +121,17 @@ void
ReOpenLoadForeign(void) ReOpenLoadForeign(void)
{ {
ForeignObj *f_code = ForeignCodeLoaded; ForeignObj *f_code = ForeignCodeLoaded;
int OldModule = CurrentModule; SMALLUNSGN OldModule = CurrentModule;
YapInitProc InitProc = NULL; YapInitProc InitProc = NULL;
while (f_code != 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) { if(ReLoadForeign(f_code->objs,f_code->libs,f_code->f,&InitProc)==LOAD_SUCCEEDED) {
(*InitProc)(); (*InitProc)();
} }
f_code = f_code->next; 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]); return(ModuleName[CurrentModule]);
else { else {
if (ap->ModuleOfPred)
return (ModuleName[IntOfTerm(ap->ModuleOfPred)]);
return (ModuleName[ap->ModuleOfPred]); return (ModuleName[ap->ModuleOfPred]);
} }
} }
@ -73,10 +71,10 @@ p_current_module(void)
return (0); return (0);
for (i = 0; i < NoOfModules; ++i) for (i = 0; i < NoOfModules; ++i)
if (ModuleName[i] == t) { if (ModuleName[i] == t) {
*CurrentModulePtr = MkIntTerm(i); CurrentModule = i;
return (TRUE); return (TRUE);
} }
*CurrentModulePtr = MkIntTerm(NoOfModules); CurrentModule = NoOfModules;
ModuleName[NoOfModules++] = t; ModuleName[NoOfModules++] = t;
return (TRUE); return (TRUE);
} }
@ -92,8 +90,8 @@ p_current_module1(void)
static Int static Int
p_change_module(void) p_change_module(void)
{ /* $change_module(New) */ { /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1))); SMALLUNSGN mod = LookupModule(Deref(ARG1));
UpdateTimedVar(AbsAppl(CurrentModulePtr-1), t); CurrentModule = mod;
return (TRUE); return (TRUE);
} }
@ -101,7 +99,9 @@ static Int
p_module_number(void) p_module_number(void)
{ /* $change_module(New) */ { /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1))); Term t = MkIntTerm(LookupModule(Deref(ARG1)));
return (unify(ARG2,t)); unify(t,ARG2);
ARG2 = t;
return(TRUE);
} }
void void
@ -109,10 +109,10 @@ InitModules(void)
{ {
ModuleName[PrimitivesModule = 0] = ModuleName[PrimitivesModule = 0] =
MkAtomTerm(LookupAtom("prolog")); MkAtomTerm(LookupAtom("prolog"));
*CurrentModulePtr = MkIntTerm(0); CurrentModule = 0;
ModuleName[1] = MkAtomTerm(LookupAtom("user")); ModuleName[1] = MkAtomTerm(LookupAtom("user"));
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag); InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag); InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
InitCPred("$change_module", 1, p_change_module, 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 *)TopB);
putcellptr((CELL *)DelayedB); putcellptr((CELL *)DelayedB);
putout(FlipFlop); putout(FlipFlop);
putcellptr(CurrentModulePtr); putout(CurrentModule);
#ifdef COROUTINING #ifdef COROUTINING
putout(DelayedVars); putout(DelayedVars);
#endif #endif
@ -672,7 +672,7 @@ get_regs(int flag)
TopB = (choiceptr)get_cellptr(); TopB = (choiceptr)get_cellptr();
DelayedB = (choiceptr)get_cellptr(); DelayedB = (choiceptr)get_cellptr();
FlipFlop = get_cell(); FlipFlop = get_cell();
CurrentModulePtr = get_cellptr(); CurrentModule = get_cell();
#ifdef COROUTINING #ifdef COROUTINING
DelayedVars = get_cell(); DelayedVars = get_cell();
#endif #endif
@ -1097,7 +1097,6 @@ restore_codes(void)
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS); 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_change_module = FuncAdjust(heap_regs->functor_change_module);
heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_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_minus = FuncAdjust(heap_regs->functor_u_minus);
heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus); heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus);
heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar); heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar);
@ -1164,8 +1163,6 @@ restore_regs(int flag)
HeapPlus = AddrAdjust(HeapPlus); HeapPlus = AddrAdjust(HeapPlus);
if (MyTR) if (MyTR)
MyTR = PtoTRAdjust(MyTR); MyTR = PtoTRAdjust(MyTR);
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
#ifdef COROUTINING #ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars))); DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
#ifdef MULTI_ASSIGNMENT_VARIABLES #ifdef MULTI_ASSIGNMENT_VARIABLES

55
C/stdpreds.c
View File

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

4
C/write.c
View File

@ -379,7 +379,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
Term targs[1]; Term targs[1];
targs[0] = t; targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil)); PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0); execute_goal(MkApplTerm(FunctorPortray, 1, targs), 0, 1);
Use_portray = TRUE; Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue)) if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return; return;
@ -456,7 +456,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
Term targs[1]; Term targs[1];
targs[0] = t; targs[0] = t;
PutValue(AtomPortray, MkAtomTerm(AtomNil)); PutValue(AtomPortray, MkAtomTerm(AtomNil));
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0); execute_goal(MkApplTerm(FunctorPortray, 1, targs),0, 1);
Use_portray = TRUE; Use_portray = TRUE;
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue)) if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
return; 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
-mkdir $(DESTDIR)$(LIBDIR)/library/chr -mkdir $(DESTDIR)$(LIBDIR)/library/chr
-mkdir $(DESTDIR)$(LIBDIR)/library/chr/examples -mkdir $(DESTDIR)$(LIBDIR)/library/chr/examples
$(INSTALL_DATA) $(CHR_TOP) $(DESTDIR)$(LIBDIR)/library for h in $(CHR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
$(INSTALL_DATA) $(CHR_LICENSE) $(DESTDIR)$(LIBDIR)/library for h in $(CHR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
$(INSTALL_DATA) $(CHR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/chr for h in $(CHR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/chr; done
$(INSTALL_DATA) $(CHR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/chr/examples 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/fourmotz.pl \
$(srcdir)/clpqr/ineq.yap \ $(srcdir)/clpqr/ineq.yap \
$(srcdir)/clpqr/itf3.pl \ $(srcdir)/clpqr/itf3.pl \
$(srcdir)/clpqr/nf.yap \
$(srcdir)/clpqr/ordering.yap \ $(srcdir)/clpqr/ordering.yap \
$(srcdir)/clpqr/project.pl \ $(srcdir)/clpqr/project.pl \
$(srcdir)/clpqr/redund.pl \ $(srcdir)/clpqr/redund.pl \
@ -38,19 +37,21 @@ CLPQR_LOCAL= \
$(srcdir)/clpqr/monash.pl \ $(srcdir)/clpqr/monash.pl \
$(srcdir)/clpqr/printf.pl $(srcdir)/clpqr/printf.pl
CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.pl \ CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.yap \
$(srcdir)/clpr/class.pl\ $(srcdir)/clpr/class.yap\
$(srcdir)/clpr/geler.yap \ $(srcdir)/clpr/geler.yap \
$(srcdir)/clpr/nf.yap \
$(srcdir)/clpr/nfr.yap $(srcdir)/clpr/nfr.yap
CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.pl \ CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.yap \
$(srcdir)/clpq/class.pl\ $(srcdir)/clpq/class.yap \
$(srcdir)/clpq/geler.yap \ $(srcdir)/clpq/geler.yap \
$(srcdir)/clpr/nf.yap \
$(srcdir)/clpq/nfq.yap $(srcdir)/clpq/nfq.yap
CLPR_TOP= $(srcdir)/clpr.yap CLPR_TOP= $(srcdir)/clpr.yap
CLPQ_TOP= $(srcdir)/clpq.pl CLPQ_TOP= $(srcdir)/clpq.yap
CLPQR_LICENSE= $(srcdir)/CLPQR.LICENSE 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
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION -mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash -mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash
$(INSTALL_DATA) $(CLPQ_TOP) $(DESTDIR)$(LIBDIR)/library for h in $(CLPQ_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
$(INSTALL_DATA) $(CLPR_TOP) $(DESTDIR)$(LIBDIR)/library for h in $(CLPR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
$(INSTALL_DATA) $(CLPQR_LICENSE) $(DESTDIR)$(LIBDIR)/library for h in $(CLPQR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq for h in $(CLPQR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done
$(INSTALL_DATA) $(CLPQ_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq for h in $(CLPQ_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpq; done
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr for h in $(CLPR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpr; done
$(INSTALL_DATA) $(CLPR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr for h in $(CLPQR_LOCAL); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done
$(INSTALL_DATA) $(CLPQR_LOCAL) $(DESTDIR)$(LIBDIR)/library/clpqr for h in $(CLPQR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples; done
$(INSTALL_DATA) $(CLPQR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/clpqr/examples for h in $(CLPQR_EXAMPLES_MONASH); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash; done
$(INSTALL_DATA) $(CLPQR_EXAMPLES_MONASH) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash for h in $(CLPQR_EXAMPLES_SESSION); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION; done
$(INSTALL_DATA) $(CLPQR_EXAMPLES_SESSION) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION

2
CLPQR/clpq/nfq.yap
View File

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

18
CLPQR/clpqr/bv.yap
View File

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

1
CLPQR/clpr.pl
View File

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

22
CLPQR/clpr.yap
View File

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

1
CLPQR/clpr/arith_r.pl
View File

@ -31,6 +31,7 @@ arith_module( nfr).
:- dynamic :- dynamic
user:goal_expansion/3. user:goal_expansion/3.
% %
user:goal_expansion(arith_eval(Term,Res), Module, Expansion) :- user:goal_expansion(arith_eval(Term,Res), Module, Expansion) :-
arith_module( Module), arith_module( Module),
compile_R( Term, Res, Code), 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], Res = [Y|Tail],
delete_first( Ys, X, 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(+,:). :- meta_predicate geler(+,:).
% %
geler( Vars, Goal) :- geler( Vars, Goal) :-
attach( Vars, run(_Mutex,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 % % Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module( nfr, :- module( nfr,
[ [
{}/1, {}/1,
@ -43,7 +42,7 @@
solve/1 solve/1
]). ]).
:- ensure_loaded( nf). :- ensure_loaded(nf).
transg( resubmit_eq(Nf)) --> transg( resubmit_eq(Nf)) -->
{ {

7
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h * * File: Heap.h *
* mods: * * mods: *
* comments: Heap Init Structure * * comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.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 */ /* information that can be stored in Code Space */
@ -97,7 +97,7 @@ typedef struct various_codes {
Term mutable_list; Term mutable_list;
Term atts_mutable_list; Term atts_mutable_list;
#endif #endif
CELL *wake_up_code; PredEntry *wake_up_code;
#endif #endif
struct pred_entry *creep_code; struct pred_entry *creep_code;
struct pred_entry *undef_code; struct pred_entry *undef_code;
@ -253,7 +253,6 @@ typedef struct various_codes {
functor_stream_eOS, functor_stream_eOS,
functor_change_module, functor_change_module,
functor_current_module, functor_current_module,
functor_mod_switch,
functor_u_minus, functor_u_minus,
functor_u_plus, functor_u_plus,
functor_v_bar, functor_v_bar,
@ -295,8 +294,6 @@ typedef struct various_codes {
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode )) #define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */ #endif /* TABLING */
#define FAILCODE ((CODEADDR)&(heap_regs->failcode )) #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 TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode ))
#define YESCODE ((CODEADDR)&(heap_regs->yescode )) #define YESCODE ((CODEADDR)&(heap_regs->yescode ))
#define NOCODE ((CODEADDR)&(heap_regs->nocode )) #define NOCODE ((CODEADDR)&(heap_regs->nocode ))

7
H/Regs.h
View File

@ -10,7 +10,7 @@
* File: Regs.h * * File: Regs.h *
* mods: * * mods: *
* comments: YAP abstract machine registers * * 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 */ Term TermNil_; /* 20 */
#endif #endif
#endif #endif
CELL *CurrentModulePtr_; SMALLUNSGN CurrentModulePtr_;
#if (defined(YAPOR) && defined(SBA)) || defined(TABLING) #if (defined(YAPOR) && defined(SBA)) || defined(TABLING)
CELL *H_FZ_; CELL *H_FZ_;
choiceptr B_FZ_; choiceptr B_FZ_;
@ -639,8 +639,7 @@ EXTERN inline void restore_B(void) {
#ifdef COROUTINING #ifdef COROUTINING
#define DelayedVars REGS.DelayedVars_ #define DelayedVars REGS.DelayedVars_
#endif #endif
#define CurrentModulePtr REGS.CurrentModulePtr_ #define CurrentModule REGS.CurrentModulePtr_
#define CurrentModule IntOfTerm(*REGS.CurrentModulePtr_)
#define REG_SIZE sizeof(REGS)/sizeof(CELL *) #define REG_SIZE sizeof(REGS)/sizeof(CELL *)

21
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto * * File: Yap.proto *
* mods: * * mods: *
* comments: Function declarations for YAP * * 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 */ /* prototype file for Yap */
@ -36,8 +36,8 @@ Atom STD_PROTO(LookupAtom,(char *));
Atom STD_PROTO(FullLookupAtom,(char *)); Atom STD_PROTO(FullLookupAtom,(char *));
void STD_PROTO(LookupAtomWithAddress,(char *,AtomEntry *)); void STD_PROTO(LookupAtomWithAddress,(char *,AtomEntry *));
Term STD_PROTO(MkApplTerm,(Functor,unsigned int,Term *)); Term STD_PROTO(MkApplTerm,(Functor,unsigned int,Term *));
Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, Term)); Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, SMALLUNSGN));
Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, Term)); Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, SMALLUNSGN));
Functor STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int)); Functor STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int));
Functor STD_PROTO(MkFunctor,(Atom,unsigned int)); Functor STD_PROTO(MkFunctor,(Atom,unsigned int));
void STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *)); void STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *));
@ -53,10 +53,9 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term));
#endif #endif
int STD_PROTO(LookupModule,(Term)); int STD_PROTO(LookupModule,(Term));
Prop STD_PROTO(GetPredProp,(Atom,unsigned int)); Prop STD_PROTO(GetPredPropByAtom,(Atom, int));
Prop STD_PROTO(GetPredPropByAtom,(Atom, Term)); Prop STD_PROTO(GetPredPropByFunc,(Functor, int));
Prop STD_PROTO(GetPredPropByFunc,(Functor, Term)); Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int,SMALLUNSGN));
Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int));
Prop STD_PROTO(GetExpProp,(Atom,unsigned int)); Prop STD_PROTO(GetExpProp,(Atom,unsigned int));
Prop STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int)); Prop STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int));
Term STD_PROTO(Module_Name, (CODEADDR)); Term STD_PROTO(Module_Name, (CODEADDR));
@ -120,7 +119,7 @@ int STD_PROTO(iequ,(Term,Term));
void STD_PROTO(InitCmpPreds,(void)); void STD_PROTO(InitCmpPreds,(void));
/* compiler.c */ /* compiler.c */
CODEADDR STD_PROTO(cclause,(Term, int)); CODEADDR STD_PROTO(cclause,(Term, int, int));
/* computils.c */ /* computils.c */
@ -149,10 +148,10 @@ void STD_PROTO(InitEval,(void));
Int STD_PROTO(EvFArt,(Term)); Int STD_PROTO(EvFArt,(Term));
/* exec.c */ /* exec.c */
Term STD_PROTO(ExecuteCallMetaCall,(void)); Term STD_PROTO(ExecuteCallMetaCall,(SMALLUNSGN mod));
void STD_PROTO(InitExecFs,(void)); void STD_PROTO(InitExecFs,(void));
int STD_PROTO(RunTopGoal,(Term)); 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)); int STD_PROTO(exec_absmi,(int));
@ -278,7 +277,7 @@ void STD_PROTO(InitUtilCPreds,(void));
/* yap.c */ /* yap.c */
void STD_PROTO(Abort,(char *msg, ...)); void STD_PROTO(Abort,(char *msg, ...));
void STD_PROTO(addclause,(Term,CODEADDR,int)); void STD_PROTO(addclause,(Term,CODEADDR,int,int));
/* ypsocks.c */ /* ypsocks.c */
void STD_PROTO(InitSockets,(void)); 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)); void STD_PROTO(emit_3ops,(compiler_vm_op,CELL,CELL,CELL));
CELL *STD_PROTO(emit_extra_size,(compiler_vm_op,CELL,int)); CELL *STD_PROTO(emit_extra_size,(compiler_vm_op,CELL,int));
char *STD_PROTO(AllocCMem,(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 *)); void STD_PROTO(bip_name,(Int, char *));
#ifdef DEBUG #ifdef DEBUG
void STD_PROTO(ShowCode,(void)); void STD_PROTO(ShowCode,(void));

2
Makefile.in
View File

@ -9,7 +9,7 @@ BINDIR = $(ROOTDIR)/bin
# #
# where YAP should look for libraries # where YAP should look for libraries
# #
LIBDIR=$(ROOTDIR)/lib/ LIBDIR=$(ROOTDIR)/lib
YAPLIBDIR=$(ROOTDIR)/lib/Yap YAPLIBDIR=$(ROOTDIR)/lib/Yap
# #
# where the includes should be stored # 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); InitCPred("$parallel_yes_answer", 0, p_parallel_yes_answer, SafePredFlag);
#endif /* YAPOR */ #endif /* YAPOR */
#ifdef TABLING #ifdef TABLING
InitCPred("$table", 1, p_table, SafePredFlag); InitCPred("$table", 2, p_table, SafePredFlag);
InitCPred("$abolish_trie", 1, p_abolish_trie, SafePredFlag); InitCPred("$do_abolish_trie", 2, p_abolish_trie, SafePredFlag);
InitCPred("$show_trie", 2, p_show_trie, SafePredFlag); InitCPred("$show_trie", 3, p_show_trie, SafePredFlag);
#endif /* TABLING */ #endif /* TABLING */
#ifdef STATISTICS #ifdef STATISTICS
InitCPred("show_frames", 0, p_show_frames, SafePredFlag); InitCPred("show_frames", 0, p_show_frames, SafePredFlag);
@ -183,25 +183,31 @@ int start_yapor(void) {
static static
int p_sequential(void) { int p_sequential(void) {
Term t; Term t, tmod;
Atom at; Atom at;
int arity; int arity;
PredEntry *pe; PredEntry *pe;
SMALLUNSGN mod;
t = Deref(ARG1); t = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return(FALSE);
}
mod = LookupModule(tmod);
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
at = AtomOfTerm(t); at = AtomOfTerm(t);
arity = 0; arity = 0;
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t); Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func); at = NameOfFunctor(func);
arity = ArityOfFunctor(func); arity = ArityOfFunctor(func);
pe = RepPredProp(PredPropByFunc(func, mod));
} else { } else {
abort_optyap("unknown term in function p_sequential"); abort_optyap("unknown term in function p_sequential");
at = NULL; /* just to avoid gcc warning */ return(FALSE);
arity = 0; /* just to avoid gcc warning */
} }
pe = RepPredProp(PredProp(at, arity));
pe->PredFlags |= SequentialPredFlag; pe->PredFlags |= SequentialPredFlag;
return (TRUE); return (TRUE);
} }
@ -449,25 +455,28 @@ void answer_to_stdout(char *answer) {
#ifdef TABLING #ifdef TABLING
static static
int p_table(void) { int p_table(void) {
Term t; Term t, t2;
Atom at;
int arity;
PredEntry *pe; PredEntry *pe;
tab_ent_ptr te; tab_ent_ptr te;
sg_node_ptr sg_node; sg_node_ptr sg_node;
SMALLUNSGN mod;
t = Deref(ARG1); t = Deref(ARG1);
t2 = Deref(ARG2);
if (IsVarTerm(t2) || !IsAtomTerm(t2)) {
return (FALSE);
} else {
mod = LookupModule(t2);
}
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
arity = 0; pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t); Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func); pe = RepPredProp(PredPropByFunc(func, mod));
arity = ArityOfFunctor(func);
} else } else
return (FALSE); return (FALSE);
pe = RepPredProp(PredProp(at, arity));
pe->PredFlags |= TabledPredFlag; pe->PredFlags |= TabledPredFlag;
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL);
new_table_entry(te, sg_node); new_table_entry(te, sg_node);
@ -479,25 +488,31 @@ int p_table(void) {
static static
int p_abolish_trie(void) { int p_abolish_trie(void) {
Term t; Term t, tmod;
Atom at; SMALLUNSGN mod;
int arity;
tab_ent_ptr tab_ent; tab_ent_ptr tab_ent;
sg_hash_ptr hash; sg_hash_ptr hash;
sg_node_ptr sg_node; sg_node_ptr sg_node;
UInt arity;
t = Deref(ARG1); t = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return (FALSE);
} else {
mod = LookupModule(tmod);
}
if (IsAtomTerm(t)) { if (IsAtomTerm(t)) {
at = AtomOfTerm(t); Atom at = AtomOfTerm(t);
tab_ent = RepPredProp(PredPropByAtom(at, mod))->TableOfPred;
arity = 0; arity = 0;
} else if (IsApplTerm(t)) { } else if (IsApplTerm(t)) {
Functor func = FunctorOfTerm(t); Functor func = FunctorOfTerm(t);
at = NameOfFunctor(func); tab_ent = RepPredProp(PredPropByFunc(func, mod))->TableOfPred;
arity = ArityOfFunctor(func); arity = ArityOfFunctor(func);
} else } else
return (FALSE); return (FALSE);
tab_ent = RepPredProp(PredProp(at, arity))->TableOfPred;
hash = TabEnt_hash_chain(tab_ent); hash = TabEnt_hash_chain(tab_ent);
TabEnt_hash_chain(tab_ent) = NULL; TabEnt_hash_chain(tab_ent) = NULL;
free_subgoal_hash_chain(hash); free_subgoal_hash_chain(hash);
@ -513,24 +528,32 @@ int p_abolish_trie(void) {
static static
int p_show_trie(void) { int p_show_trie(void) {
Term t1, t2; Term t1, t2, tmod;
Atom at;
int arity;
PredEntry *pe; PredEntry *pe;
SMALLUNSGN mod;
Atom at;
UInt arity;
t1 = Deref(ARG1); t1 = Deref(ARG1);
tmod = Deref(ARG2);
if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) {
return (FALSE);
} else {
mod = LookupModule(tmod);
}
if (IsAtomTerm(t1)) { if (IsAtomTerm(t1)) {
at = AtomOfTerm(t1); at = AtomOfTerm(t1);
arity = 0; arity = 0;
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t1)) { } else if (IsApplTerm(t1)) {
Functor func = FunctorOfTerm(t1); Functor func = FunctorOfTerm(t1);
at = NameOfFunctor(func); at = NameOfFunctor(func);
arity = ArityOfFunctor(func); arity = ArityOfFunctor(func);
pe = RepPredProp(PredPropByFunc(func, mod));
} else } else
return(FALSE); return (FALSE);
pe = RepPredProp(PredProp(at, arity));
t2 = Deref(ARG2); t2 = Deref(ARG3);
if (IsVarTerm(t2)) { if (IsVarTerm(t2)) {
Term ta = MkAtomTerm(LookupAtom("stdout")); Term ta = MkAtomTerm(LookupAtom("stdout"));
Bind((CELL *)t2, ta); 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]) :- do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :-
existing_attribute(_,Mod,Key), existing_attribute(_,Mod,Key),
get_att(AttVar,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), do_verify_attributes(Mods, AttVar, Binding, Goals),
Mod:verify_attributes(AttVar, Binding, Goal). Mod:verify_attributes(AttVar, Binding, Goal).
do_verify_attributes([_|Mods], AttVar, Binding, Goals) :- do_verify_attributes([_|Mods], AttVar, Binding, Goals) :-
@ -171,7 +171,7 @@ fetch_att_goals([_|LMods], Att, LGoal) :-
call_module_attributes(Mod, AttV, G1) :- call_module_attributes(Mod, AttV, G1) :-
existing_attribute(_,Mod,Key), existing_attribute(_,Mod,Key),
get_att(AttV,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). Mod:attribute_goal(AttV, G1).
simplify_trues((A,B), NG) :- !, 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 */ Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */ PropFlags KindOfPE; /* kind of property */
unsigned int ArityOfPE; /* arity of property */ unsigned int ArityOfPE; /* arity of property */
Term ModuleOfPred; /* module for this definition */ int ModuleOfPred; /* module for this definition */
CELL PredFlags; CELL PredFlags;
CODEADDR CodeOfPred; /* code address */ CODEADDR CodeOfPred; /* code address */
CODEADDR TrueCodeOfPred; /* if needing to spy or to lock */ 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 */ /* vsc: redefined to GetAProp to avoid conflicts with Windows header files */
Prop STD_PROTO(GetAProp,(Atom,PropFlags)); Prop STD_PROTO(GetAProp,(Atom,PropFlags));
Prop STD_PROTO(GetAPropHavingLock,(AtomEntry *,PropFlags)); Prop STD_PROTO(GetAPropHavingLock,(AtomEntry *,PropFlags));
Prop STD_PROTO(PredProp,(Atom,unsigned int));
EXTERN inline Prop 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. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;
@ -520,7 +519,7 @@ PredPropByFunc(Functor f, Term cur_mod)
} }
EXTERN inline Prop 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. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;

267
pl/boot.yap
View File

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

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

12
pl/consult.yap
View File

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

23
pl/corout.yap
View File

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

540
pl/debug.yap
View File

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

183
pl/depth_bound.yap
View File

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

4
pl/errors.yap
View File

@ -59,8 +59,8 @@
print_message(force(_Severity), Msg) :- !, print_message(force(_Severity), Msg) :- !,
print(user_error,Msg). print(user_error,Msg).
print_message(Severity, Msg) :- print_message(Severity, Msg) :-
\+ '$undefined'(user: portray_message(Severity, Msg)), \+ '$undefined'(portray_message(Severity, Msg), user),
user: portray_message(Severity, Msg), !. user:portray_message(Severity, Msg), !.
print_message(error,error(Msg,Where)) :- print_message(error,error(Msg,Where)) :-
'$output_error_message'(Msg, Where), !. '$output_error_message'(Msg, Where), !.
print_message(error,Throw) :- 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->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
'$t_body'(T, ToFill, not_last, S, SR1, Tt), '$t_body'(T, ToFill, not_last, S, SR1, Tt),
'$t_body'(R, ToFill, Last, SR1, SR, Rt). '$t_body'(R, ToFill, Last, SR1, SR, Rt).
'$t_body'((T;R), ToFill, _Last, S, SR, (Tt;Rt)) :- !, '$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
copy_term(ToFill,OtherToFill), '$t_body'(T, _, last, S, SR, Tt),
'$t_body'(T, OtherToFill, last, S, SR, Tt), '$t_body'(R, _, last, S, SR, Rt).
'$t_body'(R, ToFill, last, S, SR, Rt).
'$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !, '$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !,
'$t_body'(G, ToFill, Last, S, SR, NG). '$t_body'(G, ToFill, Last, S, SR, NG).
'$t_body'(T, filled_in, _, S, SR, Tt) :- '$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). :- module(user).
:- multifile library_directory/1.
:- dynamic_predicate(library_directory/1, logical). :- dynamic_predicate(library_directory/1, logical).
:- multifile goal_expansion/3. :- multifile goal_expansion/3.
:- dynamic_predicate(goal_expansion/3, logical). :- 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)). :- get_value(system_library_directory,D), assert(library_directory(D)).

42
pl/listing.yap
View File

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

67
pl/modules.yap
View File

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

568
pl/preds.yap
View File

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

308
pl/utils.yap
View File

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

39
pl/yapor.yap
View File

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