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

New metacall mechanism

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@169 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2001-10-30 16:42:05 +00:00
parent 8cc0f4e803
commit 458a0a857f
50 changed files with 1234 additions and 960 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

186
C/absmi.c
View File

@ -1604,7 +1604,7 @@ absmi(int inp)
ENDBOp();
NoStackExecute:
SREG = (CELL *) (PREG->u.l.l);
SREG = (CELL *) pred_entry(PREG->u.l.l);
#ifdef YAPOR
/* abort_optyap("NoStackExecute in function absmi"); */
if (HeapTop > GlobalBase - MinHeapGap)
@ -1747,7 +1747,8 @@ absmi(int inp)
NoStackCall:
/* on X86 machines S will not actually be holding the pointer to pred */
SREG = (CELL *) (PREG->u.sla.l);
SREG = (CELL *) PREG->u.sla.p;
NoStackCallGotS:
#ifdef YAPOR
/* abort_optyap("NoStackCall in function absmi"); */
if (HeapTop > GlobalBase - MinHeapGap)
@ -1776,7 +1777,7 @@ absmi(int inp)
if (ASP > (CELL *)B)
ASP = (CELL *)B;
saveregs();
gc(PredArity(SREG), Y, NEXTOP(PREG, sla));
gc(((PredEntry *)SREG)->ArityOfPE, Y, NEXTOP(PREG, sla));
setregs();
JMPNext();
@ -1788,7 +1789,7 @@ absmi(int inp)
NoStackComitY:
/* find something to fool S */
if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) {
SREG = (CELL *)&(RepPredProp(GetPredProp(AtomRestoreRegs,2))->StateOfPred);
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2));
PREG = NEXTOP(PREG,x);
XREGS[0] = XREG(PREG->u.y.y);
goto creep_either;
@ -1800,7 +1801,7 @@ absmi(int inp)
NoStackComitX:
/* find something to fool S */
if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) {
SREG = (CELL *)&(RepPredProp(GetPredProp(AtomRestoreRegs,2))->StateOfPred);
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2));
PREG = NEXTOP(PREG,x);
#if USE_THREADED_CODE
if (PREG->opc == (OPCODE)OpAddress[_fcall])
@ -1826,7 +1827,7 @@ absmi(int inp)
/* don't forget I cannot creep at ; */
NoStackEither:
/* find something to fool S */
SREG = (CELL *)&(RepPredProp(GetPredProp(AtomRestoreRegs,1))->StateOfPred);
SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,1));
#ifdef YAPOR
/* abort_optyap("NoStackCall in function absmi"); */
if (HeapTop > GlobalBase - MinHeapGap)
@ -1911,7 +1912,7 @@ absmi(int inp)
NoStackDExecute:
/* set SREG for next instructions */
SREG = (CELL *) (PREG->u.l.l);
SREG = (CELL *) pred_entry(PREG->u.l.l);
#ifdef YAPOR
/* abort_optyap("noStackDExecute in function absmi"); */
if (HeapTop > GlobalBase - MinHeapGap)
@ -1945,7 +1946,7 @@ absmi(int inp)
if (ASP > (CELL *)B)
ASP = (CELL *)B;
saveregs();
gc(PredArity(SREG), ENV, CPREG);
gc(((PredEntry *)(SREG))->ArityOfPE, ENV, CPREG);
setregs();
/* hopefully, gc will succeeded, and we will retry
* the instruction */
@ -2005,13 +2006,13 @@ absmi(int inp)
S = SREG;
#endif
BEGD(d0);
d0 = PredArity(SREG);
d0 = ((PredEntry *)(SREG))->ArityOfPE;
if (d0 == 0) {
my_goal = MkAtomTerm((Atom) PredFunctor(SREG));
my_goal = MkAtomTerm((Atom)((PredEntry *)(SREG))->FunctorOfPred);
}
else {
my_goal = AbsAppl(H);
*H = (CELL) PredFunctor(SREG);
*H = (CELL) ((PredEntry *)(SREG))->FunctorOfPred;
H++;
BEGP(pt1);
pt1 = XREGS + 1;
@ -2047,12 +2048,12 @@ absmi(int inp)
ENDP(pt1);
}
ENDD(d0);
H[0] = Module_Name((CODEADDR)pred_entry(SREG));
H[0] = Module_Name((CODEADDR)SREG);
H[1] = my_goal;
ARG1 = AbsPair(H);
H += 2;
ARG2 = ListOfWokenGoals();
SREG = (CELL *) (Unsigned(WakeUpCode) - sizeof(SMALLUNSGN));
SREG = (CELL *) (WakeUpCode);
/* no more goals to wake up */
UpdateTimedVar(WokenGoals, TermNil);
@ -2084,13 +2085,13 @@ absmi(int inp)
S = SREG;
#endif
BEGD(d0);
d0 = PredArity(SREG);
d0 = ((PredEntry *)(SREG))->ArityOfPE;
if (d0 == 0) {
H[1] = MkAtomTerm((Atom) PredFunctor(SREG));
H[1] = MkAtomTerm((Atom) ((PredEntry *)(SREG))->FunctorOfPred);
}
else {
H[d0 + 2] = AbsAppl(H);
*H = (CELL) PredFunctor(SREG);
*H = (CELL) ((PredEntry *)(SREG))->FunctorOfPred;
H++;
BEGP(pt1);
pt1 = XREGS + 1;
@ -2125,20 +2126,20 @@ absmi(int inp)
ENDP(pt1);
}
ENDD(d0);
H[0] = Module_Name((CODEADDR)pred_entry(SREG));
H[0] = Module_Name(((CODEADDR)(SREG)));
ARG1 = (Term) AbsPair(H);
H += 2;
CFREG = CalculateStackGap();
SREG = (CELL *) (Unsigned(CreepCode) - sizeof(SMALLUNSGN));
SREG = (CELL *) CreepCode;
#ifdef COROUTINING
}
#endif
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,pred_entry(SREG),XREGS+1);
low_level_trace(enter_pred,(PredEntry *)(SREG),XREGS+1);
#endif /* LOW_LEVEL_TRACE */
PREG = (yamop *) PredCode(SREG);
PREG = (yamop *) ((PredEntry *)(SREG))->CodeOfPred;
CACHE_A1();
JMPNext();
@ -5643,15 +5644,13 @@ absmi(int inp)
d0 = (CELL) (PREG->u.sla.l);
PREG = NEXTOP(PREG, sla);
saveregs();
SREG = (CELL *) (*((Int (*)(void)) d0)) ();
ENDD(d0);
d0 = (*((Int (*)(void)) d0)) ();
setregs();
if (!SREG) {
if (!d0) {
FAIL();
}
CACHE_A1();
ENDD(d0);
JMPNext();
ENDBOp();
@ -5903,7 +5902,7 @@ absmi(int inp)
READ_UNLOCK(pe->PRWLock);
d0 = pe->ArityOfPE;
if (d0 == 0) {
H[1] = MkAtomTerm(NameOfFunctor(pe->FunctorOfPred));
H[1] = MkAtomTerm((Atom)(pe->FunctorOfPred));
}
else {
H[d0 + 2] = AbsAppl(H);
@ -5957,12 +5956,12 @@ absmi(int inp)
PredEntry *undefpe;
undefpe = RepPredProp (p);
READ_LOCK(undefpe->PRWLock);
UndefCode = (CELL *) & (undefpe->CodeOfPred);
UndefCode = undefpe;
READ_UNLOCK(undefpe->PRWLock);
}
}
}
PREG = (yamop *)pred_entry_from_code(UndefCode)->CodeOfPred;
PREG = (yamop *)(UndefCode->CodeOfPred);
CFREG = CalculateStackGap();
CACHE_A1();
JMPNext();
@ -5987,7 +5986,7 @@ absmi(int inp)
d0 = pe->ArityOfPE;
/* save S for ModuleName */
if (d0 == 0) {
H[1] = MkAtomTerm(NameOfFunctor(pe->FunctorOfPred));
H[1] = MkAtomTerm((Atom)(pe->FunctorOfPred));
} else {
*H = (CELL) pe->FunctorOfPred;
H[d0 + 2] = AbsAppl(H);
@ -6026,16 +6025,17 @@ absmi(int inp)
}
ARG1 = (Term) AbsPair(H);
H += 2;
BEGP(pt0);
pt0 = (CELL *) (Unsigned(SpyCode) - sizeof(SMALLUNSGN));
P_before_spy = PREG;
PREG = (yamop *) PredCode(pt0);
CACHE_A1();
{
PredEntry *pt0;
pt0 = SpyCode;
P_before_spy = PREG;
PREG = (yamop *) (pt0->CodeOfPred);
CACHE_A1();
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,(PredEntry *)(PREG->u.sla.p),XREGS+1);
if (do_low_level_trace)
low_level_trace(enter_pred,pt0,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
ENDP(pt0);
}
JMPNext();
/************************************************************************\
@ -11132,6 +11132,118 @@ absmi(int inp)
ENDD(d0);
ENDOp();
BOp(p_execute, sla);
{
PredEntry *pen;
CACHE_Y_AS_ENV(Y);
CACHE_A1();
BEGD(d0);
d0 = ARG1;
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
d0 = ExecuteCallMetaCall();
}
deref_head(d0, execute_unk);
execute_nvar:
if (IsApplTerm(d0)) {
Functor f = FunctorOfTerm(d0);
if (IsExtensionFunctor(f)) {
d0 = ExecuteCallMetaCall();
goto execute_nvar;
}
pen = RepPredProp(PredPropByFunc(f, ARG2));
if (pen->PredFlags & MetaPredFlag) {
d0 = ExecuteCallMetaCall();
goto execute_nvar;
}
BEGP(pt1);
pt1 = RepAppl(d0);
BEGD(d2);
for (d2 = ArityOfFunctor(f); d2; d2--) {
#if SBA
BEGD(d1);
d1 = pt1[d2];
if (d1 == 0)
XREGS[d2] = (CELL)(pt1+d2);
else
XREGS[d2] = d1;
#else
XREGS[d2] = pt1[d2];
#endif
}
ENDD(d2);
ENDP(pt1);
} else if (IsAtomTerm(d0)) {
pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), ARG2));
} else {
d0 = ExecuteCallMetaCall();
goto execute_nvar;
}
#ifndef NO_CHECKING
check_stack(NoStackPExec, H);
#endif
/* code copied from call */
ENV = E_Y;
/* Try to preserve the environment */
E_Y = (CELL *) (((char *) Y) + PREG->u.sla.s);
CPREG =
(yamop *) NEXTOP(PREG, sla);
ALWAYS_LOOKAHEAD(pen->OpcodeOfPred);
PREG = (yamop *) pen->CodeOfPred;
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is primitives */
if (Module(pt0)) {
if (DEPTH == MkIntTerm(0))
FAIL();
else DEPTH = RESET_DEPTH();
}
} else if (Module(pt0))
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,pen,XREGS+1);
#endif /* LOW_LEVEL_TRACER */
#ifdef FROZEN_REGS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef SBA
if (E_Y > (CELL *) top_b || E_Y < H) E_Y = (CELL *) top_b;
#else
if (E_Y > (CELL *) top_b) E_Y = (CELL *) top_b;
#endif
}
#else
if (E_Y > (CELL *) B) {
E_Y = (CELL *) B;
}
#endif /* FROZEN_REGS */
WRITEBACK_Y_AS_ENV();
/* setup GB */
E_Y[E_CB] = (CELL) B;
#ifdef YAPOR
SCH_check_requests();
#endif /* YAPOR */
ALWAYS_GONext();
ALWAYS_END_PREFETCH();
BEGP(pt1);
deref_body(d0, pt1, execute_unk, execute_nvar);
d0 = ExecuteCallMetaCall();
goto execute_nvar;
ENDP(pt1);
ENDD(d0);
ENDCACHE_Y_AS_ENV();
NoStackPExec:
/* on X86 machines S will not actually be holding the pointer to pred */
SREG = (CELL *) pen;
goto NoStackCallGotS;
}
ENDBOp();
#if !USE_THREADED_CODE
default:
PREG = Error(SYSTEM_ERROR, MkIntegerTerm(opcode), "trying to execute invalid YAAM instruction %d", opcode);

168
C/adtdefs.c
View File

@ -22,6 +22,8 @@ static char SccsId[] = "%W% %G%";
#define ADTDEFS_C
#include "Yap.h"
Prop STD_PROTO(PredPropByFunc,(Functor, Term));
Prop STD_PROTO(PredPropByAtom,(Atom, Term));
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
@ -36,7 +38,7 @@ GetFunctorProp(AtomEntry *ae, unsigned int arity)
{ /* look property list of atom a for kind */
FunctorEntry *pp;
pp = RepFunctorProp(ae->PropOfAE);
pp = RepFunctorProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) &&
(!IsFunctorProperty(pp->KindOfPE) ||
pp->ArityOfFE != arity))
@ -60,9 +62,9 @@ InlinedUnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
p->NameOfFE = AbsAtom(ae);
p->ArityOfFE = arity;
p->PropsOfFE = NIL;
p->NextOfPE = ae->PropOfAE;
p->NextOfPE = ae->PropsOfAE;
INIT_RWLOCK(p->FRWLock);
ae->PropOfAE = AbsProp((PropEntry *) p);
ae->PropsOfAE = AbsProp((PropEntry *) p);
return ((Functor) p);
}
@ -95,8 +97,8 @@ MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p)
p->KindOfPE = FunctorProperty;
p->NameOfFE = ap;
p->ArityOfFE = arity;
p->NextOfPE = RepAtom(ap)->PropOfAE;
ae->PropOfAE = AbsProp((PropEntry *) p);
p->NextOfPE = RepAtom(ap)->PropsOfAE;
ae->PropsOfAE = AbsProp((PropEntry *) p);
WRITE_UNLOCK(ae->ARWLock);
}
@ -156,7 +158,7 @@ LookupAtom(char *atom)
a = AbsAtom(ae);
ae->NextOfAE = HashChain[hash].Entry;
HashChain[hash].Entry = a;
ae->PropOfAE = NIL;
ae->PropsOfAE = NIL;
if (ae->StrOfAE != atom)
strcpy(ae->StrOfAE, atom);
INIT_RWLOCK(ae->ARWLock);
@ -197,7 +199,7 @@ LookupAtomWithAddress(char *atom, AtomEntry *ae)
/* add new atom to start of chain */
ae->NextOfAE = a;
HashChain[hash].Entry = AbsAtom(ae);
ae->PropOfAE = NIL;
ae->PropsOfAE = NIL;
strcpy(ae->StrOfAE, atom);
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
@ -232,20 +234,20 @@ ReleaseAtom(Atom atom)
}
static Prop
StaticLockedGetAProp(AtomEntry *ae, PropFlags kind)
StaticGetAPropHavingLock(AtomEntry *ae, PropFlags kind)
{ /* look property list of atom a for kind */
PropEntry *pp;
pp = RepProp(ae->PropOfAE);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
pp = RepProp(pp->NextOfPE);
return (AbsProp(pp));
}
Prop
LockedGetAProp(AtomEntry *ae, PropFlags kind)
GetAPropHavingLock(AtomEntry *ae, PropFlags kind)
{ /* look property list of atom a for kind */
return (StaticLockedGetAProp(ae,kind));
return (StaticGetAPropHavingLock(ae,kind));
}
Prop
@ -255,13 +257,13 @@ GetAProp(Atom a, PropFlags kind)
Prop out;
READ_LOCK(ae->ARWLock);
out = StaticLockedGetAProp(ae, kind);
out = StaticGetAPropHavingLock(ae, kind);
READ_UNLOCK(ae->ARWLock);
return (out);
}
static Prop
UnlockedFunctorGetPredProp(Functor f)
inline static Prop
UnlockedFunctorGetPredProp(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
@ -269,13 +271,45 @@ UnlockedFunctorGetPredProp(Functor f)
PredEntry *p;
p = RepPredProp(p0 = fe->PropsOfFE);
while (p0 && (p->KindOfPE != PEProp ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
while (p0 && (/* p->KindOfPE != PEProp || only preds in here */
(p->ModuleOfPred != cur_mod && p->ModuleOfPred)))
p = RepPredProp(p0 = p->NextOfPE);
READ_UNLOCK(fe->FRWLock);
return (p0);
}
inline static Prop
GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
p0 = ae->PropsOfAE;
while (p0) {
PredEntry *pe = RepPredProp(p0);
if ( pe->KindOfPE == PEProp &&
(pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
return(p0);
}
p0 = pe->NextOfPE;
}
return(NIL);
}
Prop
GetPredPropByAtom(Atom at, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(at);
READ_LOCK(ae->ARWLock);
p0 = GetPredPropByAtomHavingLock(ae, cur_mod);
READ_UNLOCK(ae->ARWLock);
return(p0);
}
Prop
GetPredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; */
@ -284,38 +318,43 @@ GetPredProp(Atom ap, unsigned int arity)
AtomEntry *ae = RepAtom(ap);
Functor f;
if (arity == 0)
return(GetPredPropByAtom(ap, *CurrentModulePtr));
WRITE_LOCK(ae->ARWLock);
f = InlinedUnlockedMkFunctor(ae, arity);
WRITE_UNLOCK(ae->FRWLock);
READ_LOCK(f->ARWLock);
p0 = UnlockedFunctorGetPredProp(f);
p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr);
READ_UNLOCK(f->FRWLock);
return (p0);
}
Prop
GetPredPropByFunc(Functor f)
GetPredPropByFunc(Functor f, Term t)
/* get predicate entry for ap/arity; */
{
Prop p0;
READ_LOCK(f->ARWLock);
p0 = UnlockedFunctorGetPredProp(f);
p0 = UnlockedFunctorGetPredProp(f, t);
READ_UNLOCK(f->FRWLock);
return (p0);
}
Prop
LockedGetPredProp(Atom ap, unsigned int arity)
GetPredPropHavingLock(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
Functor f;
if (arity == 0) {
GetPredPropByAtomHavingLock(ae, *CurrentModulePtr);
}
f = InlinedUnlockedMkFunctor(ae, arity);
READ_LOCK(f->ARWLock);
p0 = UnlockedFunctorGetPredProp(f);
p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr);
READ_UNLOCK(f->FRWLock);
return (p0);
}
@ -329,7 +368,7 @@ GetExpProp(Atom at, unsigned int arity)
ExpEntry *p;
READ_LOCK(ae->ARWLock);
p = RepExpProp(p0 = ae->PropOfAE);
p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
READ_UNLOCK(ae->ARWLock);
@ -338,37 +377,24 @@ GetExpProp(Atom at, unsigned int arity)
/* get expression entry for at/arity, at is already locked; */
Prop
LockedGetExpProp(AtomEntry *ae, unsigned int arity)
GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
{
Prop p0;
ExpEntry *p;
p = RepExpProp(p0 = ae->PropOfAE);
p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
return (p0);
}
Prop
PredPropByFunc(Functor f)
/* get predicate entry for ap/arity; create it if neccessary. */
NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
{
Prop p0;
FunctorEntry *fe = (FunctorEntry *)f;
PredEntry *p;
PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p));
Int m = IntOfTerm(cur_mod);
WRITE_LOCK(fe->FRWLock);
p = RepPredProp(p0 = fe->PropsOfFE);
while (p0 && (p->KindOfPE != 0 ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
p = RepPredProp(p0 = p->NextOfPE);
if (p0 != NIL) {
WRITE_UNLOCK(f->FRWLock);
return (p0);
}
p = (PredEntry *) AllocAtomSpace(sizeof(*p));
INIT_RWLOCK(p->PRWLock);
p->KindOfPE = PEProp;
p->ArityOfPE = fe->ArityOfFE;
@ -378,9 +404,12 @@ PredPropByFunc(Functor f)
p->OwnerFile = AtomNil;
p->OpcodeOfPred = UNDEF_OPCODE;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
p->ModuleOfPred = CurrentModule;
p->NextPredOfModule = ModulePred[CurrentModule];
ModulePred[CurrentModule] = p;
if (m == 0)
p->ModuleOfPred = 0;
else
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[m];
ModulePred[m] = p;
INIT_LOCK(p->StatisticsForPred.lock);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
@ -391,22 +420,63 @@ PredPropByFunc(Functor f)
/* careful that they don't cross MkFunctor */
p->NextOfPE = fe->PropsOfFE;
fe->PropsOfFE = p0 = AbsPredProp(p);
p->FunctorOfPred = f;
p->FunctorOfPred = (Functor)fe;
WRITE_UNLOCK(fe->FRWLock);
return (p0);
}
Prop
NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
{
Prop p0;
PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p));
int m = IntOfTerm(cur_mod);
INIT_RWLOCK(p->PRWLock);
p->KindOfPE = PEProp;
p->ArityOfPE = 0;
p->FirstClause = p->LastClause = NIL;
p->PredFlags = 0L;
p->StateOfPred = 0;
p->OwnerFile = AtomNil;
p->OpcodeOfPred = UNDEF_OPCODE;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
if (!m)
p->ModuleOfPred = 0;
else
p->ModuleOfPred = cur_mod;
p->NextPredOfModule = ModulePred[m];
ModulePred[m] = p;
INIT_LOCK(p->StatisticsForPred.lock);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
p->StatisticsForPred.NOfRetries = 0;
#ifdef TABLING
p->TableOfPred = NULL;
#endif /* TABLING */
/* careful that they don't cross MkFunctor */
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = p0 = AbsPredProp(p);
p->FunctorOfPred = (Functor)AbsAtom(ae);
WRITE_UNLOCK(ae->ARWLock);
return (p0);
}
Prop
PredProp(Atom ap, unsigned int arity)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
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);
p0 = PredPropByFunc(f, *CurrentModulePtr);
WRITE_UNLOCK(ae->ARWLock);
return(p0);
}
@ -433,15 +503,15 @@ PutValue(Atom a, Term v)
ValEntry *p;
WRITE_LOCK(ae->ARWLock);
p0 = LockedGetAProp(ae, ValProperty);
p0 = GetAPropHavingLock(ae, ValProperty);
if (p0 != NIL) {
p = RepValProp(p0);
WRITE_LOCK(p->VRWLock);
WRITE_UNLOCK(ae->ARWLock);
} else {
p = (ValEntry *) AllocAtomSpace(sizeof(ValEntry));
p->NextOfPE = RepAtom(a)->PropOfAE;
RepAtom(a)->PropOfAE = AbsValProp(p);
p->NextOfPE = RepAtom(a)->PropsOfAE;
RepAtom(a)->PropsOfAE = AbsValProp(p);
p->KindOfPE = ValProperty;
/* take care that the lock for the property will be inited even
if someone else searches for the property */

14
C/amasm.c
View File

@ -753,7 +753,7 @@ a_p(op_numbers opcode)
code_p->u.sdl.s =
emit_count(-Signed(RealEnvSize) - CELLSIZE * cpc->rnd2);
code_p->u.sdl.d =
emit_a((CELL) RepPredProp(fe)->CodeOfPred);
emit_a((CELL) RepPredProp(fe)->TrueCodeOfPred);
code_p->u.sdl.l =
emit_a(Unsigned(code_addr) + label_offset[comit_lab]);
code_p->u.sdl.p =
@ -765,14 +765,18 @@ a_p(op_numbers opcode)
}
else {
if (pass_no) {
if (Flags & UserCPredFlag)
if (Flags & UserCPredFlag) {
code_p->opc = emit_op(_call_usercpred);
else
code_p->opc = emit_op(_call_cpred);
} else {
if (RepPredProp(fe)->FunctorOfPred == FunctorExecuteInMod)
code_p->opc = emit_op(_p_execute);
else
code_p->opc = emit_op(_call_cpred);
}
code_p->u.sla.s = emit_count(-Signed(RealEnvSize) - CELLSIZE
* (cpc->rnd2));
code_p->u.sla.l = emit_a((CELL)
RepPredProp(fe)->CodeOfPred);
RepPredProp(fe)->TrueCodeOfPred);
code_p->u.sla.p = emit_a((CELL)
RepPredProp(fe));
if (cpc->rnd2)

8
C/arith0.c
View File

@ -190,7 +190,7 @@ InitConstExps(void)
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
AtomEntry *ae = RepAtom(LookupAtom(InitConstTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if (LockedGetExpProp(ae, 0)) {
if (GetExpPropHavingLock(ae, 0)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
@ -199,8 +199,8 @@ InitConstExps(void)
p->ArityOfEE = 0;
p->ENoOfEE = 0;
p->FOfEE.constant = InitConstTab[i].f;
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsExpProp(p);
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
}
@ -216,7 +216,7 @@ ReInitConstExps(void)
AtomEntry *ae = RepAtom(FullLookupAtom(InitConstTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if ((p = LockedGetExpProp(ae, 0)) == NULL) {
if ((p = GetExpPropHavingLock(ae, 0)) == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return(FALSE);
}

8
C/arith1.c
View File

@ -2007,7 +2007,7 @@ InitUnaryExps(void)
for (i = 0; i < sizeof(InitUnTab)/sizeof(InitUnEntry); ++i) {
AtomEntry *ae = RepAtom(LookupAtom(InitUnTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if (LockedGetExpProp(ae, 1)) {
if (GetExpPropHavingLock(ae, 1)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
@ -2016,8 +2016,8 @@ InitUnaryExps(void)
p->ArityOfEE = 1;
p->ENoOfEE = 1;
p->FOfEE.unary = InitUnTab[i].f;
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsExpProp(p);
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
InitCPred("is", 3, p_unary_is, TestPredFlag | SafePredFlag);
@ -2034,7 +2034,7 @@ ReInitUnaryExps(void)
AtomEntry *ae = RepAtom(FullLookupAtom(InitUnTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if ((p = LockedGetExpProp(ae, 1)) == NULL) {
if ((p = GetExpPropHavingLock(ae, 1)) == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return(FALSE);
}

8
C/arith2.c
View File

@ -1720,7 +1720,7 @@ InitBinaryExps(void)
for (i = 0; i < sizeof(InitBinTab)/sizeof(InitBinEntry); ++i) {
AtomEntry *ae = RepAtom(LookupAtom(InitBinTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if (LockedGetExpProp(ae, 2)) {
if (GetExpPropHavingLock(ae, 2)) {
WRITE_UNLOCK(ae->ARWLock);
break;
}
@ -1729,8 +1729,8 @@ InitBinaryExps(void)
p->ArityOfEE = 2;
p->ENoOfEE = 2;
p->FOfEE.binary = InitBinTab[i].f;
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsExpProp(p);
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsExpProp(p);
WRITE_UNLOCK(ae->ARWLock);
}
InitCPred("is", 4, p_binary_is, TestPredFlag | SafePredFlag);
@ -1747,7 +1747,7 @@ ReInitBinaryExps(void)
AtomEntry *ae = RepAtom(FullLookupAtom(InitBinTab[i].OpName));
WRITE_LOCK(ae->ARWLock);
if ((p = LockedGetExpProp(ae, 2)) == NULL) {
if ((p = GetExpPropHavingLock(ae, 2)) == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return(FALSE);
}

28
C/arrays.c
View File

@ -149,7 +149,7 @@ AccessNamedArray(Atom a, Int indx)
ArrayEntry *pp;
READ_LOCK(ae->ARWLock);
pp = RepArrayProp(ae->PropOfAE);
pp = RepArrayProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepArrayProp(pp->NextOfPE);
READ_UNLOCK(ae->ARWLock);
@ -393,9 +393,9 @@ CreateNamedArray(PropEntry * pp, Int dim, AtomEntry *ae)
p = (ArrayEntry *) AllocAtomSpace(sizeof(*p));
p->KindOfPE = ArrayProperty;
p->NextOfPE = ae->PropOfAE;
p->NextOfPE = ae->PropsOfAE;
INIT_RWLOCK(p->ArRWLock);
ae->PropOfAE = AbsArrayProp(p);
ae->PropsOfAE = AbsArrayProp(p);
InitNamedArray(p, dim);
@ -446,13 +446,13 @@ CreateStaticArray(AtomEntry *ae, Int dim, static_array_types type, CODEADDR star
if (EndOfPAEntr(p)) {
p = (StaticArrayEntry *) AllocAtomSpace(sizeof(*p));
p->KindOfPE = ArrayProperty;
p->NextOfPE = ae->PropOfAE;
p->NextOfPE = ae->PropsOfAE;
INIT_RWLOCK(p->ArRWLock);
WRITE_LOCK(p->ArRWLock);
}
p->ArrayEArity = -dim;
p->ArrayType = type;
ae->PropOfAE = AbsArrayProp((ArrayEntry *)p);
ae->PropsOfAE = AbsArrayProp((ArrayEntry *)p);
WRITE_UNLOCK(ae->ARWLock);
if (start_addr == NULL) {
int i;
@ -578,7 +578,7 @@ ClearNamedArray(CELL *pt0)
AtomEntry *ae = (AtomEntry *)RepAppl(pt0[-1]);
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropOfAE);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) {
pp = RepProp(pp->NextOfPE);
}
@ -649,7 +649,7 @@ p_create_array(void)
PropEntry *pp;
WRITE_LOCK(ae->ARWLock);
pp = RepProp(ae->PropOfAE);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepProp(pp->NextOfPE);
if (EndOfPAEntr(pp)) {
@ -753,7 +753,7 @@ p_create_static_array(void)
StaticArrayEntry *pp;
WRITE_LOCK(ae->ARWLock);
pp = RepStaticArrayProp(ae->PropOfAE);
pp = RepStaticArrayProp(ae->PropsOfAE);
WRITE_LOCK(pp->ArRWLock);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepStaticArrayProp(pp->NextOfPE);
@ -786,7 +786,7 @@ p_has_static_array(void)
StaticArrayEntry *pp;
READ_LOCK(ae->ARWLock);
pp = RepStaticArrayProp(ae->PropOfAE);
pp = RepStaticArrayProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepStaticArrayProp(pp->NextOfPE);
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
@ -833,7 +833,7 @@ p_resize_static_array(void)
else if (IsAtomTerm(t)) {
/* resize a named array */
Atom a = AtomOfTerm(t);
StaticArrayEntry *pp = RepStaticArrayProp(RepAtom(a)->PropOfAE);
StaticArrayEntry *pp = RepStaticArrayProp(RepAtom(a)->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepStaticArrayProp(pp->NextOfPE);
@ -868,7 +868,7 @@ p_close_static_array(void)
PropEntry *pp;
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropOfAE);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepProp(pp->NextOfPE);
READ_UNLOCK(ae->ARWLock);
@ -1101,7 +1101,7 @@ p_create_mmapped_array(void)
StaticArrayEntry *pp;
WRITE_LOCK(ae->ARWLock);
pp = RepStaticArrayProp(ae->PropOfAE);
pp = RepStaticArrayProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepStaticArrayProp(pp->NextOfPE);
if (!EndOfPAEntr(pp)) {
@ -1361,7 +1361,7 @@ p_assign_static(void)
AtomEntry *ae = RepAtom(AtomOfTerm(t1));
READ_LOCK(ae->ARWLock);
ptr = RepStaticArrayProp(ae->PropOfAE);
ptr = RepStaticArrayProp(ae->PropsOfAE);
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
ptr = RepStaticArrayProp(ptr->NextOfPE);
READ_UNLOCK(ae->ARWLock);
@ -1611,7 +1611,7 @@ SetDBForThrow(Term Message)
StaticArrayEntry *ptr;
DBRef ref;
READ_LOCK(ae->ARWLock);
ptr = RepStaticArrayProp(ae->PropOfAE);
ptr = RepStaticArrayProp(ae->PropsOfAE);
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
ptr = RepStaticArrayProp(ptr->NextOfPE);
READ_UNLOCK(ae->ARWLock);

8
C/bb.c
View File

@ -32,7 +32,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */
BBProp p;
WRITE_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropOfAE);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);
@ -44,8 +44,8 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
return(NULL);
}
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsBBProp(p);
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsBBProp(p);
p->ModuleOfBB = CurrentModule;
p->Element = NULL;
p->KeyOfBB = AbsAtom(ae);
@ -111,7 +111,7 @@ GetBBProp(AtomEntry *ae) /* get BBentry for at; */
BBProp p;
READ_LOCK(ae->ARWLock);
p = RepBBProp(p0 = ae->PropOfAE);
p = RepBBProp(p0 = ae->PropsOfAE);
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
(p->ModuleOfBB != CurrentModule))) {
p = RepBBProp(p0 = p->NextOfPE);

145
C/cdmgr.c
View File

@ -299,7 +299,7 @@ RemoveIndexation(PredEntry *ap)
Error_Term = TermNil;
Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
if (Arity == 0)
sprintf(ErrorMessage, "predicate %s is in use", RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE);
sprintf(ErrorMessage, "predicate %s is in use", RepAtom((Atom)(ap->FunctorOfPred))->StrOfAE);
else
sprintf(ErrorMessage,
#if SHORT_INTS
@ -796,6 +796,8 @@ addclause(Term t, CODEADDR cp, int mode)
Int Arity;
PredEntry *p;
int spy_flag = FALSE;
SMALLUNSGN mod = CurrentModule;
if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
t = ArgOfTerm(1, t);
@ -810,39 +812,9 @@ addclause(Term t, CODEADDR cp, int mode)
p = RepPredProp(PredProp(AbsAtom(ap), Arity));
PutValue(AtomAbol, TermNil);
WRITE_LOCK(p->PRWLock);
if (p->PredFlags & StandardPredFlag) {
Term t, ti[2];
WRITE_UNLOCK(p->PRWLock);
ti[0] = MkAtomTerm(AbsAtom(ap));
ti[1] = MkIntegerTerm(Arity);
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
ErrorMessage = ErrorSay;
Error_Term = t;
Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
#ifdef HAVE_SNPRINTF
if (Arity == 0)
snprintf(ErrorMessage, 256, "system predicate %s", ap->StrOfAE);
else
snprintf(ErrorMessage, 256,
#if SHORT_INTS
"system predicate %s/%ld",
#else
"system predicate %s/%d",
#endif
ap->StrOfAE, Arity);
#else
if (Arity == 0)
sprintf(ErrorMessage, "system predicate %s", ap->StrOfAE);
else
sprintf(ErrorMessage,
#if SHORT_INTS
"system predicate %s/%ld",
#else
"system predicate %s/%d",
#endif
ap->StrOfAE, Arity);
#endif
/* we are redefining a prolog module predicate */
if (mod != 0 && p->ModuleOfPred == 0) {
addcl_permission_error(ap, Arity);
return;
}
/* The only problem we have now is when we need to throw away
@ -1183,7 +1155,7 @@ p_purge_clauses(void)
pred = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun));
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
} else
return (FALSE);
WRITE_LOCK(pred->PRWLock);
@ -1233,7 +1205,7 @@ p_setspy(void)
at = FullLookupAtom("$spy");
pred = RepPredProp(PredProp(at, 1));
SpyCode = CellPtr(&(pred->CodeOfPred));
SpyCode = pred;
t = Deref(ARG1);
if (IsVarTerm(t))
return (FALSE);
@ -1242,7 +1214,7 @@ p_setspy(void)
pred = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun));
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
} else {
return (FALSE);
}
@ -1290,7 +1262,7 @@ p_rmspy(void)
pred = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pred = RepPredProp(PredPropByFunc(fun));
pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
} else
return (FALSE);
WRITE_LOCK(pred->PRWLock);
@ -1334,7 +1306,7 @@ p_number_of_clauses(void)
pe = PredProp(a, 0);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
@ -1372,7 +1344,7 @@ p_find_dynamic(void)
pe = PredProp(a, 0);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
@ -1427,7 +1399,7 @@ p_next_dynamic(void)
pe = PredProp(a, 0);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
pe = PredPropByFunc(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE);
q = RepPredProp(pe)->FirstClause;
@ -1462,7 +1434,7 @@ p_in_use(void)
pe = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun));
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
} else
return (FALSE);
READ_LOCK(pe->PRWLock);
@ -1576,7 +1548,7 @@ p_is_dynamic(void)
pe = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun));
pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr));
} else
return (FALSE);
if (pe == NIL)
@ -1609,7 +1581,13 @@ p_set_pred_module(void)
if (pe == NIL)
return (FALSE);
WRITE_LOCK(pe->PRWLock);
pe->ModuleOfPred = LookupModule(Deref(ARG2));
{
SMALLUNSGN mod = LookupModule(Deref(ARG2));
if (mod)
pe->ModuleOfPred = MkIntTerm(mod);
else
pe->ModuleOfPred = 0;
}
WRITE_UNLOCK(pe->PRWLock);
return(TRUE);
}
@ -1619,34 +1597,37 @@ p_undefined(void)
{ /* '$undefined'(P) */
PredEntry *pe;
Term t;
SMALLUNSGN omod = CurrentModule;
Term tmod = *CurrentModulePtr;
t = Deref(ARG1);
restart_undefined:
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
*CurrentModulePtr = MkIntTerm(omod);
return(FALSE);
}
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(GetPredProp(at,0));
pe = RepPredProp(GetPredPropByAtom(at,tmod));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t);
if (funt == FunctorModule) {
Term mod = ArgOfTerm(1, t);
if (!IsVarTerm(mod) ) {
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
t = ArgOfTerm(2, t);
goto restart_undefined;
if (IsVarTerm(mod) ) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
return(FALSE);
}
if (!IsAtomTerm(mod) ) {
Error(TYPE_ERROR_ATOM,ARG1,"undefined/1");
return(FALSE);
}
tmod = MkIntTerm(LookupModule(mod));
t = ArgOfTerm(2, t);
goto restart_undefined;
}
pe = RepPredProp(GetPredPropByFunc(funt));
pe = RepPredProp(GetPredPropByFunc(funt, tmod));
} else {
*CurrentModulePtr = MkIntTerm(omod);
return (FALSE);
}
*CurrentModulePtr = MkIntTerm(omod);
if (pe == RepPredProp(NIL))
return (TRUE);
READ_LOCK(pe->PRWLock);
@ -1679,7 +1660,7 @@ p_kill_dynamic(void)
pe = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(funt));
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
} else
return (FALSE);
if (pe == NIL)
@ -1880,7 +1861,7 @@ p_search_for_static_predicate_in_use(void)
pe = RepPredProp(PredProp(at, 0));
} else if (IsApplTerm(t)) {
Functor funt = FunctorOfTerm(ARG1);
pe = RepPredProp(PredPropByFunc(funt));
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
} else
return(FALSE);
/* do nothing if we are in consult */
@ -1949,7 +1930,7 @@ NextPred(PredEntry *pp, AtomEntry *ae)
static Int
check_code_in_atom(AtomEntry *ae, CODEADDR codeptr, Int *parity, SMALLUNSGN *pmodule) {
PredEntry *pp;
for (pp = NextPred(RepPredProp(ae->PropOfAE),ae);
for (pp = NextPred(RepPredProp(ae->PropsOfAE),ae);
!EndOfPAEntr(pp);
pp = NextPred(RepPredProp(pp->NextOfPE),ae)) {
CODEADDR clcode, cl;
@ -1963,7 +1944,10 @@ check_code_in_atom(AtomEntry *ae, CODEADDR codeptr, Int *parity, SMALLUNSGN *pmo
codeptr > pp->TrueCodeOfPred &&
codeptr <= pp->TrueCodeOfPred + SizeOfBlock(pp->TrueCodeOfPred)) {
*parity = pp->ArityOfPE;
*pmodule = pp->ModuleOfPred;
if (pp->ModuleOfPred == 0)
*pmodule = pp->ModuleOfPred;
else
*pmodule = IntOfTerm(pp->ModuleOfPred);
READ_UNLOCK(pp->PRWLock);
return(-1);
}
@ -1972,7 +1956,10 @@ check_code_in_atom(AtomEntry *ae, CODEADDR codeptr, Int *parity, SMALLUNSGN *pmo
if (codeptr > cl && codeptr <= cl + SizeOfBlock(cl)) {
/* we found it */
*parity = pp->ArityOfPE;
*pmodule = pp->ModuleOfPred;
if (pp->ModuleOfPred == 0)
*pmodule = pp->ModuleOfPred;
else
*pmodule = IntOfTerm(pp->ModuleOfPred);
READ_UNLOCK(pp->PRWLock);
return(i);
}
@ -2137,6 +2124,40 @@ p_parent_pred(void)
unify(ARG3, MkIntTerm(arity)));
}
static Int /* $parent_pred(Module, Name, Arity) */
p_system_pred(void)
{
PredEntry *pe;
Term mod = *CurrentModulePtr;
Term t1 = Deref(ARG1);
restart:
if (IsVarTerm(t1))
return (FALSE);
if (IsAtomTerm(t1)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod));
} else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1);
if (funt == FunctorModule) {
Term nmod = ArgOfTerm(1, t1);
if (IsVarTerm(nmod)) {
Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1");
return(FALSE);
}
if (!IsAtomTerm(nmod)) {
Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1");
return(FALSE);
}
mod = MkIntTerm(LookupModule(nmod));
t1 = ArgOfTerm(2, t1);
goto restart;
}
pe = RepPredProp(PredPropByFunc(funt, mod));
} else
return (FALSE);
return(pe->ModuleOfPred == 0);
}
void
InitCdMgr(void)
{
@ -2157,7 +2178,7 @@ InitCdMgr(void)
InitCPred("$number_of_clauses", 2, p_number_of_clauses, SafePredFlag|SyncPredFlag);
InitCPred("$find_dynamic", 3, p_find_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$next_dynamic", 3, p_next_dynamic, SafePredFlag|SyncPredFlag);
InitCPred("$undefined", 1, p_undefined, SafePredFlag);
InitCPred("$undefined", 1, p_undefined, SafePredFlag|TestPredFlag);
InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag);
InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag);
InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag);
@ -2174,4 +2195,6 @@ InitCdMgr(void)
InitCPred("$toggle_static_predicates_in_use", 0, p_toggle_static_predicates_in_use, SafePredFlag|SyncPredFlag);
InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag);
InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag);
InitCPred("$system_predicate", 1, p_system_pred, SafePredFlag);
}

9
C/compiler.c
View File

@ -1095,7 +1095,7 @@ c_functor(Term Goal)
c_var(t3,f_flag,(unsigned int)_functor);
} else {
Functor f = FunctorOfTerm(Goal);
Prop p0 = PredPropByFunc(f);
Prop p0 = PredPropByFunc(f, *CurrentModulePtr);
if (profiling)
emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero);
c_args(Goal);
@ -1260,7 +1260,7 @@ c_goal(Term Goal)
}
else {
f = FunctorOfTerm(Goal);
p = RepPredProp(p0 = PredPropByFunc(f));
p = RepPredProp(p0 = PredPropByFunc(f, *CurrentModulePtr));
if (f == FunctorOr) {
CELL l = ++labelno;
CELL m = ++labelno;
@ -1451,8 +1451,7 @@ c_goal(Term Goal)
c_goal(ArgOfTerm(2, Goal));
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorEq) {
} else if (f == FunctorEq) {
if (profiling)
emit(enter_profiling_op, (CELL)p, Zero);
c_eq(ArgOfTerm(1, Goal), ArgOfTerm(2, Goal));
@ -2855,7 +2854,7 @@ cclause(Term inp_clause, int NOfArgs)
Atom ap = AtomOfTerm(head);
CurrentPred = RepPredProp(PredProp(ap, 0));
} else {
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head)));
CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),*CurrentModulePtr));
}
/* insert extra instructions to count calls */
READ_LOCK(CurrentPred->PRWLock);

30
C/computils.c
View File

@ -82,9 +82,9 @@ is_a_test_pred (Term arg)
else if (IsApplTerm (arg))
{
Functor f = FunctorOfTerm (arg);
if (RepPredProp (PredPropByFunc (f)) == NULL)
if (RepPredProp (PredPropByFunc (f, *CurrentModulePtr)) == NULL)
return (FALSE);
return (RepPredProp (PredPropByFunc (f))->PredFlags & TestPredFlag);
return (RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->PredFlags & TestPredFlag);
}
else
return (FALSE);
@ -297,22 +297,36 @@ ShowOp (f)
{
PredEntry *p = RepPredProp ((Prop) arg);
Functor f = p->FunctorOfPred;
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
UInt arity = p->ArityOfPE;
SMALLUNSGN mod = 0;
if (p->ModuleOfPred) mod = IntOfTerm(p->ModuleOfPred);
plwrite (ModuleName[mod], DebugPutc, 0);
DebugPutc (c_output_stream,':');
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
if (arity == 0)
plwrite (MkAtomTerm ((Atom)f), DebugPutc, 0);
else
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
plwrite (MkIntTerm (arity), DebugPutc, 0);
}
break;
case 'P':
{
PredEntry *p = RepPredProp((Prop) rn);
Functor f = p->FunctorOfPred;
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
UInt arity = p->ArityOfPE;
SMALLUNSGN mod = 0;
if (p->ModuleOfPred) mod = IntOfTerm(p->ModuleOfPred);
plwrite (ModuleName[mod], DebugPutc, 0);
DebugPutc (c_output_stream,':');
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
if (arity == 0)
plwrite (MkAtomTerm ((Atom)f), DebugPutc, 0);
else
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
DebugPutc (c_output_stream,'/');
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
plwrite (MkIntTerm (arity), DebugPutc, 0);
}
break;
case 'f':

2
C/corout.c
View File

@ -1159,7 +1159,7 @@ void InitCoroutPreds(void)
#endif /* FIXED_STACKS */
at = LookupAtom("$wake_up_goal");
pred = RepPredProp(PredProp(at, 2));
WakeUpCode = (CELL *) & (pred->CodeOfPred);
WakeUpCode = (CELL *) pred;
InitAttVarPreds();
#endif /* COROUTINING */
InitCPred("$read_svar_list", 2, p_read_svar_list, SafePredFlag);

22
C/dbase.c
View File

@ -392,12 +392,12 @@ int DBTrailOverflow(void)
/* get DB entry for ap/arity; */
static Prop
LockedFindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity)
FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity)
{
Prop p0;
DBProp p;
p = RepDBProp(p0 = ae->PropOfAE);
p = RepDBProp(p0 = ae->PropsOfAE);
while (p0 && (((p->KindOfPE & ~0x1) != (CodeDB|DBProperty)) ||
(p->ArityOfDB != arity) ||
((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != DBModule ))) {
@ -414,7 +414,7 @@ FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity)
Prop out;
READ_LOCK(ae->ARWLock);
out = LockedFindDBProp(ae, CodeDB, arity);
out = FindDBPropHavingLock(ae, CodeDB, arity);
READ_UNLOCK(ae->ARWLock);
return(out);
}
@ -2106,11 +2106,11 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
AtomEntry *ae = RepAtom(At);
WRITE_LOCK(ae->ARWLock);
if (EndOfPAEntr(p = RepDBProp(LockedFindDBProp(ae, flag, arity)))) {
if (EndOfPAEntr(p = RepDBProp(FindDBPropHavingLock(ae, flag, arity)))) {
/* create a new DBProp */
int OLD_UPDATE_MODE = UPDATE_MODE;
if (flag & MkCode) {
PredEntry *pp = RepPredProp(LockedGetPredProp(At, arity));
PredEntry *pp = RepPredProp(GetPredPropHavingLock(At, arity));
if (!EndOfPAEntr(pp)) {
READ_LOCK(pp->PRWLock);
if(pp->PredFlags & LogUpdatePredFlag)
@ -2146,8 +2146,8 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg)
p->FunctorOfDB = (Functor) At;
else
p->FunctorOfDB = UnlockedMkFunctor(ae,arity);
p->NextOfPE = ae->PropOfAE;
ae->PropOfAE = AbsDBProp(p);
p->NextOfPE = ae->PropsOfAE;
ae->PropsOfAE = AbsDBProp(p);
}
WRITE_UNLOCK(ae->ARWLock);
return(p);
@ -3123,7 +3123,7 @@ MyEraseClause(Clause *clau)
Atom name = (Atom) father->FunctorOfDB;
pred = RepPredProp(PredProp(name, 0));
} else {
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB));
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr));
}
DBModule = father->ModuleOfDB;
WRITE_LOCK(pred->PRWLock);
@ -3317,7 +3317,7 @@ PrepareToEraseClause(Clause *clau, DBRef dbr)
Atom name = (Atom) father->FunctorOfDB;
pred = RepPredProp(PredProp(name, 0));
} else {
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB));
pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr));
}
DBModule = father->ModuleOfDB;
WRITE_LOCK(pred->PRWLock);
@ -3598,7 +3598,7 @@ init_current_key(void)
READ_UNLOCK(HashChain[i].AERWLock);
}
READ_LOCK(RepAtom(a)->ARWLock);
pp = NextDBProp(RepProp(RepAtom(a)->PropOfAE));
pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE));
READ_UNLOCK(RepAtom(a)->ARWLock);
EXTRA_CBACK_ARG(2,3) = MkAtomTerm(a);
EXTRA_CBACK_ARG(2,2) = MkIntTerm(i);
@ -3674,7 +3674,7 @@ cont_current_key(void)
}
}
READ_LOCK(RepAtom(a)->ARWLock);
if (!EndOfPAEntr(pp = NextDBProp(RepProp(RepAtom(a)->PropOfAE))))
if (!EndOfPAEntr(pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE))))
EXTRA_CBACK_ARG(2,3) = (CELL) MkAtomTerm(a);
READ_UNLOCK(RepAtom(a)->ARWLock);
}

8
C/errors.c
View File

@ -107,13 +107,15 @@ DumpActiveGoals (void)
if (pe->PredFlags & (CompiledPredFlag | DynamicPredFlag | FastPredFlag))
{
Functor f;
SMALLUNSGN mod = 0;
f = pe->FunctorOfPred;
if (pe->KindOfPE && hidden (NameOfFunctor (f)))
goto next;
if (first++ == 1)
YP_fprintf(YP_stderr,"Active ancestors:\n");
plwrite (ModuleName[pe->ModuleOfPred], DebugPutc, 0);
if (pe->ModuleOfPred) mod = IntOfTerm(pe->ModuleOfPred);
plwrite (ModuleName[mod], DebugPutc, 0);
DebugPutc (c_output_stream,':');
if (pe->ArityOfPE == 0) {
plwrite (MkAtomTerm ((Atom)f), DebugPutc, 0);
@ -161,9 +163,11 @@ DumpActiveGoals (void)
READ_LOCK(pe->PRWLock);
{
Functor f;
SMALLUNSGN mod = 0;
f = pe->FunctorOfPred;
plwrite (ModuleName[pe->ModuleOfPred], DebugPutc, 0);
if (pe->ModuleOfPred) mod = IntOfTerm(pe->ModuleOfPred);
plwrite (ModuleName[mod], DebugPutc, 0);
DebugPutc (c_output_stream,':');
if (pe->ArityOfPE == 0) {
plwrite (MkAtomTerm (NameOfFunctor(f)), DebugPutc, 0);

596
C/exec.c
View File

@ -21,15 +21,22 @@ static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
#include "absmi.h"
#include "yapio.h"
STATIC_PROTO(Int CallProlog, (PredEntry *, unsigned int, Int));
STATIC_PROTO(Int CallPredicate, (PredEntry *, choiceptr));
STATIC_PROTO(Int CallClause, (PredEntry *, unsigned int, Int));
STATIC_PROTO(Int p_save_cp, (void));
STATIC_PROTO(Int p_execute, (void));
STATIC_PROTO(Int p_execute0, (void));
STATIC_PROTO(Int p_at_execute, (void));
static Int
FastCallProlog(PredEntry *pen) {
static Term
current_cp_as_integer(void)
{
return(MkIntTerm(LCL0-(CELL *)B));
}
static inline Int
CallPredicate(PredEntry *pen, choiceptr cut_pt) {
WRITE_LOCK(pen->PRWLock);
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
if (pen->ModuleOfPred) {
@ -44,127 +51,123 @@ FastCallProlog(PredEntry *pen) {
if (do_low_level_trace)
low_level_trace(enter_pred,pen,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
if (pen->PredFlags & ProfiledPredFlag)
pen->StatisticsForPred.NOfEntries++;
CP = P;
P = (yamop *)(pen->CodeOfPred);
WRITE_UNLOCK(pen->PRWLock);
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL) B;
return (Unsigned(&(pen->StateOfPred)));
YENV[E_CB] = (CELL) cut_pt;
return (TRUE);
}
inline static Int
CallMetaCall(void) {
ARG2 = current_cp_as_integer(); /* p_save_cp */
ARG3 = ARG1;
WRITE_LOCK(PredMetaCall->PRWLock);
return (CallPredicate(PredMetaCall, B));
}
Term
ExecuteCallMetaCall(void) {
Term ts[3];
ts[0] = ARG1;
ts[1] = current_cp_as_integer(); /* p_save_cp */
ts[2] = ARG1;
return(MkApplTerm(PredMetaCall->FunctorOfPred,3,ts));
}
static Int
CallError(yap_error_number err)
{
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCall());
} else {
Error(err, ARG1, "call/1");
return(FALSE);
}
}
static Int
CallProlog(PredEntry *pen, unsigned int arity, Int position)
CallClause(PredEntry *pen, unsigned int arity, Int position)
{
CELL flags;
if (position == -1) return(CallPredicate(pen, B));
WRITE_LOCK(pen->PRWLock);
flags = pen->PredFlags;
if ((flags & (CompiledPredFlag | DynamicPredFlag)) ||
pen->OpcodeOfPred == UNDEF_OPCODE) {
if (position == -1 ||
pen->OpcodeOfPred == UNDEF_OPCODE) {
return(FastCallProlog(pen));
} else {
CODEADDR q;
CODEADDR q;
#ifdef DEPTH_LIMIT
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
if (pen->ModuleOfPred) {
if (DEPTH == MkIntTerm(0))
return(FALSE);
else DEPTH = RESET_DEPTH();
}
} else if (pen->ModuleOfPred)
DEPTH -= MkIntConstant(2);
if (DEPTH <= MkIntTerm(1)) {/* I assume Module==0 is prolog */
if (pen->ModuleOfPred) {
if (DEPTH == MkIntTerm(0))
return(FALSE);
else DEPTH = RESET_DEPTH();
}
} else if (pen->ModuleOfPred)
DEPTH -= MkIntConstant(2);
#endif /* DEPTH_LIMIT */
#ifdef LOW_LEVEL_TRACER
if (do_low_level_trace)
low_level_trace(enter_pred,pen,XREGS+1);
if (do_low_level_trace)
low_level_trace(enter_pred,pen,XREGS+1);
#endif /* LOW_LEVEL_TRACE */
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL)(B->cp_b);
CP = P;
q = pen->FirstClause;
if (pen->PredFlags & ProfiledPredFlag) {
LOCK(pen->StatisticsForPred.lock);
if (position == 1)
pen->StatisticsForPred.NOfEntries++;
else
pen->StatisticsForPred.NOfRetries++;
UNLOCK(pen->StatisticsForPred.lock);
}
if (flags & DynamicPredFlag) {
CLAUSECODE->arity = pen->ArityOfPE;
CLAUSECODE->func = pen->FunctorOfPred;
while (position > 1) {
while (ClauseCodeToClause(q)->ClFlags & ErasedMask)
q = NextClause(q);
position--;
q = NextClause(q);
}
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL)(B->cp_b);
CP = P;
q = pen->FirstClause;
if (pen->PredFlags & ProfiledPredFlag) {
LOCK(pen->StatisticsForPred.lock);
if (position == 1)
pen->StatisticsForPred.NOfEntries++;
else
pen->StatisticsForPred.NOfRetries++;
UNLOCK(pen->StatisticsForPred.lock);
}
if (flags & DynamicPredFlag) {
CLAUSECODE->arity = pen->ArityOfPE;
CLAUSECODE->func = pen->FunctorOfPred;
while (position > 1) {
while (ClauseCodeToClause(q)->ClFlags & ErasedMask)
q = NextClause(q);
#if defined(YAPOR) || defined(THREADS)
{
Clause *cl = ClauseCodeToClause(q);
LOCK(cl->ClLock);
TRAIL_CLREF(cl);
INC_DBREF_COUNT(cl);
UNLOCK(cl->ClLock);
}
#else
if (!(ClauseCodeToClause(q)->ClFlags & InUseMask)) {
OPREG *opp = &(ClauseCodeToClause(q)->ClFlags);
TRAIL_CLREF(ClauseCodeToClause(q));
*opp |= InUseMask;
}
#endif
CLAUSECODE->clause = (CODEADDR)NEXTOP((yamop *)(q),ld);
P = (yamop *)CLAUSECODE->clause;
WRITE_UNLOCK(pen->PRWLock);
return((CELL)(&(CLAUSECODE->clause)));
} else {
for (; position > 1; position--)
q = NextClause(q);
P = NEXTOP((yamop *)(q),ld);
WRITE_UNLOCK(pen->PRWLock);
return (Unsigned(&(pen->StateOfPred)));
position--;
q = NextClause(q);
}
}
}
if (flags & UserCPredFlag) {
Int(*p) (void) = (Int(*) (void)) pen->CodeOfPred;
Int out;
WRITE_UNLOCK(pen->PRWLock);
save_machine_regs();
out = YapExecute(p);
restore_machine_regs();
return(out);
}
if (flags & CPredFlag) {
Int(*p) (void) = (Int(*) (void)) pen->CodeOfPred;
WRITE_UNLOCK(pen->PRWLock);
return ((*p) ());
} else if (flags & BasicPredFlag) {
if (pen->OpcodeOfPred != UNDEF_OPCODE) {
Int(*p) (void) = (Int(*) (void)) pen->CodeOfPred;
while (ClauseCodeToClause(q)->ClFlags & ErasedMask)
q = NextClause(q);
#if defined(YAPOR) || defined(THREADS)
{
Clause *cl = ClauseCodeToClause(q);
LOCK(cl->ClLock);
TRAIL_CLREF(cl);
INC_DBREF_COUNT(cl);
UNLOCK(cl->ClLock);
}
#else
if (!(ClauseCodeToClause(q)->ClFlags & InUseMask)) {
OPREG *opp = &(ClauseCodeToClause(q)->ClFlags);
TRAIL_CLREF(ClauseCodeToClause(q));
*opp |= InUseMask;
}
#endif
CLAUSECODE->clause = (CODEADDR)NEXTOP((yamop *)(q),ld);
P = (yamop *)CLAUSECODE->clause;
WRITE_UNLOCK(pen->PRWLock);
return (((*p) ()) != FALSE);
return((CELL)(&(CLAUSECODE->clause)));
} else {
for (; position > 1; position--)
q = NextClause(q);
P = NEXTOP((yamop *)(q),ld);
WRITE_UNLOCK(pen->PRWLock);
return (Unsigned(pen));
}
} else {
Error(SYSTEM_ERROR,ARG1,"debugger tries to debug clause for builtin");
return (FALSE);
}
return (FALSE);
}
static Term
current_cp_as_integer(void)
{
return(MkIntTerm(LCL0-(CELL *)B));
}
static Int
@ -186,154 +189,110 @@ p_save_cp(void)
return(TRUE);
}
inline static int
SpecialCallFunctor(Functor f) {
return(f == FunctorComma || f == FunctorOr || f == FunctorArrow ||
f == FunctorVBar || f == FunctorNot || f == FunctorAltNot);
}
inline static Int
CallMetaCall(void) {
ARG2 = current_cp_as_integer(); /* p_save_cp */
ARG3 = ARG1;
WRITE_LOCK(PredMetaCall->PRWLock);
return (FastCallProlog(PredMetaCall));
}
inline static Int
EnterCreepMode(PredEntry *pen) {
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy));
PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,*CurrentModulePtr));
ARG1 = MkPairTerm(Module_Name((CODEADDR)(pen)),ARG1);
CreepFlag = CalculateStackGap();
P_before_spy = P;
WRITE_LOCK(PredSpy->PRWLock);
return (FastCallProlog(PredSpy));
return (CallPredicate(PredSpy, B));
}
static Int
p_execute(void)
{ /* '$execute'(Goal) */
Term t = Deref(ARG1);
Prop pe;
Atom a;
inline static Int
do_execute(Term t)
{
restart_exec:
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCall());
} else if (IsVarTerm(t)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCall());
} else {
Error(INSTANTIATION_ERROR,t,"call/1");
return(FALSE);
}
}
if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
register CELL *pt;
unsigned int arity;
PredEntry *pen;
unsigned int i, arity;
if (IsExtensionFunctor(f)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCall());
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
}
return CallError(TYPE_ERROR_CALLABLE);
}
arity = ArityOfFunctor(f);
if (SpecialCallFunctor(f)) {
pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr));
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & MetaPredFlag) {
return(CallMetaCall());
} else 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(CallMetaCall());
}
} else {
PredEntry *pen;
arity = ArityOfFunctor(f);
a = NameOfFunctor(f);
if (CurrentModule)
pe = PredPropByFunc(f);
else {
pe = GetPredPropByFunc(f);
if (pe == NIL) {
return(CallMetaCall());
}
}
pen = RepPredProp(pe);
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & MetaPredFlag) {
return(CallMetaCall());
}
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
for (i = 1; i <= arity; ++i) {
#if SBA
Term d0 = *pt++;
if (d0 == 0)
XREGS[i] = (CELL)(pt-1);
else
XREGS[i] = d0;
#else
XREGS[i] = *pt++;
#endif
}
return (CallProlog(pen, arity, (Int) (-1)));
}
} else if (IsAtomOrIntTerm(t)) {
if (IsIntTerm(t)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return (CallMetaCall());
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
}
}
a = AtomOfTerm(t);
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
for (i = 1; i <= arity; i++) {
#if SBA
Term d0 = *pt++;
if (d0 == 0)
XREGS[i] = (CELL)(pt-1);
else
XREGS[i] = d0;
#else
XREGS[i] = *pt++;
#endif
}
return (CallPredicate(pen, B));
} else if (IsAtomTerm(t)) {
PredEntry *pe;
Atom a = AtomOfTerm(t);
if (a == AtomTrue || a == AtomOtherwise || a == AtomCut)
return(TRUE);
else if (a == AtomFail || a == AtomFalse)
return(FALSE);
/* call may not define new system predicates!! */
if (CurrentModule)
pe = PredProp(a, 0);
else {
pe = GetPredProp(a, 0);
if (pe == NIL) {
ARG1 = t;
return(CallMetaCall());
}
}
pe = RepPredProp(PredPropByAtom(a, *CurrentModulePtr));
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(RepPredProp(pe)));
return(EnterCreepMode(pe));
}
return (CallProlog(RepPredProp(pe), 0, (Int) (-1)));
return (CallPredicate(pe, B));
} else if (IsIntTerm(t)) {
return CallError(TYPE_ERROR_CALLABLE);
} else {
/* Is Pair Term */
return(CallMetaCall());
}
}
static Int
p_execute(void)
{ /* '$execute'(Goal) */
Term t = Deref(ARG1);
return(do_execute(t));
}
static Int
p_execute_in_mod(void)
{ /* '$execute'(Goal) */
if (ARG2 != ModuleName[CurrentModule]) {
/* switch modules, but do it in Prolog */
Term ts[2];
ts[0] = ARG2;
ts[1] = ARG1;
ARG1 = MkApplTerm(FunctorModule, 2, ts);
}
return(do_execute(Deref(ARG1)));
}
inline static Int
CallMetaCallWithin(void)
{
WRITE_LOCK(PredMetaCall->PRWLock);
return (FastCallProlog(PredMetaCall));
return (CallPredicate(PredMetaCall, B));
}
/* '$execute_within'(Goal,CutPt,OrigGoal) */
@ -349,29 +308,17 @@ p_execute_within(void)
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCallWithin());
} else if (IsVarTerm(t)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCallWithin());
} else {
Error(INSTANTIATION_ERROR,t,"call/1");
return(FALSE);
}
return CallError(INSTANTIATION_ERROR);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
register CELL *pt;
if (IsExtensionFunctor(f)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return(CallMetaCallWithin());
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
}
return CallError(TYPE_ERROR_CALLABLE);
}
if (SpecialCallFunctor(f)) {
return(CallMetaCallWithin());
} else if (f == FunctorModule) {
if (f == FunctorModule) {
Term mod = ArgOfTerm(1, t);
if (mod == ModuleName[CurrentModule]) {
/* we can skip this operation */
@ -388,9 +335,9 @@ p_execute_within(void)
a = NameOfFunctor(f);
if (CurrentModule)
pe = PredPropByFunc(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
else {
pe = GetPredPropByFunc(f);
pe = GetPredPropByFunc(f, *CurrentModulePtr);
if (pe == NIL) {
return(CallMetaCallWithin());
}
@ -421,16 +368,11 @@ p_execute_within(void)
XREGS[i] = *pt++;
#endif
}
return (CallProlog(pen, arity, (Int) (-1)));
return (CallPredicate(pen, B));
}
} else if (IsAtomOrIntTerm(t)) {
if (IsIntTerm(t)) {
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {
return (CallMetaCallWithin());
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
}
return CallError(TYPE_ERROR_CALLABLE);
}
a = AtomOfTerm(t);
if (a == AtomTrue || a == AtomOtherwise)
@ -447,34 +389,125 @@ p_execute_within(void)
DelayedB = pt0;
}
/* find where to cut to */
#ifdef YAPOR
if (SHOULD_CUT_UP_TO(B,pt0)) {
#ifdef YAPOR
/* Wow, we're gonna cut!!! */
CUT_prune_to(pt0);
#else
if (SHOULD_CUT_UP_TO(B,pt0)) {
/* Wow, we're gonna cut!!! */
B = pt0;
#endif /* YAPOR */
HB = PROTECT_FROZEN_H(B);
}
return(TRUE);
} else if (a == AtomFail || a == AtomFalse)
} else if (a == AtomFail || a == AtomFalse) {
return(FALSE);
/* call may not define new system predicates!! */
if (CurrentModule)
pe = PredProp(a, 0);
else {
pe = GetPredProp(a, 0);
if (pe == NIL) {
ARG1 = t;
} else {
/* call may not define new system predicates!! */
pe = PredPropByAtom(a, *CurrentModulePtr);
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(RepPredProp(pe)));
}
return (CallPredicate(RepPredProp(pe), B));
}
} else {
/* Is Pair Term */
return(CallMetaCallWithin());
}
}
/* '$execute_within2'(Goal) */
static Int
p_execute_within2(void)
{
Term t = Deref(ARG1);
Prop pe;
if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) {
return(CallMetaCallWithin());
} else if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
return CallError(TYPE_ERROR_CALLABLE);
}
{
PredEntry *pen;
CELL *dest;
register CELL *pt;
register unsigned int i;
unsigned int arity = ArityOfFunctor(f);
pe = PredPropByFunc(f, *CurrentModulePtr);
pen = RepPredProp(pe);
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & MetaPredFlag) {
return(CallMetaCallWithin());
}
/* at this point check if we should enter creep mode */
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(pen));
}
/* now let us do what we wanted to do from the beginning !! */
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
dest = XREGS+1;
for (i = 0; i < arity; ++i) {
#if SBA
Term d0 = *pt++;
if (d0 == 0)
*dest++ = (CELL)(pt-1);
else
*dest++ = d0;
#else
*dest++ = *pt++;
#endif
}
return (CallPredicate(pen, (choiceptr)(ENV[E_CB])));
}
} else if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
if (a == AtomTrue || a == AtomOtherwise)
return(TRUE);
else if (a == AtomCut) {
choiceptr pt0;
pt0 = (choiceptr)(ENV[E_CB]);
if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {
pt0 = TopB;
if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB))
DelayedB = pt0;
}
/* find where to cut to */
if (SHOULD_CUT_UP_TO(B,pt0)) {
#ifdef YAPOR
/* Wow, we're gonna cut!!! */
CUT_prune_to(pt0);
#else
/* Wow, we're gonna cut!!! */
B = pt0;
#endif /* YAPOR */
HB = PROTECT_FROZEN_H(B);
}
return(TRUE);
} else if (a == AtomFail || a == AtomFalse) {
return(FALSE);
}
/* call may not define new system predicates!! */
pe = PredPropByAtom(a, *CurrentModulePtr);
if (yap_flags[SPY_CREEP_FLAG]) {
return(EnterCreepMode(RepPredProp(pe)));
}
return (CallProlog(RepPredProp(pe), 0, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
} else if (IsIntTerm(t)) {
return CallError(TYPE_ERROR_CALLABLE);
} else {
/* Is Pair Term */
return(CallMetaCallWithin());
@ -491,14 +524,7 @@ p_execute0(void)
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
arity = 0;
if (CurrentModule)
pe = PredProp(a, arity);
else {
pe = GetPredProp(a, arity);
if (pe == NIL)
return(FALSE);
}
pe = PredPropByAtom(a, *CurrentModulePtr);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
register unsigned int i;
@ -511,30 +537,23 @@ p_execute0(void)
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
for (i = 1; i <= arity; ++i)
for (i = 1; i <= arity; ++i) {
#if SBA
{
Term d0 = *pt++;
if (d0 == 0)
XREGS[i] = (CELL)(pt-1);
else
XREGS[i] = d0;
}
#else
XREGS[i] = *pt++;
#endif
if (CurrentModule)
pe = PredPropByFunc(f);
else {
pe = GetPredPropByFunc(f);
if (pe == NIL)
return(FALSE);
}
pe = GetPredPropByFunc(f, *CurrentModulePtr);
} else
return (FALSE); /* for the moment */
/* N = arity; */
/* call may not define new system predicates!! */
return (CallProlog(RepPredProp(pe), arity, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -545,15 +564,8 @@ p_execute_0(void)
Atom a;
a = AtomOfTerm(t);
if (CurrentModule)
pe = PredProp(a, 0);
else {
pe = GetPredProp(a, 0);
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 0, (Int) (-1)));
pe = PredPropByAtom(a, *CurrentModulePtr);
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -572,7 +584,7 @@ p_execute_1(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 1, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -592,7 +604,7 @@ p_execute_2(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 2, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -613,7 +625,7 @@ p_execute_3(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 3, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -635,7 +647,7 @@ p_execute_4(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 4, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -658,7 +670,7 @@ p_execute_5(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 5, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -682,7 +694,7 @@ p_execute_6(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 6, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -707,7 +719,7 @@ p_execute_7(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 7, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -733,7 +745,7 @@ p_execute_8(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 8, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -760,7 +772,7 @@ p_execute_9(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 9, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
static Int
@ -788,7 +800,7 @@ p_execute_10(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), 10, (Int) (-1)));
return (CallPredicate(RepPredProp(pe), B));
}
#ifdef DEPTH_LIMIT
@ -861,7 +873,7 @@ p_at_execute(void)
if (pe == NIL)
return(FALSE);
}
return (CallProlog(RepPredProp(pe), arity, IntOfTerm(t2)));
return (CallClause(RepPredProp(pe), arity, IntOfTerm(t2)));
}
int
@ -979,7 +991,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
HB = H;
YENV[E_CB] = Unsigned (B);
P = (yamop *) CodeAdr;
S = CellPtr (&(RepPredProp (PredProp (AtomCall, 1))->StateOfPred)); /* A1 mishaps */
S = CellPtr (RepPredProp (PredProp (AtomCall, 1))); /* A1 mishaps */
TopB = B;
return(exec_absmi(top));
@ -1012,7 +1024,7 @@ execute_goal(Term t, int nargs)
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pt = NULL;
pe = GetPredProp(a, 0);
pe = PredPropByAtom(a, *CurrentModulePtr);
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
@ -1024,7 +1036,7 @@ execute_goal(Term t, int nargs)
otherwise I would dereference the argument and
might skip a svar */
pt = RepAppl(t)+1;
pe = GetPredPropByFunc(f);
pe = GetPredPropByFunc(f, *CurrentModulePtr);
} else {
Error(TYPE_ERROR_CALLABLE,t,"call/1");
return(FALSE);
@ -1043,12 +1055,12 @@ execute_goal(Term t, int nargs)
}
if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
CodeAdr = RepPredProp (PredProp (at, 0))->CodeOfPred;
CodeAdr = RepPredProp (PredPropByAtom(at, *CurrentModulePtr))->CodeOfPred;
READ_UNLOCK(ppe->PRWLock);
out = do_goal(CodeAdr, 0, pt, nargs, FALSE);
} else {
Functor f = FunctorOfTerm(t);
CodeAdr = RepPredProp (PredPropByFunc (f))->CodeOfPred;
CodeAdr = RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->CodeOfPred;
READ_UNLOCK(ppe->PRWLock);
out = do_goal(CodeAdr, ArityOfFunctor(f), pt, nargs, FALSE);
}
@ -1172,7 +1184,7 @@ RunTopGoal(Term t)
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
pt = NULL;
pe = GetPredProp(a, 0);
pe = PredPropByAtom(a, *CurrentModulePtr);
arity = 0;
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
@ -1184,7 +1196,7 @@ RunTopGoal(Term t)
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
pe = GetPredPropByFunc(f);
pe = GetPredPropByFunc(f, *CurrentModulePtr);
pt = RepAppl(t)+1;
arity = ArityOfFunctor(f);
} else {
@ -1315,7 +1327,9 @@ void
InitExecFs(void)
{
InitCPred("$execute", 1, p_execute, 0);
InitCPred("$execute_in_mod", 2, p_execute_in_mod, 0);
InitCPred("$execute_within", 3, p_execute_within, 0);
InitCPred("$execute_within", 1, p_execute_within2, 0);
InitCPred("$execute", 2, p_at_execute, 0);
InitCPred("$call_with_args", 1, p_execute_0, 0);
InitCPred("$call_with_args", 2, p_execute_1, 0);

60
C/init.c
View File

@ -312,12 +312,12 @@ OpDec(int p, char *type, Atom a)
p |= DcrrpFlag;
}
WRITE_LOCK(ae->ARWLock);
info = RepOpProp(LockedGetAProp(ae, OpProperty));
info = RepOpProp(GetAPropHavingLock(ae, OpProperty));
if (EndOfPAEntr(info)) {
info = (OpEntry *) AllocAtomSpace(sizeof(OpEntry));
info->KindOfPE = Ord(OpProperty);
info->NextOfPE = RepAtom(a)->PropOfAE;
RepAtom(a)->PropOfAE = AbsOpProp(info);
info->NextOfPE = RepAtom(a)->PropsOfAE;
RepAtom(a)->PropsOfAE = AbsOpProp(info);
INIT_RWLOCK(info->OpRWLock);
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
@ -507,17 +507,30 @@ InitDebug(void)
PutValue(At, MkIntTerm(10));
}
void
InitCPred(char *Name, int Arity, CPredicate code, int flags)
{
Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->TrueCodeOfPred = pe->CodeOfPred = (CODEADDR) code;
pe->OpcodeOfPred = opcode(_Ystop);
pe->ModuleOfPred = CurrentModule;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
if (flags & UserCPredFlag)
p_code->opc = pe->OpcodeOfPred = opcode(_call_usercpred);
else
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.p = (CODEADDR)pe;
p_code = NEXTOP(p_code,sla);
p_code->opc = opcode(_procceed);
{
Term mod = CurrentModule;
if (mod) mod = MkIntTerm(mod);
pe->ModuleOfPred = mod;
}
if (!(flags & UserCPredFlag)) {
c_predicates[NUMBER_OF_CPREDS] = code;
pe->StateOfPred = NUMBER_OF_CPREDS;
@ -530,9 +543,17 @@ InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int f
{
Atom atom = LookupAtom(Name);
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
pe->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->CodeOfPred = (CODEADDR) code;
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.p = (CODEADDR)pe;
p_code = NEXTOP(p_code,sla);
p_code->opc = opcode(_procceed);
c_predicates[NUMBER_OF_CPREDS] = code;
pe->StateOfPred = NUMBER_OF_CPREDS;
NUMBER_OF_CPREDS++;
@ -550,14 +571,22 @@ InitAsmPred(char *Name, int Arity, int code, CPredicate def, int flags)
PredEntry *pe = RepPredProp(PredProp(atom, Arity));
pe->PredFlags = flags | StandardPredFlag | (code);
pe->FirstClause = pe->LastClause = NIL;
if (def != NULL) {
pe->CodeOfPred = pe->TrueCodeOfPred = (CODEADDR)def;
yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e));
p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) def;
pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code;
p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred);
p_code->u.sla.l2 = (CELL)NIL;
p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.p = (CODEADDR)pe;
p_code = NEXTOP(p_code,sla);
p_code->opc = opcode(_procceed);
c_predicates[NUMBER_OF_CPREDS] = def;
pe->StateOfPred = NUMBER_OF_CPREDS;
NUMBER_OF_CPREDS++;
pe->OpcodeOfPred = opcode(_Ystop);
} else {
pe->FirstClause = pe->LastClause = NIL;
pe->OpcodeOfPred = opcode(_undef_p);
pe->TrueCodeOfPred = pe->CodeOfPred =
(CODEADDR)(&(pe->OpcodeOfPred));
@ -915,6 +944,7 @@ InitCodes(void)
heap_regs->functor_comma = MkFunctor(AtomComma, 2);
heap_regs->functor_csult = MkFunctor(AtomCsult, 1);
heap_regs->functor_eq = MkFunctor(AtomEq, 2);
heap_regs->functor_execute_in_mod = MkFunctor(LookupAtom("$execute_in_mod"), 2);
heap_regs->functor_g_atom = MkFunctor(LookupAtom("atom"), 1);
heap_regs->functor_g_atomic = MkFunctor(LookupAtom("atomic"), 1);
heap_regs->functor_g_compound = MkFunctor(LookupAtom("compound"), 1);
@ -947,6 +977,7 @@ InitCodes(void)
#ifdef EUROTRA
heap_regs->term_dollar_u = MkAtomTerm(LookupAtom("$u"));
#endif
heap_regs->term_prolog = MkAtomTerm(LookupAtom("prolog"));
heap_regs->term_refound_var = MkAtomTerm(LookupAtom("$I_FOUND_THE_VARIABLE_AGAIN"));
heap_regs->n_of_file_aliases = 0;
heap_regs->file_aliases = NULL;
@ -955,10 +986,10 @@ InitCodes(void)
heap_regs->size_of_overflow = 0;
/* make sure no one else can use these two atoms */
*CurrentModulePtr = MkIntTerm(1);
heap_regs->pred_goal_expansion = RepPredProp(PredProp(LookupAtom("goal_expansion"),3));
heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),MkIntTerm(1)));
*CurrentModulePtr = MkIntTerm(0);
heap_regs->dead_clauses = NULL;
heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,3));
heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,3),MkIntTerm(0)));
ReleaseAtom(AtomOfTerm(heap_regs->term_refound_var));
}
@ -1005,7 +1036,7 @@ InitYaamRegs(void)
UndefCode = NULL;
} else {
undefpe = RepPredProp (p);
UndefCode = (CELL *) & (undefpe->CodeOfPred);
UndefCode = undefpe;
}
}
STATIC_PREDICATES_MARKED = FALSE;
@ -1136,6 +1167,7 @@ InitStacks(int Heap,
#else
InitAbsmi();
#endif
InitModules();
InitCodes();
InitOps();
InitDebug();

13
C/modules.c
View File

@ -41,8 +41,11 @@ Module_Name(CODEADDR cap)
predicate is a meta-call. Otherwise it will still work.
*/
return(ModuleName[CurrentModule]);
else
else {
if (ap->ModuleOfPred)
return (ModuleName[IntOfTerm(ap->ModuleOfPred)]);
return (ModuleName[ap->ModuleOfPred]);
}
}
int
@ -94,6 +97,13 @@ p_change_module(void)
return (TRUE);
}
static Int
p_module_number(void)
{ /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1)));
return (unify(ARG2,t));
}
void
InitModules(void)
{
@ -104,4 +114,5 @@ InitModules(void)
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag);
InitCPred("$module_number", 2, p_module_number, SafePredFlag|SyncPredFlag);
}

22
C/save.c
View File

@ -1071,6 +1071,7 @@ restore_codes(void)
heap_regs->functor_comma = FuncAdjust(heap_regs->functor_comma);
heap_regs->functor_csult = FuncAdjust(heap_regs->functor_csult);
heap_regs->functor_eq = FuncAdjust(heap_regs->functor_eq);
heap_regs->functor_execute_in_mod = FuncAdjust(heap_regs->functor_execute_in_mod);
heap_regs->functor_g_atom = FuncAdjust(heap_regs->functor_g_atom);
heap_regs->functor_g_atomic = FuncAdjust(heap_regs->functor_g_atomic);
heap_regs->functor_g_compound = FuncAdjust(heap_regs->functor_g_compound);
@ -1102,6 +1103,7 @@ restore_codes(void)
#ifdef EUROTRA
heap_regs->term_dollar_u = AtomTermAdjust(heap_regs->term_dollar_u);
#endif
heap_regs->term_prolog = AtomTermAdjust(heap_regs->term_prolog);
heap_regs->term_refound_var = AtomTermAdjust(heap_regs->term_refound_var);
heap_regs->file_aliases =
(struct AliasDescS *)AddrAdjust((ADDR)heap_regs->file_aliases);
@ -1112,15 +1114,15 @@ restore_codes(void)
heap_regs->pred_meta_call =
(PredEntry *)AddrAdjust((ADDR)heap_regs->pred_meta_call);
if (heap_regs->undef_code != NULL)
heap_regs->undef_code = PtoHeapCellAdjust(heap_regs->undef_code);
heap_regs->undef_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(heap_regs->undef_code));
if (heap_regs->creep_code != NULL)
heap_regs->creep_code = PtoHeapCellAdjust(heap_regs->creep_code);
heap_regs->creep_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(heap_regs->creep_code));
if (heap_regs->spy_code != NULL)
heap_regs->spy_code = PtoHeapCellAdjust(heap_regs->spy_code);
heap_regs->spy_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(heap_regs->spy_code));
#ifdef COROUTINING
#ifdef MULTI_ASSIGNMENT_VARIABLES
if (heap_regs->wake_up_code != NULL)
heap_regs->wake_up_code = PtoHeapCellAdjust(heap_regs->wake_up_code);
heap_regs->wake_up_code = (PredEntry *)PtoHeapCellAdjust((CELL *)(heap_regs->wake_up_code));
heap_regs->mutable_list =
AbsAppl(PtoGloAdjust(RepAppl(heap_regs->mutable_list)));
heap_regs->atts_mutable_list =
@ -1726,6 +1728,7 @@ RestoreClause(Clause *Cl)
case _call:
case _either:
case _or_else:
case _p_execute:
#ifdef YAPOR
case _or_last:
#endif
@ -2408,7 +2411,10 @@ CleanCode(PredEntry *pp)
CODEADDR FirstC, LastC;
/* Init takes care of the first 2 cases */
pp->FunctorOfPred = FuncAdjust(pp->FunctorOfPred);
if (pp->ArityOfPE)
pp->FunctorOfPred = FuncAdjust(pp->FunctorOfPred);
else
pp->FunctorOfPred = (Functor)AtomAdjust((Atom)(pp->FunctorOfPred));
if (pp->OwnerFile)
pp->OwnerFile = AtomAdjust(pp->OwnerFile);
pp->OpcodeOfPred = opcode(op_from_opcode(pp->OpcodeOfPred));
@ -2555,7 +2561,7 @@ RestoreInvisibleAtoms(void)
#ifdef DEBUG_RESTORE2 /* useful during debug */
YP_fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropOfAE));
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE;
at->NextOfAE = atm = AtomAdjust(atm);
at = RepAtom(atm);
@ -2646,7 +2652,7 @@ restore_heap(void)
#ifdef DEBUG_RESTORE2 /* useful during debug */
YP_fprintf(errout, "Restoring %s\n", at->StrOfAE);
#endif
RestoreEntries(RepProp(at->PropOfAE));
RestoreEntries(RepProp(at->PropsOfAE));
atm = at->NextOfAE = AtomAdjust(at->NextOfAE);
at = RepAtom(atm);
} while (!EndOfPAEntr(at));
@ -2680,7 +2686,7 @@ ShowAtoms()
at = RepAtom(HashPtr->Entry);
do {
YP_fprintf(YP_stderr,"Passei ao %s em %x\n", at->StrOfAE, at);
ShowEntries(RepProp(at->PropOfAE));
ShowEntries(RepProp(at->PropsOfAE));
} while (!EndOfPAEntr(at = RepAtom(at->NextOfAE)));
}
HashPtr++;

33
C/stdpreds.c
View File

@ -141,7 +141,7 @@ p_flipflop(void)
at = FullLookupAtom("$spy");
pred = RepPredProp(PredProp(at, 1));
SpyCode = CellPtr(&(pred->CodeOfPred));
SpyCode = pred;
return ((int) (FlipFlop = (1 - FlipFlop)));
}
@ -165,7 +165,7 @@ p_creep(void)
at = FullLookupAtom("$creep");
pred = RepPredProp(PredProp(at, 1));
CreepCode = (CELL *) & (pred->CodeOfPred);
CreepCode = pred;
CreepFlag = Unsigned(LCL0)-Unsigned(H0);
return (TRUE);
}
@ -192,7 +192,7 @@ FindAtom(codeToFind, arity)
register PredEntry *pp;
AtomEntry *ae = RepAtom(a);
READ_LOCK(ae->ARWLock);
pp = RepPredProp(RepAtom(a)->PropOfAE);
pp = RepPredProp(RepAtom(a)->PropsOfAE);
while (!EndOfPAEntr(pp) && ((pp->KindOfPE & 0x8000)
|| (pp->CodeOfPred != codeToFind)))
pp = RepPredProp(pp->NextOfPE);
@ -1370,7 +1370,10 @@ cont_current_predicate(void)
cut_fail();
EXTRA_CBACK_ARG(2,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule));
Arity = pp->ArityOfPE;
name = NameOfFunctor(pp->FunctorOfPred);
if (Arity)
name = NameOfFunctor(pp->FunctorOfPred);
else
name = (Atom)pp->FunctorOfPred;
return (unify(ARG1,MkAtomTerm(name)) &&
unify(ARG2, MkIntegerTerm(Arity)));
}
@ -1406,7 +1409,7 @@ cont_current_op(void)
if (fix > 3) {
a = AtomOfTerm(Deref(ARG3));
READ_LOCK(RepAtom(a)->ARWLock);
if (EndOfPAEntr(pp = NextOp(RepOpProp(RepAtom(a)->PropOfAE)))) {
if (EndOfPAEntr(pp = NextOp(RepOpProp(RepAtom(a)->PropsOfAE)))) {
READ_UNLOCK(RepAtom(a)->ARWLock);
cut_fail();
}
@ -1453,13 +1456,13 @@ cont_current_op(void)
}
at = RepAtom(a);
READ_LOCK(at->ARWLock);
pp = NextOp(RepOpProp(at->PropOfAE));
pp = NextOp(RepOpProp(at->PropsOfAE));
READ_UNLOCK(at->ARWLock);
} while (EndOfPAEntr(pp));
fix = 0;
EXTRA_CBACK_ARG(3,1) = (CELL) MkAtomTerm(a);
} else {
pp = NextOp(RepOpProp(at->PropOfAE));
pp = NextOp(RepOpProp(at->PropsOfAE));
}
READ_LOCK(pp->OpRWLock);
if (fix == 0 && pp->Prefix == 0)
@ -1553,23 +1556,19 @@ p_debug()
static Int
p_flags(void)
{ /* $flags(+Functor,?OldFlags,?NewFlags) */
Atom at;
int arity;
PredEntry *pe;
Int newFl;
Term t1 = Deref(ARG1);
if (IsVarTerm(t1))
return (FALSE);
if (IsAtomTerm(t1))
at = AtomOfTerm(t1), arity = 0;
else if (IsApplTerm(t1)) {
if (IsAtomTerm(t1)) {
pe = RepPredProp(PredProp(AtomOfTerm(t1), 0));
} else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1);
at = NameOfFunctor(funt);
arity = ArityOfFunctor(funt);
pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr));
} else
return (FALSE);
pe = RepPredProp(PredProp(at, arity));
if (EndOfPAEntr(pe))
return (FALSE);
WRITE_LOCK(pe->PRWLock);
@ -1685,7 +1684,7 @@ p_unhide(void)
}
atom = RepAtom(AtomOfTerm(t1));
WRITE_LOCK(atom->ARWLock);
if (atom->PropOfAE != NIL) {
if (atom->PropsOfAE != NIL) {
Error(SYSTEM_ERROR,t1,"cannot unhide an atom in use");
return(FALSE);
}
@ -1698,7 +1697,7 @@ p_unhide(void)
}
if (EndOfPAEntr(chain))
return (FALSE);
atom->PropOfAE = chain->PropOfAE;
atom->PropsOfAE = chain->PropsOfAE;
if (old == NIL)
INVISIBLECHAIN.Entry = chain->NextOfAE;
else

20
C/tracer.c
View File

@ -133,7 +133,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
/* if (vsc_count < 24) return; */
/* if (vsc_count > 500000) exit(0); */
/* if (gc_calls < 1) return;*/
YP_fprintf(YP_stderr,"%lu (%d)", vsc_count, CurrentModule);
YP_fprintf(YP_stderr,"%lu %p (%d)", vsc_count, B, CurrentModule);
/* check_trail_consistency(); */
if (pred == NULL) {
return;
@ -145,6 +145,9 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
case enter_pred:
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
if (arity == 0)
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
@ -165,7 +168,10 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
} else {
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
if (arity == 0)
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("RETRY PRODUCER: ", s, 0, mname, NULL);
@ -179,7 +185,10 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
} else {
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
if (arity == 0)
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("RETRY CONSUMER: ", s, 0, mname, NULL);
@ -188,7 +197,10 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
case retry_pred:
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
arity = pred->ArityOfPE;
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
if (arity == 0)
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("FAIL ", NULL, 0, NULL, args);

4
C/userpreds.c
View File

@ -690,9 +690,9 @@ p_softfunctor()
WRITE_LOCK(RepAtom(a)->ARWLock);
if ((p0 = GetAProp(a, SFProperty)) == NIL) {
pe = (SFEntry *) AllocAtomSpace(sizeof(*pe));
pe->NextOfPE = RepAtom(a)->PropOfAE;
pe->NextOfPE = RepAtom(a)->PropsOfAE;
pe->KindOfPE = SFProperty;
RepAtom(a)->PropOfAE = AbsSFProp(pe);
RepAtom(a)->PropsOfAE = AbsSFProp(pe);
} else
pe = RepSFProp(p0);
WRITE_UNLOCK(RepAtom(a)->ARWLock);

13
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.9 2001-10-03 13:39:14 vsc Exp $ *
* version: $Id: Heap.h,v 1.10 2001-10-30 16:42:05 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -99,9 +99,9 @@ typedef struct various_codes {
#endif
CELL *wake_up_code;
#endif
CELL *creep_code;
CELL *undef_code;
CELL *spy_code;
struct pred_entry *creep_code;
struct pred_entry *undef_code;
struct pred_entry *spy_code;
int profiling;
AtomHashEntry invisiblechain;
OPCODE dummycode;
@ -227,6 +227,7 @@ typedef struct various_codes {
functor_csult,
functor_cut_by,
functor_eq,
functor_execute_in_mod,
functor_g_atom,
functor_g_atomic,
functor_g_compound,
@ -259,6 +260,7 @@ typedef struct various_codes {
#ifdef EUROTRA
term_dollar_u,
#endif
term_prolog,
term_refound_var;
void *last_wtime;
PredEntry *pred_goal_expansion;
@ -291,6 +293,7 @@ typedef struct various_codes {
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */
#define FAILCODE ((CODEADDR)&(heap_regs->failcode ))
#define FAILCODE ((CODEADDR)&(heap_regs->failcode ))
#define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode ))
#define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode ))
#define YESCODE ((CODEADDR)&(heap_regs->yescode ))
@ -412,6 +415,7 @@ typedef struct various_codes {
#define FunctorCsult heap_regs->functor_csult
#define FunctorCutBy heap_regs->functor_cut_by
#define FunctorEq heap_regs->functor_eq
#define FunctorExecuteInMod heap_regs->functor_execute_in_mod
#define FunctorGAtom heap_regs->functor_g_atom
#define FunctorGAtomic heap_regs->functor_g_atomic
#define FunctorGCompound heap_regs->functor_g_compound
@ -441,6 +445,7 @@ typedef struct various_codes {
#define FunctorVBar heap_regs->functor_v_bar
#define FunctorVar heap_regs->functor_var
#define TermDollarU heap_regs->term_dollar_u
#define TermProlog heap_regs->term_prolog
#define TermReFoundVar heap_regs->term_refound_var
#define PredGoalExpansion heap_regs->pred_goal_expansion
#define PredMetaCall heap_regs->pred_meta_call

3
H/YapOpcodes.h
View File

@ -353,5 +353,6 @@
OPCODE(p_func2f_xx ,xxx),
OPCODE(p_func2f_xy ,xyx),
OPCODE(p_func2f_yx ,yxx),
OPCODE(p_func2f_yy ,yyx)
OPCODE(p_func2f_yy ,yyx),
OPCODE(p_execute ,sla)

16
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.3 2001-10-03 13:39:14 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.4 2001-10-30 16:42:05 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -36,6 +36,8 @@ Atom STD_PROTO(LookupAtom,(char *));
Atom STD_PROTO(FullLookupAtom,(char *));
void STD_PROTO(LookupAtomWithAddress,(char *,AtomEntry *));
Term STD_PROTO(MkApplTerm,(Functor,unsigned int,Term *));
Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, Term));
Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, Term));
Functor STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int));
Functor STD_PROTO(MkFunctor,(Atom,unsigned int));
void STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *));
@ -52,10 +54,11 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term));
int STD_PROTO(LookupModule,(Term));
Prop STD_PROTO(GetPredProp,(Atom,unsigned int));
Prop STD_PROTO(GetPredPropByFunc,(Functor));
Prop STD_PROTO(LockedGetPredProp,(Atom,unsigned int));
Prop STD_PROTO(GetPredPropByAtom,(Atom, Term));
Prop STD_PROTO(GetPredPropByFunc,(Functor, Term));
Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int));
Prop STD_PROTO(GetExpProp,(Atom,unsigned int));
Prop STD_PROTO(LockedGetExpProp,(AtomEntry *,unsigned int));
Prop STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int));
Term STD_PROTO(Module_Name, (CODEADDR));
@ -146,10 +149,11 @@ void STD_PROTO(InitEval,(void));
Int STD_PROTO(EvFArt,(Term));
/* exec.c */
Term STD_PROTO(ExecuteCallMetaCall,(void));
void STD_PROTO(InitExecFs,(void));
int STD_PROTO(RunTopGoal,(Term));
Int STD_PROTO(execute_goal,(Term, int));
int STD_PROTO(exec_absmi,(int));
int STD_PROTO(RunTopGoal,(Term));
void STD_PROTO(InitExecFs,(void));
/* grow.c */

2
H/absmi.h
View File

@ -151,7 +151,7 @@ int STD_PROTO(iequ_complex, (CELL *, CELL *,CELL *));
#ifdef ANALYST
static char *op_names[_std_top + 1] =
static char *op_names[_p_execute + 1] =
{
#define OPCODE(OP,TYPE) #OP
#include "YapOpcodes.h"

2
H/eval.h
View File

@ -34,7 +34,7 @@
#ifdef LONG_MIN
#define Int_MIN LONG_MIN
#else
#define Int_MIN (-CELL_MAX-(CELL)1)
#define Int_MIN (-Int_MAX-(CELL)1)
#endif
typedef union arith_ret {

1
changes4.3.html
View File

@ -16,6 +16,7 @@
<h2>Yap-4.3.20:</h2>
<ul>
<li>CLEANUP: don't use state of Pred.</li>
<li>SPEEDUP: improve predicate access by linking predicates to
functors.</li>
<li>FIXED: listing broke when current_predicate became meta.</li>

2
m4/Atoms.h.m4
View File

@ -41,7 +41,7 @@ typedef struct PropEntryStruct *Prop;
/* atom structure */
typedef struct AtomEntryStruct {
Atom NextOfAE; /* used to build hash chains */
Prop PropOfAE; /* property list for this atom */
Prop PropsOfAE; /* property list for this atom */
#if defined(YAPOR) || defined(THREADS)
rwlock_t ARWLock;
#endif

138
m4/Yatom.h.m4
View File

@ -202,24 +202,24 @@ typedef struct {
typedef struct pred_entry {
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
unsigned int ArityOfPE; /* arity of property */
SMALLUNSGN StateOfPred; /* actual state of predicate */
unsigned int ArityOfPE; /* arity of property */
Term ModuleOfPred; /* module for this definition */
CELL PredFlags;
CODEADDR CodeOfPred; /* code address */
CODEADDR TrueCodeOfPred; /* if needing to spy or to lock */
Functor FunctorOfPred; /* functor for Predicate */
Functor FunctorOfPred; /* functor for Predicate */
CODEADDR FirstClause, LastClause;
CELL PredFlags;
Atom OwnerFile; /* File where the predicate was defined */
Atom OwnerFile; /* File where the predicate was defined */
struct pred_entry *NextPredOfModule; /* next pred for same module */
#if defined(YAPOR) || defined(THREADS)
rwlock_t PRWLock; /* a simple lock to protect this entry */
rwlock_t PRWLock; /* a simple lock to protect this entry */
#endif
#ifdef TABLING
tab_ent_ptr TableOfPred;
tab_ent_ptr TableOfPred;
#endif /* TABLING */
OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */
profile_data StatisticsForPred; /* enable profiling for predicate */
SMALLUNSGN ModuleOfPred; /* module for this definition */
OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */
profile_data StatisticsForPred; /* enable profiling for predicate */
SMALLUNSGN StateOfPred; /* actual state of predicate */
} PredEntry;
#define PEProp ((PropFlags)(0x0000))
@ -493,86 +493,52 @@ CODEADDR STD_PROTO(PredIsIndexable,(PredEntry *));
/* init.c */
Atom STD_PROTO(GetOp,(OpEntry *,int *,int));
#ifdef XX_ADTDEFS_C
#ifndef inline
/* look property list of atom a for kind */
EXTERN inline Prop GetAProp(a,kind)
Atom a;
PropFlags kind;
{ register PropEntry *pp = RepProp(RepAtom(a)->PropOfAE);
while( !EndOfPAEntr(pp) && pp->KindOfPE!=kind) pp=RepProp(pp->NextOfPE);
return(AbsProp(pp));
}
/* get predicate entry for ap/arity; create it if neccessary. */
EXTERN inline Prop PredProp(ap,arity)
Atom ap;
unsigned int arity;
{
Prop p0;
PredEntry *p = RepPredProp(p0=RepAtom(ap)->PropOfAE);
while(p0 && (p->KindOfPE != 00 || p->ArityOfPE != arity ||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
p = RepPredProp(p0=p->NextOfPE);
if(p0) return(p0);
YAPEnterCriticalSection();
p = (PredEntry *) AllocAtomSpace(sizeof(*p));
p->KindOfPE = PEProp;
p->ArityOfPE = arity;
p->FirstClause = p->LastClause = NIL;
p->PredFlags = 0L;
p->StateOfPred = 0;
p->OwnerFile = AtomNil;
p->ModuleOfPred = CurrentModule;
p->OpcodeOfPred = opcode(_undef_p);
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
p->StatisticsForPred.NOfRetries = 0;
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->DefaultCodeOfPred));
if (arity==0) p->FunctorOfPred = (Functor) ap;
else p->FunctorOfPred = MkFunctor(ap,arity);
p->NextOfPE = RepAtom(ap)->PropOfAE;
RepAtom(ap)->PropOfAE = p0 = AbsPredProp(p);
YAPLeaveCriticalSection();
return(p0);
}
EXTERN inline Term GetValue(a)
Atom a;
{
Prop p0 = GetAProp(a,ValProperty);
if(p0==0) return(MkAtomTerm(AtomNil));
return(RepValProp(p0)->ValueOfVE);
}
EXTERN inline void PutValue(a,v)
Atom a; Term v;
{
Prop p0 = GetAProp(a,ValProperty);
if(p0) RepValProp(p0)->ValueOfVE = v;
else {
ValEntry *p;
YAPEnterCriticalSection();
p = (ValEntry *) AllocAtomSpace(sizeof(ValEntry));
p->KindOfPE = ValProperty;
p->ValueOfVE = v;
p->NextOfPE = RepAtom(a)->PropOfAE;
RepAtom(a)->PropOfAE = AbsValProp(p);
YAPLeaveCriticalSection();
}
}
#endif /* inline */
#else
/* vsc: redefined to GetAProp to avoid conflicts with Windows header files */
Prop STD_PROTO(GetAProp,(Atom,PropFlags));
Prop STD_PROTO(LockedGetAProp,(AtomEntry *,PropFlags));
Prop STD_PROTO(GetAPropHavingLock,(AtomEntry *,PropFlags));
Prop STD_PROTO(PredProp,(Atom,unsigned int));
Prop STD_PROTO(PredPropByFunc,(Functor));
#endif /* ADTDEFS_C */
EXTERN inline Prop
PredPropByFunc(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
FunctorEntry *fe = (FunctorEntry *)f;
WRITE_LOCK(fe->FRWLock);
p0 = fe->PropsOfFE;
while (p0) {
PredEntry *p = RepPredProp(p0);
if (/* p->KindOfPE != 0 || only props */
(p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) {
WRITE_UNLOCK(f->FRWLock);
return (p0);
}
p0 = p->NextOfPE;
}
return(NewPredPropByFunctor(fe,cur_mod));
}
EXTERN inline Prop
PredPropByAtom(Atom at, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(at);
WRITE_LOCK(ae->ARWLock);
p0 = ae->PropsOfAE;
while (p0) {
PredEntry *pe = RepPredProp(p0);
if ( pe->KindOfPE == PEProp &&
(pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
WRITE_UNLOCK(ae->ARWLock);
return(p0);
}
p0 = pe->NextOfPE;
}
return(NewPredPropByAtom(ae,cur_mod));
}
#if defined(YAPOR) || defined(THREADS)
void STD_PROTO(ReleasePreAllocCodeSpace, (ADDR));

12
pl/arith.yap
View File

@ -36,11 +36,20 @@ do_not_compile_expressions :- '$set_value'('$c_arith',[]).
'$c_built_in'(IN, IN).
'$do_c_built_in'(Mod:G, Mod:GN) :- !,
'$do_c_built_in'(G, GN).
'$do_c_built_in'(\+ G, OUT) :-
nonvar(G),
G = (A = B),
!,
OUT = (A \= B).
'$do_c_built_in'(call(G), OUT) :-
nonvar(G),
G = (Mod:G1),
atom(Mod),
!,
'$module_number'(Mod,MNum),
OUT = '$execute_in_mod'(G1,MNum).
'$do_c_built_in'(recorded(K,T,R), OUT) :-
nonvar(K),
!,
@ -153,8 +162,7 @@ do_not_compile_expressions :- '$set_value'('$c_arith',[]).
'$expand_expr'(/\, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$and'(X1,Y1,O), F),
'$do_and'(Q, F, P),
'$do_and'(Q, '$and'(X,Y,O), P).
'$do_and'(Q, F, P).
'$expand_expr'(\/, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$or'(X1,Y1,O), F),

28
pl/boot.yap
View File

@ -641,13 +641,35 @@ incore(G) :- '$execute'(G).
'$iso_check_goal'(G,G0),
'$call'(G, CP,G0).
','(A,B) :-
'$execute_within'(A),
'$execute_within'(B).
';'(A,B) :-
( '$execute_within'(A) ;
'$execute_within'(B) ).
'|'(A,B) :-
( '$execute_within'(A) ;
'$execute_within'(B) ).
'->'(A,B) :-
( '$execute_within'(A) ->
'$execute_within'(B) ).
\+(A) :-
\+ '$execute_within'(A).
not(A) :-
\+ '$execute_within'(A).
Mod:G :- '$mod_switch'(Mod,'$execute_within'(G)).
'$call'(M:_,_,G0) :- var(M), !,
throw(error(instantiation_error,call(G0))).
'$call'(M:G,CP,G0) :- !,
'$mod_switch'(M,'$call'(G,CP,G0)).
'$call'((A,B),CP,G0) :- !,
'$execute_within'(A,CP,G0),
'$execute_within'(B,CP,G0).
'$call'((X->Y),CP,G0) :- !,
(
'$execute_within'(X,CP,G0)

12
pl/checker.yap
View File

@ -35,7 +35,7 @@ style_check([]).
style_check([H|T]) :- style_check(H), style_check(T).
no_style_check(V) :- var(V), !, fail.
no_style_check(all) :- $syntax_check_mode(_,off),
no_style_check(all) :- '$syntax_check_mode'(_,off),
'$syntax_check_single_var'(_,off),
'$syntax_check_discontiguous'(_,off),
'$syntax_check_multiple'(_,off).
@ -98,10 +98,10 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$sv_list'(T,L).
$sv_warning([],_) :- !.
$sv_warning(SVs,T) :-
'$sv_warning'([],_) :- !.
'$sv_warning'(SVs,T) :-
'$xtract_head'(T,H,Name,Arity),
write(user_error,'[ Warning: singleton variable '),
write(user_error,'[ Warning: singleton variable'),
'$write_svs'(SVs),
write(user_error,' in '),
write(user_error,Name/Arity),
@ -123,7 +123,7 @@ $sv_warning(SVs,T) :-
'$xtract_head'((H,_),H1,Name,Arity) :- !,
'$xtract_head'(H,H1,Name,Arity).
'$xtract_head'((H-->_),HL,Name,Arity) :- !,
'$xtract_head'(H,H1,Name,A1),
'$xtract_head'(H,_,Name,A1),
Arity is A1+2,
functor(HL,Name,Arity).
'$xtract_head'(H,H,Name,Arity) :-
@ -158,7 +158,7 @@ $sv_warning(SVs,T) :-
'$handle_multiple'(F,A) :-
\+ '$first_clause_in_file'(F,A), !.
'$handle_multiple'(F,A) :-
'$handle_multiple'(_,_) :-
'$get_value'('$consulting',true), !.
'$handle_multiple'(F,A) :-
'$current_module'(M),

16
pl/consult.yap
View File

@ -28,9 +28,9 @@ ensure_loaded(V) :-
'$find_in_path'(X,Y),
( open(Y,'$csult',Stream), !,
( '$loaded'(Stream) ->
( $consulting_file_name(Stream,TFN),
( '$consulting_file_name'(Stream,TFN),
'$recorded'('$module','$module'(TFN,M,P),_) ->
$current_module(T), '$import'(P,M,T)
'$current_module'(T), '$import'(P,M,T)
;
true
)
@ -51,7 +51,7 @@ ensure_loaded(V) :-
( '$loaded'(Stream) ->
( '$consulting_file_name'(Stream,TFN),
'$recorded'('$module','$module'(TFN,M,P),_) ->
'$current_module'(T), $import(P,M,T)
'$current_module'(T), '$import'(P,M,T)
;
true
)
@ -158,9 +158,9 @@ reconsult(Fs) :-
'EMACS_FILE'(F,File0) :-
format('''EMACS_RECONSULT''(~w).~n',[File0]),
'$getcwd'(OldD),
open(F,$csult,Stream),
open(F,'$csult',Stream),
'$find_in_path'(File0,File),
open(File,$csult,Stream0),
open(File,'$csult',Stream0),
'$get_value'('$consulting_file',OldF),
'$set_consulting_file'(Stream0),
H0 is heapused, T0 is cputime,
@ -177,7 +177,7 @@ reconsult(Fs) :-
'$end_consult',
'$clear_reconsulting',
( LC == 0 -> prompt(_,' |: ') ; true),
( '$get_value'($verbose,on) ->
( '$get_value'('$verbose',on) ->
tab(user_error,LC) ;
true ),
H is heapused-H0, T is cputime-T0,
@ -243,10 +243,10 @@ reconsult(Fs) :-
'$peek_byte'(Stream, 0'#), !, % 35 is ASCII for #
'$get0_line_codes'(Stream, _),
'$skip_unix_comments'(Stream).
'$skip_unix_comments'(Stream).
'$skip_unix_comments'(_).
prolog_load_context(_, X) :-
prolog_load_context(_, _) :-
'$get_value'('$consulting_file',[]), !, fail.
prolog_load_context(directory, DirName) :-
'$get_value'('$consulting_file',FileName),

47
pl/corout.yap
View File

@ -116,7 +116,7 @@ freeze(_, G) :-
'$freeze_goal'(V,VG) :-
var(VG), !,
'$current_module'(M),
'$freeze'(V, '$redo_freeze'(_Done,V,M:G)).
'$freeze'(V, '$redo_freeze'(_Done,V,M:VG)).
'$freeze_goal'(V,M:G) :- !,
'$freeze'(V, '$redo_freeze'(_Done,V,M:G)).
'$freeze_goal'(V,G) :-
@ -161,7 +161,7 @@ freeze(_, G) :-
%
dif(X, Y) :- '$can_unify'(X, Y, LVars), !,
LVars = [_|_],
'$dif_suspend_on_lvars'(LVars, '$redo_dif'(Done, X, Y)).
'$dif_suspend_on_lvars'(LVars, '$redo_dif'(_Done, X, Y)).
dif(_, _).
@ -179,8 +179,8 @@ dif(_, _).
% we try to increase the number of suspensions; last, the two terms
% did not unify, we are done, so we succeed and bind the Done variable.
%
'$redo_dif'(Done, X, Y, G) :- nonvar(Done), !.
'$redo_dif'(Done, X, Y, G) :-
'$redo_dif'(Done, _, _, _) :- nonvar(Done), !.
'$redo_dif'(_, X, Y, G) :-
'$can_unify'(X, Y, LVars), !,
LVars = [_|_],
'$dif_suspend_on_lvars'(LVars, G).
@ -191,7 +191,7 @@ dif(_, _).
%
% someone else (that is Cond had ;) did the work, do nothing
%
'$redo_freeze'(Done, Goal) :- nonvar(Done), !.
'$redo_freeze'(Done, _) :- nonvar(Done), !.
%
% We still have some more conditions: continue the analysis.
%
@ -208,8 +208,8 @@ dif(_, _).
%
% eq is a combination of dif and freeze
'$redo_eq'(Done, X, Y, Goal, G) :- nonvar(Done), !.
'$redo_eq'(Done, X, Y, _, G) :-
'$redo_eq'(Done, _, _, _, _) :- nonvar(Done), !.
'$redo_eq'(_, X, Y, _, G) :-
'$can_unify'(X, Y, LVars),
LVars = [_|_], !,
'$dif_suspend_on_lvars'(LVars, G).
@ -220,7 +220,7 @@ dif(_, _).
%
% ground is similar to freeze
'$redo_ground'(Done, X, Goal) :- nonvar(Done), !.
'$redo_ground'(Done, _, _) :- nonvar(Done), !.
'$redo_ground'(Done, X, Goal) :-
'$non_ground'(X, Var), !,
'$freeze'(Var, '$redo_ground'(Done, X, Goal)).
@ -313,7 +313,7 @@ when(_,Goal) :-
'$when'(Cond, G, Done, [], LG),
!,
'$suspend_when_goals'(LG, Done).
'$when'(Cond, G, '$done') :-
'$when'(_, G, '$done') :-
'$execute'(G).
%
@ -360,7 +360,7 @@ when(_,Goal) :-
'$suspend_when_goals'(['$dif_suspend_on_lvars'(LVars, G)|LG], Done) :-
var(Done), !,
'$dif_suspend_on_lvars'(LVars, G),
'$suspend_when_goals'(Ls, Done).
'$suspend_when_goals'(LG, Done).
'$suspend_when_goals'([_|_], _).
%
@ -377,7 +377,7 @@ when(_,Goal) :-
% significant as the remaining overheads.
%
'$block'(Conds) :-
'$generate_blocking_code'(Conds, G, Code),
'$generate_blocking_code'(Conds, _, Code),
'$$compile'(Code, Code, 5), fail.
'$block'(_).
@ -397,7 +397,7 @@ when(_,Goal) :-
%
% find out what we are blocking on.
%
'$extract_head_for_block'((C1, C2), G) :- !,
'$extract_head_for_block'((C1, _), G) :- !,
'$extract_head_for_block'(C1, G).
'$extract_head_for_block'(C, G) :-
functor(C, Na, Ar),
@ -528,7 +528,7 @@ frozen(V, LG) :-
'$process_when'(G, NG).
'$process_when'(G, G).
'$convert_frozen_goal'(V, LV, _, V, Gs) :- '$is_att_variable'(V), !.
'$convert_frozen_goal'(V, _, _, V, _) :- '$is_att_variable'(V), !.
'$convert_frozen_goal'('$redo_dif'(Done, X, Y), LV, Done, [X,Y|LV], dif(X,Y)).
'$convert_frozen_goal'('$redo_freeze'(Done, FV, G), LV, Done, [FV|LV], G).
'$convert_frozen_goal'('$redo_eq'(Done, X, Y, G), LV, Done, [X,Y|LV], G).
@ -578,9 +578,9 @@ call_residue(Goal,Residue) :-
'$show_frozen'(Goal,LIV,Residue).
'$purge_and_set_done_goals'([], L, L).
'$purge_and_set_done_goals'([AttV|G0], [LVars-GS|GF], Atts) :-
'$purge_and_set_done_goals'([AttV|G0], [_-GS|GF], Atts) :-
'$is_att_variable'(AttV), !,
attributes:convert_att_var(AttV, Gs),
attributes:convert_att_var(AttV, GS),
'$purge_and_set_done_goals'(G0, GF, Atts).
'$purge_and_set_done_goals'(['$redo_dif'(Done, X , Y)|G0], [LVars-dif(X,Y)|GF], Atts) :-
var(Done),
@ -600,15 +600,14 @@ call_residue(Goal,Residue) :-
var(Done), !,
Done = '$done',
'$purge_and_set_done_goals'(G0, GF, Atts).
'$purge_and_set_done_goals'([G|G0], GF, Atts) :-
Done = '$done',
'$purge_and_set_done_goals'([_|G0], GF, Atts) :-
'$purge_and_set_done_goals'(G0, GF, Atts).
'$project'(true,_,_,Gs,Gs) :- !.
'$project'(_,_,_,Gs,Gs) :-
'$undefined'(attributes:modules_with_attributes(_)), !.
'$project'(G,LIV,LAV,Gs,Gs0) :-
'$project'(_,LIV,LAV,Gs,Gs0) :-
attributes:modules_with_attributes(LMods),
(LAV = [] ->
Gs = Gs0
@ -631,24 +630,24 @@ call_residue(Goal,Residue) :-
'$execute'(Mod:project_attributes(LIV, LAV)), !,
'$all_attvars'(NLAV),
'$project_module'(LMods,LIV,NLAV).
'$project_module'([Mod|LMods], LIV, LAV) :-
'$project_module'([_|LMods], LIV, LAV) :-
'$project_module'(LMods,LIV,LAV).
'$convert_att_vars'([], LIV, L, L).
'$convert_att_vars'([], _, L, L).
'$convert_att_vars'([V|LAV], LIV, NGs, NGs0) :-
var(V),
attributes:convert_att_var(V, G),
G \= true,
'$variables_in_term'(G,[],GV0),
% '$variables_in_term'(G,[],GV0),
% I'm allowing goals without variables to go through
'$sort'(GV0,GV),
% '$sort'(GV0,GV),
% ( GV0 = [] -> true ;
% '$sort'(LIV,NLIV), % notice that ordering changes as we introduce constraints
% '$vars_interset_for_constr'(GV,NLIV) ), !,
!,
'$split_goals_for_catv'(G,V,NGs,IGs),
'$convert_att_vars'(LAV, LIV, IGs, NGs0).
'$convert_att_vars'([V|LAV], LIV, Gs, NGs0) :-
'$convert_att_vars'([_|LAV], LIV, Gs, NGs0) :-
'$convert_att_vars'(LAV, LIV, Gs, NGs0).
'$split_goals_for_catv'((G,NG),V,Gs,Gs0) :- !,
@ -660,7 +659,7 @@ call_residue(Goal,Residue) :-
'$vars_interset_for_constr'([V1|GV],[V2|LIV]) :-
V1 @< V2, !,
'$vars_interset_for_constr'(GV,[V2|LIV]).
'$vars_interset_for_constr'([V1|GV],[V2|LIV]) :-
'$vars_interset_for_constr'([V1|GV],[_|LIV]) :-
'$vars_interset_for_constr'([V1|GV],LIV).

68
pl/debug.yap
View File

@ -28,10 +28,8 @@
% $suspy does most of the work
'$suspy'(V,S) :- var(V) , !,
throw(error(instantiation_error,spy(V,S))).
'$suspy'(M:S,P) :- !,
'$current_module'(Old,M),
('$suspy'(S,P),fail ; true), !,
'$change_module'(Old).
'$suspy'((M:S),P) :- !,
'$mod_switch'(M, '$suspy'(S,P)).
'$suspy'([],_) :- !.
'$suspy'([F|L],M) :- !, ( '$suspy'(F,M) ; '$suspy'(L,M) ).
'$suspy'(F/N,M) :- !, functor(T,F,N),
@ -46,8 +44,9 @@
throw(error(existence_error(procedure,A),spy(A))).
'$suspy'(A,nospy) :- '$noclausesfor'(A), !,
throw(error(existence_error(procedure,A),nospy(A))).
'$suspy'(A,M) :- current_predicate(A,T), functor(T,F,N),
\+ '$undefined'(T), \+ '$system_predicate'(T),
'$suspy'(A,M) :- current_predicate(A,T),
\+ '$undefined'(T), \+ '$system_predicate'(T), !,
functor(T,F,N),
'$suspy2'(M,F,N,T).
'$noclausesfor'(A) :- current_predicate(A,T),
@ -56,12 +55,12 @@
'$noclausesfor'(_).
'$suspy2'(spy,F,N,T) :-
$current_module(M),
'$current_module'(M),
'$recorded'('$spy','$spy'(T,M),_), !,
format('[ Warning: there is already a spy point on ~w ]~n',M:F/N).
'$suspy2'(spy,F,N,T) :- !,
'$warn_if_undef'(T,F,N),
$current_module(M),
'$current_module'(M),
'$recorda'('$spy','$spy'(T,M),_),
'$set_value'('$spypoint_added', true),
'$set_spy'(T),
@ -74,7 +73,7 @@
'$rm_spy'(T),
write(user_error,'[ Spy point on '), write(user_error,F/N), write(user_error,' removed ]'),
nl(user_error).
'$suspy2'(nospy,F,N,T) :-
'$suspy2'(nospy,F,N,_) :-
write(user_error,'[ Warning: there is no spy-point on '),
write(user_error,F/N), write(user_error,' ]'), nl(user_error).
@ -84,15 +83,16 @@
'$warn_if_undef'(_,_,_).
'$pred_being_spied'(G) :-
$current_module(M),'$recorded'('$spy','$spy'(G,M),_),!.
'$current_module'(M),
'$recorded'('$spy','$spy'(G,M),_), !.
spy L :- '$set_value'('$spypoint_added', false), fail.
spy _ :- '$set_value'('$spypoint_added', false), fail.
spy L :- '$suspy'(L,spy), fail.
spy L :- '$get_value'('$spypoint_added', false), !.
spy L :- debug.
spy _ :- '$get_value'('$spypoint_added', false), !.
spy _ :- debug.
nospy L :- '$suspy'(L,nospy), fail.
nospy L.
nospy _.
nospyall :- '$recorded'('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(M:F/N,nospy), fail.
nospyall.
@ -148,10 +148,10 @@ leash(X) :-
'$show_leash_bit'(WasWritten,2'0001,L,fail),
write(user_error,') ]'), nl(user_error).
'$show_leash_bit'(Was,Bit,Code,_) :- Bit /\ Code =:= 0, !.
'$show_leash_bit'(_,Bit,Code,_) :- Bit /\ Code =:= 0, !.
'$show_leash_bit'(Was,_,_,Name) :- var(Was), !,
Was = yes, write(user_error,Name).
'$show_leash_bit'(Was,_,_,Name) :-
'$show_leash_bit'(_,_,_,Name) :-
write(user_error,','), write(user_error,Name).
'$leashcode'(full,2'1111) :- !.
@ -249,11 +249,11 @@ debugging :-
'$awoken_goals'(LG), !,
'$creep',
'$wake_up_goal'(G, LG).
'$spy'([Module|G]) :-
'$spy'([_Module|G]) :-
% '$format'(user_error,"$spym(~w,~w)~n",[Module,G]),
( '$hidden'(G)
;
'$parent_pred'(O,A1,A2),
'$parent_pred'(0,_,_),
'$system_predicate'(G)
),
!,
@ -268,7 +268,7 @@ debugging :-
'$awoken_goals'(LG), !,
'$creep',
'$wake_up_goal'(G, LG).
'$direct_spy'([Module|G]) :-
'$direct_spy'([_|G]) :-
'$hidden'(G),
!,
/* called from prolog module */
@ -328,7 +328,7 @@ debugging :-
'$cont_creep'; /* exit */
/* we get here when we want to redo a goal */
'$set_value'(spy_cl,Cla),/* restore clause no. to try */
$current_module(_,Module),
'$current_module'(_,Module),
'$trace'(redo,G,L), /* inform user_error */
fail /* to backtrack to spycalls */
).
@ -349,18 +349,18 @@ debugging :-
'$spycalls'(Mod:G,Res) :-
!,
'$mod_switch'(Mod,'$spycalls'(G,Res)).
'$spycalls'(repeat,Res) :-
'$spycalls'(repeat,_) :-
!,
repeat.
'$spycalls'(fail,Res) :-
'$spycalls'(fail,_) :-
!,
fail.
'$spycalls'(false,Res) :-
'$spycalls'(false,_) :-
!,
false.
'$spycalls'(true,Res) :-
'$spycalls'(true,_) :-
!.
'$spycalls'(otherwise,Res) :-
'$spycalls'(otherwise,_) :-
!.
'$spycalls'(\+ G,Res) :-
!,
@ -476,7 +476,7 @@ debugging :-
'$spycall_stdpred'(G) :-
functor(G,F,N),
(
'$recorded'('$meta_predicate','$meta_predicate'(Mod,F,N,D),_) ->
'$recorded'('$meta_predicate','$meta_predicate'(_,F,N,_),_) ->
'$setflop'(1),
'$creep',
'$execute0'(G)
@ -752,25 +752,25 @@ debugging :-
'$direct_spy'([M|'!'(CP)]),
% clean up any garbage left here by the debugger.
'$$cut_by'(CP).
'$creep_call'('$cut_by'(X),CP) :- !,
'$creep_call'('$cut_by'(X),_) :- !,
'$$cut_by'(X).
'$creep_call'(repeat,_) :- !,
'$current_module'(M),
'$current_module'(Module),
'$direct_spy'([Module|repeat]).
'$creep_call'([A|B],_) :- !,
'$current_module'(M),
'$current_module'(Module),
'$direct_spy'([Module|[A|B]]).
'$creep_call'(A,CP) :-
'$undefined'(A), !,
'$creep_call_undefined'(A,CP).
'$creep_call'(A,CP) :-
'$creep_call'(A,_) :-
'$current_module'(Module),
'$direct_spy'([Module|A]).
'$creep_call_undefined'(A,CP) :-
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_undefined'(G, _) :-
( \+ '$undefined'(user:unknown_predicate_handler(_,_,_)),
@ -792,7 +792,7 @@ debugging :-
true
),
'$execute'(M:Goal).
'$creep'(G) :-
'$creep'(_) :-
'$get_value'('$throw', true), !,
'$set_value'('$throw', false),
abort.
@ -823,7 +823,7 @@ debugging :-
( SL = L -> write(user_error,'>') ; write(user_error,' ')),
write(user_error,' ('), write(user_error,L), write(user_error,') '),
write(user_error,P), write(user_error,': '),
( $current_module(Module), Module\=prolog,
( '$current_module'(Module), Module\=prolog,
Module\=user -> write(user_error,Module),write(user_error,':');
true
),
@ -979,7 +979,7 @@ debugging :-
'$deb_get_sterm_in_g'(L,G,A),
recorda('$debug_sub_skel',L,_),
nl(user_error), write(user_error,A), nl(user_error), nl(user_error).
'$print_deb_sterm'(G) :- '$skipeol'(94).
'$print_deb_sterm'(_) :- '$skipeol'(94).
'$get_sterm_list'(L) :-
get0(user_input,C),

24
pl/depth_bound.yap
View File

@ -20,15 +20,15 @@
depth_bound_call(A,D) :-
'$execute_under_depth_limit'(A,D).
$old_depth_bound_call(A,D) :-
'$old_depth_bound_call'(A,D) :-
'$check_callable'(A,A),
'$user_call_depth_limited'(A, D).
'$user_call_depth_limited'(V,D) :- var(V), !,
'$user_call_depth_limited'(V,_) :- var(V), !,
throw(error(instantiation_error,V)).
'$user_call_depth_limited'(A,D) :- number(A), !,
throw(error(type_error(callable,A),A,D)).
'$user_call_depth_limited'(R,D) :- db_reference(R), !,
'$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),
@ -100,13 +100,13 @@ $old_depth_bound_call(A,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'(!,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),_) ->
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),
@ -179,13 +179,13 @@ $old_depth_bound_call(A,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'(!,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),_) ->
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),

148
pl/directives.yap
View File

@ -287,46 +287,6 @@ yap_flag(language,X) :-
yap_flag(language,X) :-
throw(error(domain_error(flag_value,language+X),yap_flag(language,X))).
'$trans_to_lang_flag'(0,cprolog).
'$trans_to_lang_flag'(1,iso).
'$trans_to_lang_flag'(2,sicstus).
'$adjust_language'(cprolog) :-
'$switch_log_upd'(0),
'$syntax_check_mode'(_,off),
'$syntax_check_single_var'(_,off),
'$syntax_check_discontiguous'(_,off),
'$syntax_check_multiple'(_,off),
'$transl_to_on_off'(Y,off), % disable character escapes.
'$set_yap_flags'(12,Y),
'$set_yap_flags'(14,1),
unknown(_,error).
'$adjust_language'(sicstus) :-
'$switch_log_upd'(1),
leash(full),
'$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on),
'$transl_to_on_off'(X1,on),
'$set_yap_flags'(5,X1),
'$force_char_conversion',
'$set_yap_flags'(14,0),
unknown(_,error).
'$adjust_language'(iso) :-
'$switch_log_upd'(2),
'$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on),
'$set_yap_flags'(7,1),
fileerrors,
'$transl_to_on_off'(X1,on),
'$set_yap_flags'(5,X1),
'$force_char_conversion',
'$set_yap_flags'(14,0),
unknown(_,error).
yap_flag(debug,X) :-
var(X), !,
('$get_value'(debug,1) ->
@ -417,12 +377,6 @@ yap_flag(character_escapes,X) :- !,
yap_flag(character_escapes,X) :-
throw(error(domain_error(flag_value,character_escapes+X),yap_flag(to_chars_mode,X))).
'$transl_to_character_escape_modes'(0,off) :- !.
'$transl_to_character_escape_modes'(0,cprolog).
'$transl_to_character_escape_modes'(1,on) :- !.
'$transl_to_character_escape_modes'(1,iso).
'$transl_to_character_escape_modes'(2,sicstus).
yap_flag(update_semantics,X) :-
var(X), !,
( '$log_upd'(I) -> '$convert_upd_sem'(I,X) ).
@ -480,9 +434,6 @@ yap_flag(user_error,OUT) :-
yap_flag(user_error,Stream) :-
'$change_alias_to_stream'(user_error,Stream).
'$flag_check_alias'(OUT, Alias) :-
stream_property(OUT,[alias(Alias)]), !.
yap_flag(debugger_print_options,OUT) :-
var(OUT),
'$recorded'('$print_options','$debugger'(OUT),_), !.
@ -501,30 +452,6 @@ yap_flag(toplevel_print_options,Opts) :- !,
:- '$recorda'('$print_options','$toplevel'([quoted(true),numbervars(true),portrayed(true)]),_).
'$convert_upd_sem'(0,immediate).
'$convert_upd_sem'(1,logical).
'$convert_upd_sem'(2,logical_assert).
'$transl_to_true_false'(0,false).
'$transl_to_true_false'(1,true).
'$transl_to_on_off'(0,off).
'$transl_to_on_off'(1,on).
'$transl_to_arity'(X1,X) :- X1 < 0, !, X = unbounded.
'$transl_to_arity'(X,X).
'$transl_to_rounding_function'(0,down).
'$transl_to_rounding_function'(1,toward_zero).
'$transl_to_trl_types'(0,chars).
'$transl_to_trl_types'(1,codes).
'$transl_to_trl_types'(2,atom).
'$yap_flag_show_tracing'(true, _, on) :- !.
'$yap_flag_show_tracing'(_, true, verbose) :- !.
'$yap_flag_show_tracing'(_, _, off).
yap_flag(host_type,X) :-
'$host_type'(X).
@ -570,6 +497,79 @@ yap_flag(host_type,X) :-
),
yap_flag(V, Out).
'$trans_to_lang_flag'(0,cprolog).
'$trans_to_lang_flag'(1,iso).
'$trans_to_lang_flag'(2,sicstus).
'$adjust_language'(cprolog) :-
'$switch_log_upd'(0),
'$syntax_check_mode'(_,off),
'$syntax_check_single_var'(_,off),
'$syntax_check_discontiguous'(_,off),
'$syntax_check_multiple'(_,off),
'$transl_to_on_off'(Y,off), % disable character escapes.
'$set_yap_flags'(12,Y),
'$set_yap_flags'(14,1),
unknown(_,error).
'$adjust_language'(sicstus) :-
'$switch_log_upd'(1),
leash(full),
'$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on),
'$transl_to_on_off'(X1,on),
'$set_yap_flags'(5,X1),
'$force_char_conversion',
'$set_yap_flags'(14,0),
unknown(_,error).
'$adjust_language'(iso) :-
'$switch_log_upd'(2),
'$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on),
'$set_yap_flags'(7,1),
fileerrors,
'$transl_to_on_off'(X1,on),
'$set_yap_flags'(5,X1),
'$force_char_conversion',
'$set_yap_flags'(14,0),
unknown(_,error).
'$transl_to_character_escape_modes'(0,off) :- !.
'$transl_to_character_escape_modes'(0,cprolog).
'$transl_to_character_escape_modes'(1,on) :- !.
'$transl_to_character_escape_modes'(1,iso).
'$transl_to_character_escape_modes'(2,sicstus).
'$convert_upd_sem'(0,immediate).
'$convert_upd_sem'(1,logical).
'$convert_upd_sem'(2,logical_assert).
'$transl_to_true_false'(0,false).
'$transl_to_true_false'(1,true).
'$transl_to_on_off'(0,off).
'$transl_to_on_off'(1,on).
'$transl_to_arity'(X1,X) :- X1 < 0, !, X = unbounded.
'$transl_to_arity'(X,X).
'$transl_to_rounding_function'(0,down).
'$transl_to_rounding_function'(1,toward_zero).
'$transl_to_trl_types'(0,chars).
'$transl_to_trl_types'(1,codes).
'$transl_to_trl_types'(2,atom).
'$yap_flag_show_tracing'(true, _, on) :- !.
'$yap_flag_show_tracing'(_, true, verbose) :- !.
'$yap_flag_show_tracing'(_, _, off).
'$flag_check_alias'(OUT, Alias) :-
stream_property(OUT,[alias(Alias)]), !.
current_prolog_flag(V,Out) :-
(var(V) ; atom(V) ), !,
'$show_yap_flag_opts'(V,NOut),
@ -594,7 +594,7 @@ prolog_flag(F, Old, New) :-
throw(error(instantiation_error,prolog_flag(F,Old,New))).
prolog_flag(F, Old, New) :-
current_prolog_flag(F, Old),
set_prolog_flag(F, Old).
set_prolog_flag(F, New).
prolog_flag(F, Old) :-
current_prolog_flag(F, Old).

4
pl/errors.yap
View File

@ -56,7 +56,7 @@
'$process_error'(Throw) :-
print_message(error,Throw).
print_message(force(Severity), Msg) :- !,
print_message(force(_Severity), Msg) :- !,
print(user_error,Msg).
print_message(Severity, Msg) :-
\+ '$undefined'(user: portray_message(Severity, Msg)),
@ -290,7 +290,7 @@ print_message(help,M) :-
'$output_error_message'(system_error(Message), Where) :-
format(user_error,"[ SYSTEM ERROR- ~w at ~w]~n",
[Message,Where]).
'$output_error_message'(type_error(T,_,Err,M), Where) :-
'$output_error_message'(type_error(T,_,Err,M), _Where) :-
format(user_error,"[ TYPE ERROR- ~w: expected ~w, got ~w ]~n",
[T,Err,M]).
'$output_error_message'(type_error(array,W), Where) :-

6
pl/grammar.yap
View File

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

6
pl/init.yap
View File

@ -20,16 +20,10 @@
% These are pseudo declarations
% so that the user will get a redefining system predicate
G1 ; G2 :- '$execute'((G1;G2)).
G1 | G2 :- '$execute'((G1;G2)).
G1 -> G2 :- '$execute'((G1->G2)).
','(G1,G2) :- '$execute'((G1,G2)).
otherwise.
fail :- fail.
false :- false.
!.
\+ G :- \+ G.
not(G) :- not(G).
(:- G) :- '$execute'(G), !.
'$$!'(CP) :- '$cut_by'(CP).

21
pl/listing.yap
View File

@ -86,7 +86,7 @@ portray_clause(Pred) :-
put(","),
'$aftercomma'(T,IO,I),
'$write_body'(Q,I,',').
'$write_body'((P->Q;S),I,T) :-
'$write_body'((P->Q;S),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
@ -95,7 +95,7 @@ portray_clause(Pred) :-
put(";"),
'$write_body'(S,I,';'),
tab(1), put(")").
'$write_body'((P->Q|S),I,T) :-
'$write_body'((P->Q|S),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
@ -104,35 +104,28 @@ portray_clause(Pred) :-
put("|"),
'$write_body'(S,I,'|'),
tab(1), put(")").
'$write_body'((P->Q),I,T) :-
'$write_body'((P->Q),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
put("-"), put(">"),
'$write_body'(Q,I,'->'),
tab(1), put(")").
'$write_body'((P;Q),I,T) :-
'$write_body'((P;Q),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
put(";"),
'$write_body'(Q,I,';'),
tab(1), put(")").
'$write_body'((P;Q),I,T) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
put(";"),
'$write_body'(Q,I,';'),
tab(1), put(")").
'$write_body'((P|Q),I,T) :-
'$write_body'((P|Q),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
put("|"),
'$write_body'(Q,I,'|'),
tab(1), put(")").
'$write_body'((P|Q),I,T) :-
'$write_body'((P|Q),I,_) :-
!,
nl, tab(I-2), put("("),
'$write_body'(P,I,'('),
@ -169,4 +162,4 @@ portray_clause(Pred) :-
'$list_transform'([X,Y|L],M) :- X == Y, X = '$VAR'(M), !, N is M+1,
'$list_transform'(L,N).
'$list_transform'('$VAR'(-1).L,M) :- !, '$list_transform'(L,M).
'$list_transform'(X.L,M) :- '$list_transform'(L,M).
'$list_transform'(_.L,M) :- '$list_transform'(L,M).

44
pl/modules.yap
View File

@ -41,7 +41,7 @@ use_module(File,Imports) :-
atom(File), !,
'$current_module'(M),
'$find_in_path'(File,X),
( open(X,$csult,Stream), !,
( open(X,'$csult',Stream), !,
'$consulting_file_name'(Stream,TrueFileName),
( '$loaded'(Stream) -> true
;
@ -53,7 +53,7 @@ use_module(File,Imports) :-
close(Stream),
( var(R) -> true; erased(R) -> true; erase(R)),
( '$recorded'('$module','$module'(TrueFileName,Mod,Publics),_) ->
$use_preds(Imports,Publics,Mod,M)
'$use_preds'(Imports,Publics,Mod,M)
;
format(user_error,'[ use_module/2 can not find a module in file ~w]~n',File),
fail
@ -64,7 +64,7 @@ use_module(File,Imports) :-
use_module(library(File),Imports) :- !,
'$current_module'(M),
'$find_in_path'(library(File),X),
( open(X,$csult,Stream), !,
( open(X,'$csult',Stream), !,
'$consulting_file_name'(Stream,TrueFileName),
( '$loaded'(Stream) -> true
;
@ -76,7 +76,7 @@ use_module(library(File),Imports) :- !,
close(Stream),
( var(R) -> true; erased(R) -> true; erase(R)),
( '$recorded'('$module','$module'(TrueFileName,Mod,Publics),_) ->
$use_preds(Imports,Publics,Mod,M)
'$use_preds'(Imports,Publics,Mod,M)
;
format(user_error,'[ use_module/2 can not find a module in file ~w]~n',[File]),
fail
@ -177,7 +177,7 @@ module(N) :-
throw(error(instantiation_error,module(N))).
module(N) :-
atom(N), !,
'$current_module'(Old,N),
'$current_module'(_,N),
'$get_value'('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true),
( recorded('$module','$module'(F,N,[]),_) ->
@ -188,8 +188,8 @@ module(N) :-
throw(error(type_error(atom,N),module(N))).
'$module_dec'(N,P) :-
$current_module(Old,N),
$get_value('$consulting_file',F),
'$current_module'(Old,N),
'$get_value'('$consulting_file',F),
( recordzifnot('$module','$module'(N),_) -> true; true),
recorda('$module','$module'(F,N,P),_),
( '$recorded'('$importing','$importing'(F),_) ->
@ -201,7 +201,7 @@ module(N) :-
'$import'([],_,_) :- !.
'$import'([N/K|L],M,T) :-
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]),
( T = user ->
recordz('$import','$import'(M,_,N,K),_)
@ -216,17 +216,17 @@ module(N) :-
format(user_error,'[Illegal pred specification(~w) in module declaration for module ~w]~n',[PS,M]),
'$import'(L,M,T).
$check_import(M,T,N,K) :-
'$check_import'(M,T,N,K) :-
'$recorded'('$import','$import'(M1,T0,N,K),R), T0 == T, M1 \= M, /* ZP */ !,
format(user_error,'NAME CLASH: ~w was already imported to module ~w;~n',[M1:N/K,T]),
format(user_error,' Do you want to import it from ~w ? [y or n] ',M),
repeat,
get0(C), $skipeol(C),
get0(C), '$skipeol'(C),
( C is "y" -> erase(R), !;
C is "n" -> !, fail;
write(user_error, ' Please answer with ''y'' or ''n'' '), fail
).
$check_import(_,_,_,_).
'$check_import'(_,_,_,_).
% $use_preds(Imports,Publics,Mod,M)
'$use_preds'([],_,_,_) :- !.
@ -299,7 +299,7 @@ $check_import(_,_,_,_).
tell('P0:debug'),
write(X),nl,
tell(F), fail.
'$trace_module'(X).
'$trace_module'(_).
'$trace_module'(X,Y) :- X==Y, !.
'$trace_module'(X,Y) :-
@ -309,7 +309,7 @@ $check_import(_,_,_,_).
portray_clause(X),
portray_clause(Y),
tell(F),fail.
$trace_module(X,Y).
'$trace_module'(_,_).
%
% calling the meta-call expansion facility and expand_goal from
@ -338,7 +338,7 @@ $trace_module(X,Y).
% current module for fixing up meta-call arguments
% current module for predicate
% head variables.
'$module_expansion'(V,call(MM:V),call(MM:V),M,MM,TM,HVars) :- var(V), !.
'$module_expansion'(V,call(MM:V),call(MM:V),_M,MM,_TM,_) :- var(V), !.
'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
@ -353,9 +353,9 @@ $trace_module(X,Y).
'$module_expansion'(false,false,false,_,_,_,_) :- !.
% if I don't know what the module is, I cannot do anything to the goal,
% so I just put a call for later on.
'$module_expansion'(M:G,call(M:G),call(M:G),_,_,_,HVars) :- var(M), !.
'$module_expansion'(M:G,call(M:G),call(M:G),_,_,_,_) :- var(M), !.
% if M1 is given explicitly process G within M1's context.
'$module_expansion'(M:G,G1,GO,Mod,MM,TM,HVars) :- !,
'$module_expansion'(M:G,G1,GO,_Mod,_MM,TM,HVars) :- !,
% is this imported from some other module M1?
( '$imported_pred'(G, M, M1) ->
% continue recursively...
@ -435,7 +435,7 @@ $trace_module(X,Y).
% '$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'(H,[]).
'$module_u_vars'(_,[]).
'$module_u_vars'(0,_,_,[]) :- !.
'$module_u_vars'(I,D,H,[Y|L]) :-
@ -475,14 +475,14 @@ $trace_module(X,Y).
% check if an argument should be expanded
'$do_expand'(V,HVars) :- var(V), !, '$not_in_vars'(V,HVars).
'$do_expand'(M:F,_) :- !, fail.
'$do_expand'(X,_).
'$do_expand'(_:_,_) :- !, fail.
'$do_expand'(_,_).
$not_in_vars(_,[]).
$not_in_vars(V,[X|L]) :- X\==V, $not_in_vars(V,L).
'$not_in_vars'(_,[]).
'$not_in_vars'(V,[X|L]) :- X\==V, '$not_in_vars'(V,L).
current_module(Mod) :-
'$recorded'($module,'$module'(Mod),_).
'$recorded'('$module','$module'(Mod),_).
current_module(Mod,TFN) :-
'$recorded'('$module','$module'(TFN,Mod,_Publics),_).

43
pl/preds.yap
View File

@ -30,9 +30,8 @@ assert(V) :- var(V), !,
throw(error(instantiation_error,assert(V))).
assert(C) :- '$assert'(C,last,_,assert(C)).
'$assert'(V,Where,R,P) :- var(V), !,
'$current_module'(M),
throw(error(instantiation_error,P)).
'$assert'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert'(C,Where,R,P)).
'$assert'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
@ -62,9 +61,8 @@ assert(C) :- '$assert'(C,last,_,assert(C)).
).
'$assert_dynamic'(V,Where,R,P) :- var(V), !,
'$current_module'(M),
throw(error(instantiation_error,P)).
'$assert_dynamic'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert_dynamic'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert_dynamic'(C,Where,R,P)).
'$assert_dynamic'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
@ -103,9 +101,8 @@ assertz_static(V) :- var(V), !,
assertz_static(C) :-
'$assert_static'(C,last,_,assertz_static(C)).
'$assert_static'(V,Where,R,P) :- var(V), !,
'$current_module'(M),
throw(error(instantiation_error,P)).
'$assert_static'(V,_,_,_) :- var(V), !,
throw(error(instantiation_error,assert(V))).
'$assert_static'(M:C,Where,R,P) :- !,
'$mod_switch'(M,'$assert_static'(C,Where,R,P)).
'$assert_static'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !,
@ -133,7 +130,8 @@ assertz_static(C) :-
'$compile_dynamic'((Head:-Body),2,CR),
( '$get_value'('$abol',true)
->
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
'$flags'(H,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true )
;
true
@ -152,6 +150,7 @@ assertz_static(C) :-
'$compile_dynamic'((Head:-Body),0,CR),
( '$get_value'('$abol',true)
->
'$flags'(H,Fl,Fl),
( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ),
( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true )
;
@ -248,6 +247,7 @@ clause(P,Q,R) :-
( '$is_dynamic'(P) ->
'$recordedp'(P,(P:-Q),R)
;
functor(P,N,A),
throw(error(permission_error(access,private_procedure,N/A),
clause(P,Q,R)))
).
@ -278,8 +278,8 @@ retract(C,R) :-
var(R),
'$recordedp'(H,(H:-B),R),
erase(R).
retract(C,R) :-
'$fetch_predicate_indicator_from_clause'(C, PI).
retract(C,_) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
throw(error(permission_error(modify,static_procedure,PI),retract(C))).
'$fetch_predicate_indicator_from_clause'((C :- _), Na/Ar) :- !,
@ -305,7 +305,7 @@ retractall(T) :-
'$erase_all_clauses_for_dynamic'(T) :-
'$recordedp'(T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T) :-
'$recordedp'(T,C,R), fail.
'$recordedp'(T,_,_), fail.
'$erase_all_clauses_for_dynamic'(_).
abolish(N,A) :- var(N), !,
@ -358,19 +358,19 @@ abolish(X) :-
'$check_error_in_predicate_indicator'(S, Msg) :-
S \= _/_, !,
throw(error(type_error(predicate_indicator,S), Msg)).
'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
var(Na), !,
throw(error(instantiation_error, Msg)).
'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
\+ atom(Na), !,
throw(error(type_error(atom,Na), Msg)).
'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
var(Ar), !,
throw(error(instantiation_error, Msg)).
'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
\+ integer(Ar), !,
throw(error(type_error(integer,Ar), Msg)).
'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
Ar < 0, !,
throw(error(domain_error(not_less_than_zero,Ar), Msg)).
% not yet implemented!
@ -383,7 +383,7 @@ abolish(X) :-
throw(error(instantiation_error, Msg)).
'$check_error_in_module'(M, Msg) :-
\+ atom(M), !,
throw(error(type_error(atom,Na), Msg)).
throw(error(type_error(atom,M), Msg)).
'$old_abolish'(V) :- var(V), !,
'$abolish_all_old'.
@ -422,6 +422,7 @@ abolish(X) :-
% this code has to be here because of abolish/2
'$abolishs'(G) :-
'$has_yap_or', !,
functor(G,A,N),
throw(error(permission_error(modify,static_procedure,A/N),abolish(G))).
'$abolishs'(G) :-
'$purge_clauses'(G),
@ -455,13 +456,13 @@ dynamic(X) :-
F /\ 16'400 =:= 16'400, '$undefined'(T) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,F,NF);
F/\16'8 =:= 16'8 -> true ;
throw(error(permission_error(modify,static_procedure,A/N),dynamic(A/N)))
), $flags(T,F1,F1).
), '$flags'(T,F1,F1).
'$dynamic2'(X) :-
throw(error(type_error(callable,X),dynamic(X))).
'$logical_updatable'(A/N) :- integer(N), atom(A), !,
functor(T,A,N), $flags(T,F,F),
functor(T,A,N), '$flags'(T,F,F),
( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,F,NF);
'$is_dynamic'(T) -> true;
F /\ 16'400 =:= 16'400 , '$undefined'(T) -> NF is F \/ 0x8, '$flags'(T,F,NF);

14
pl/setof.yap
View File

@ -23,7 +23,7 @@
:- op(50,xfx,same).
Variable^Goal :-
_^Goal :-
'$execute'(Goal).
@ -75,11 +75,11 @@ findall(Template, Generator, Answers, SoFar) :-
% by getting all answers
'$collect_with_common_vars'(Ref, VarList, SoFar, Solution) :-
'$db_dequeue'(Ref, BDEntry), !,
BDEntry = Key-Term,
BDEntry = Key-_,
Solution = [BDEntry|Answers],
'$variables_in_term'(Key, _, VarList),
'$collect_with_common_vars'(Ref, VarList, SoFar, Answers).
'$collect_with_common_vars'(Ref, VarList, Solution, Solution).
'$collect_with_common_vars'(_, _, Solution, Solution).
% This is the setof predicate
@ -154,11 +154,11 @@ bagof(Template, Generator, Bag) :-
'$excess_vars'(bagof(X,P,S), Y, L0, L) :- !,
'$variables_in_term'(X+Y, [], NY),
'$excess_vars'((P,S), NY, L0, L).
'$excess_vars'(findall(X,P,S), Y, L0, L) :- !,
'$excess_vars'(findall(_,_,S), Y, L0, L) :- !,
'$excess_vars'(S, Y, L0, L).
'$excess_vars'(findall(X,P,S0,S), Y, L0, L) :- !,
'$excess_vars'(findall(_,_,_,S), Y, L0, L) :- !,
'$excess_vars'(S, Y, L0, L).
'$excess_vars'(\+G, _, L0, LF) :- !,
'$excess_vars'(\+_, _, L0, LF) :- !,
L0 = LF.
'$excess_vars'(_:G, Y, L0, LF) :- !,
'$excess_vars'(G, Y, L0, LF).
@ -171,7 +171,7 @@ bagof(Template, Generator, Bag) :-
'$excess_vars'(T1, X, L0, L1),
'$recurse_for_excess_vars'(LArgs, X, L1, L).
'$doesnt_include'([], X).
'$doesnt_include'([], _).
'$doesnt_include'([Y|L], X) :-
Y \== X,
'$doesnt_include'(L, X).

14
pl/sockets.yap
View File

@ -35,7 +35,7 @@ socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
'$check_list'(V,G) :- var(V), !,
throw(error(instantiation_error,G)).
'$check_list'([],_) :- !.
'$check_list'([Opt|T],G) :- !,
'$check_list'([_|T],G) :- !,
  '$check_list'(T,G).
'$check_io_opts'(T,G) :-
throw(error(type_error(list,T),G)).
@ -44,13 +44,13 @@ socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
'$select_cp_fds'([_-Fd|L], Fds0, [Fd|Fds]) :-
'$select_cp_fds'(L, Fds0, Fds).
'$check_select_time'(V, Sec, USec, Goal) :-
'$check_select_time'(V, _, _, Goal) :-
var(V), !,
throw(error(instantiation_error,G)).
throw(error(instantiation_error,Goal)).
'$check_select_time'(off, -1, -1, _).
'$check_select_time'(Sec0:Usec0, Sec, USec, _) :-
'$check_select_time'(Sec0:USec0, Sec, USec, _) :-
Sec is Sec0,
Usec0 is Usec,
USec is USec0,
Sec > 0, USec > 0.
'$cp_socket_fds'([], Fds, [], Fds).
@ -60,7 +60,7 @@ socket_select(Socks, OutSocks, TimeOut, Streams, OutStreams) :-
socket_accept(Socket, Client, Stream),
'$cp_socket_fds'(Scks, Fds, Out, StrFds).
'$cp_stream_fds'([], Fds, []).
'$cp_stream_fds'([], _, []).
'$cp_stream_fds'([_|Strs], [[]|Fds], Out) :- !,
'$cp_stream_fds'(Strs, Fds, Out).
'$cp_stream_fds'([Stream|Strs], [Stream|Fds], [Stream|Out]) :-
@ -75,7 +75,7 @@ socket_buffering(Sock, Flag, InSize, OutSize) :-
'$convert_sock_buff'(OutSize, OutNumb).
'$convert_sock_buff'(unbuf, 1) :- !.
'$convert_sock_buff'(fullbuf, InNumb).
'$convert_sock_buff'(fullbuf, _).

14
pl/strict_iso.yap
View File

@ -12,10 +12,10 @@
'$iso_check_goal'((G1;G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1;G2),G0),
'$iso_check_a_goal'(G2,(G1;G2),G0).
'$iso_check_goal'((G1->G2),(G1->G2),G0) :- !,
'$iso_check_goal'((G1->G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1->G2),G0),
'$iso_check_a_goal'(G2,(G1->G2),G0).
'$iso_check_goal'(!,G0) :- !.
'$iso_check_goal'(!,_) :- !.
'$iso_check_goal'((G1|G2),G0) :-
'$access_yap_flags'(9,1), !,
throw(error(domain_error(builtin_procedure,(G1|G2)), call(G0))).
@ -30,7 +30,7 @@
->
true
;
throw(error(domain_error(builtin_procedure,G), G))
throw(error(domain_error(builtin_procedure,G), call(G0)))
).
'$iso_check_goal'(_,_).
@ -55,7 +55,7 @@
'$iso_check_a_goal'((_|_),E,G0) :-
'$access_yap_flags'(9,1), !,
throw(error(domain_error(builtin_procedure,E), call(G0))).
'$iso_check_a_goal'((G1|G2),_,G0) :- !.
'$iso_check_a_goal'((_|_),_,_) :- !.
'$iso_check_a_goal'(G,_,G0) :-
'$access_yap_flags'(9,1),
'$system_predicate'(G),
@ -64,13 +64,13 @@
->
true
;
throw(error(domain_error(builtin_procedure,G), G))
throw(error(domain_error(builtin_procedure,G), call(G0)))
).
'$iso_check_a_goal'(_,_,_).
'$check_iso_strict_clause'((G:-B)) :- !,
'$check_iso_strict_clause'((_:-B)) :- !,
'$check_iso_strict_body'(B).
'$check_iso_strict_clause'(G).
'$check_iso_strict_clause'(_).
'$check_iso_strict_body'((B1,B2)) :- !,
'$check_iso_strict_body'(B1),

12
pl/tabling.yap
View File

@ -21,7 +21,7 @@ table(X) :- var(X), !,
fail.
table((A,B)) :- !, table(A), table(B).
table(A/N) :- integer(N), atom(A), !,
functor(T,A,N), $flags(T,F,F),
functor(T,A,N), '$flags'(T,F,F),
(
X is F /\ 8'000100, X =\= 0, !,
write(user_error, '[ Warning: '),
@ -29,7 +29,7 @@ table(A/N) :- integer(N), atom(A), !,
write(user_error, ' is already declared as table ]'),
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, A/N),
@ -49,9 +49,9 @@ show_trie(X) :- var(X), !,
nl(user_error),
fail.
show_trie(A/N) :- integer(N), atom(A), !,
functor(T,A,N), $flags(T,F,F),
functor(T,A,N), '$flags'(T,F,F),
(
X is F /\ 8'000100, X =\= 0, !, $show_trie(T,_)
X is F /\ 8'000100, X =\= 0, !, '$show_trie'(T,_)
;
write(user_error, '[ Error: '),
write(user_error, A/N),
@ -71,9 +71,9 @@ abolish_trie(X) :- var(X), !,
nl(user_error),
fail.
abolish_trie(A/N) :- integer(N), atom(A), !,
functor(T,A,N), $flags(T,F,F),
functor(T,A,N), '$flags'(T,F,F),
(
X is F /\ 8'000100, X =\= 0, !, $abolish_trie(T)
X is F /\ 8'000100, X =\= 0, !, '$abolish_trie'(T)
;
write(user_error, '[ Error: '),
write(user_error, A/N),

47
pl/utils.yap
View File

@ -17,12 +17,12 @@
once(G) :- '$execute'(G), !.
if(X,Y,Z) :-
if(X,Y,_Z) :-
CP is '$last_choice_pt',
'$execute'(X),
'$clean_ifcp'(CP),
'$execute'(Y).
if(X,Y,Z) :-
if(_X,_Y,Z) :-
'$execute'(Z).
@ -341,6 +341,8 @@ current_atom(A) :- % check
current_atom(A) :- % generate
'$current_atom'(A).
current_predicate(A,T) :- var(T), !, % only for the predicate
'$current_predicate_no_modules'(A,T).
current_predicate(A,M:T) :- % module specified
var(M), !,
current_module(M),
@ -352,6 +354,8 @@ current_predicate(A,M:T) :- % module specified
current_predicate(A,T) :- % only for the predicate
'$current_predicate_no_modules'(A,T).
current_predicate(F) :- var(F), !, % only for the predicate
'$current_predicate3'(F).
current_predicate(M:F) :- % module specified
var(M), !,
current_module(M),
@ -364,13 +368,9 @@ current_predicate(F) :- % only for the predicate
'$current_predicate3'(F).
system_predicate(A,P) :-
'$mod_switch'(prolog,'$current_predicate_no_modules'(A,T)),
'$mod_switch'(prolog,'$current_predicate_no_modules'(A,P)),
\+ '$hidden'(A).
'$system_predicate'(Pred) :-
'$flags'(Pred,Flags,_),
Flags /\ 8'40000 =\= 0.
system_predicate(P) :- '$system_predicate'(P).
'$current_predicate_no_modules'(A,T) :-
@ -402,7 +402,7 @@ statistics :-
'$inform_gc'(NOfGC,TotGCTime,TotGCSize),
'$statistics'(Runtime,CPUtime,Walltime,HpSpa,HpInUse,HpMax,TrlSpa, TrlInUse,TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize).
'$statistics'(Runtime,CPUtime,Walltime,HpSpa,HpInUse,HpMax,TrlSpa, TrlInUse,TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize) :-
'$statistics'(Runtime,CPUtime,Walltime,HpSpa,HpInUse,_HpMax,TrlSpa, TrlInUse,_TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize) :-
TotalMemory is HpSpa+StkSpa+TrlSpa,
format(user_error,"memory (total)~t~d bytes~35+~n", [TotalMemory]),
format(user_error," program space~t~d bytes~35+", [HpSpa]),
@ -573,15 +573,15 @@ predicate_property(Pred,Prop) :-
'$is_multifile'(N,A).
'$predicate_property'(P,imported_from(Mod)) :-
functor(P,N,A),
'$recorded'($module,$module(_TFN,Mod,Publics),_),
$member(N/A,Publics). /* defined in modules.yap */
'$recorded'('$module','$module'(_TFN,Mod,Publics),_),
'$member'(N/A,Publics). /* defined in modules.yap */
'$predicate_property'(P,public) :-
'$is_public'(P).
'$predicate_property'(P,exported) :-
functor(P,N,A),
$current_module(M),
'$recorded'($module,$module(_TFN,M,Publics),_),
$member(N/A,Publics). /* defined in modules.yap */
'$current_module'(M),
'$recorded'('$module','$module'(_TFN,M,Publics),_),
'$member'(N/A,Publics). /* defined in modules.yap */
%%% Some "dirty" predicates
@ -593,8 +593,8 @@ predicate_property(Pred,Prop) :-
'$pred_exists'(Pred) :- \+ '$undefined'(Pred).
grow_heap(X) :- $grow_heap(X).
grow_stack(X) :- $grow_stack(X).
grow_heap(X) :- '$grow_heap'(X).
grow_stack(X) :- '$grow_stack'(X).
%
% gc() expects to be called from "call". Make sure it has an
@ -615,7 +615,7 @@ profile_data(P, Parm, Data) :- var(P), !,
profile_data(M:P, Parm, Data) :- var(M), !,
throw(error(instantiation_error,profile_data(M:P, Parm, Data))).
profile_data(M:P, Parm, Data) :- var(M), !,
'$mod_switch'(Mod,'$profile_data'(P, Parm, Data)).
'$mod_switch'(M,'$profile_data'(P, Parm, Data)).
profile_data(P, Parm, Data) :-
'$profile_data'(P, Parm, Data).
@ -735,21 +735,6 @@ sub_atom(At, Bef, Size, After, SubAt) :-
X11 is X1+1,
'$range_var'(X11,X2,XF).
current_predicate(V) :- var(V), !,
current_predicate(_,S),
functor(S,Na,Ar),
V = Na/Ar.
current_predicate(Na/Ar) :- !,
current_predicate(Na,S),
\+ '$system_predicate'(S),
functor(S,Na,Ar).
current_predicate(M:X) :- !,
'$mod_switch'(M,current_predicate(X)).
current_predicate(T) :-
throw(error(type_error(predicate_indicator,T),current_predicate(T))).
'$singletons_in_term'(T,VL) :-
'$variables_in_term'(T,[],V10),
'$sort'(V10, V1),

7
pl/yapor.yap
View File

@ -15,8 +15,9 @@
* *
*************************************************************************/
'$parallel_query'(G,[]) :- !, '$start_yapor', '$execute'(G), !, $parallel_yes_answer.
'$parallel_query'(G,V) :- '$start_yapor', '$execute'(G), $parallel_new_answer(V).
'$parallel_query'(G,[]) :- !, '$start_yapor', '$execute'(G), !,
'$parallel_yes_answer'.
'$parallel_query'(G,V) :- '$start_yapor', '$execute'(G), '$parallel_new_answer'(V).
% ***************************
% * -------- YAPOR -------- *
@ -79,7 +80,7 @@ parallel(A/N) :- integer(N), atom(A), !,
write(user_error, ' is already declared as sequential ]'),
nl(user_error)
;
X is F /\ 8'170000, X =:= 0, !, $sequential(T)
X is F /\ 8'170000, X =:= 0, !, '$sequential'(T)
;
write(user_error, '[ Error: '),
write(user_error, A/N),

38
pl/yio.yap
View File

@ -215,16 +215,10 @@ open(F,T,S,Opts) :-
throw(error(instantiation_error,G)).
'$check_open_eof_action_arg'(error,_) :- !.
'$check_open_eof_action_arg'(eof_code,_) :- !.
'$check_open_eof_action_arg'(reset,G) :- !.
'$check_open_eof_action_arg'(reset,_) :- !.
'$check_open_eof_action_arg'(X,G) :-
throw(error(domain_error(io_mode,eof_action(X)),G)).
'$check_open_alias_arg'(T, G) :- var(X), !,
throw(error(instantiation_error,G)).
'$check_open_eof_action_arg'(T,_) :- atom(T), !.
'$check_open_alias_arg'(T, G) :- var(X), !,
throw(error(type_error(atom,T),G)).
'$check_read_syntax_errors_arg'(X, G) :- var(X), !,
throw(error(instantiation_error,G)).
'$check_read_syntax_errors_arg'(dec10,_) :- !.
@ -265,7 +259,7 @@ open(F,T,S,Opts) :-
'$check_write_max_depth'(X, G) :- var(X), !,
throw(error(instantiation_error,G)).
'$check_write_max_depth'(I,_) :- integer(I), I > 0, !.
'$check_write_portrayed'(X,G) :-
'$check_write_max_depth'(X,G) :-
throw(error(domain_error(write_option,max_depth(X)),G)).
set_input(Stream) :-
@ -343,7 +337,7 @@ read_term(Stream, T, Options) :-
%
'$preprocess_read_terms_options'([]).
'$preprocess_read_terms_options'([syntax_errors(NewVal)|L]) :- !,
'$get_read_error_handler'(OldVal).
'$get_read_error_handler'(OldVal),
'$set_value'('$read_term_error_handler', OldVal),
'$set_read_error_handler'(NewVal),
'$preprocess_read_terms_options'(L).
@ -363,12 +357,12 @@ read_term(Stream, T, Options) :-
'$postprocess_read_terms_option'(syntax_errors(_), _, _) :-
'$get_value'('$read_term_error_handler', OldVal),
'$set_read_error_handler'(OldVal).
'$postprocess_read_terms_option'(variable_names(Vars), T, VL) :-
'$postprocess_read_terms_option'(variable_names(Vars), _, VL) :-
'$read_term_non_anonymous'(VL, Vars).
'$postprocess_read_terms_option'(singletons(Val), T, VL) :-
'$singletons_in_term'(T, Val1),
'$fetch_singleton_names'(Val1,VL,Val).
'$postprocess_read_terms_option'(variables(Val), T, VL) :-
'$postprocess_read_terms_option'(variables(Val), T, _) :-
'$variables_in_term'(T, [], Val).
%'$postprocess_read_terms_option'(cycles(Val), _, _).
@ -393,7 +387,7 @@ read_term(Stream, T, Options) :-
% V1 @> V2,
'$fetch_singleton_names'(Ss, Ns, NSs).
'$add_singleton_if_no_underscore'([95|_],V2,NSs,NSs) :- !.
'$add_singleton_if_no_underscore'([95|_],_,NSs,NSs) :- !.
'$add_singleton_if_no_underscore'(Na,V2,NSs,[(Name=V2)|NSs]) :-
atom_codes(Name, Na).
@ -459,25 +453,25 @@ write_term(_,_,_).
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([quoted(false)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 /\ 14,
'$process_wt_opts'(Opts, Flag0, Flag, CallBacks).
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([ignore_ops(true)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 \/ 2,
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([ignore_ops(false)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 /\ 13,
'$process_wt_opts'(Opts, Flag0, Flag, CallBacks).
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([numbervars(true)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 \/ 4,
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([numbervars(false)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 /\ 11,
'$process_wt_opts'(Opts, Flag0, Flag, CallBacks).
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([portrayed(true)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 \/ 8,
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([portrayed(false)|Opts], Flag0, Flag, CallBacks) :-
FlagI is Flag0 /\ 7,
'$process_wt_opts'(Opts, Flag0, Flag, CallBacks).
'$process_wt_opts'(Opts, FlagI, Flag, CallBacks).
'$process_wt_opts'([max_depth(D)|Opts], Flag0, Flag, [max_depth(D1,D0)|CallBacks]) :-
write_depth(D1,D0),
write_depth(D,D),
@ -751,7 +745,7 @@ stream_position(A,N,M) :-
atom(A),
current_stream(_,_,S), '$user_file_name'(S,A), !,
'$stream_position'(S,N,M).
stream_position(S,N) :-
stream_position(S,N,M) :-
'$stream_position'(S,N,M).
'$stream_position'(S,N,M) :-
@ -812,7 +806,7 @@ stream_property(Stream, Props) :-
'$check_stream_props'(Prop, [Prop]).
'$process_stream_properties'([], Stream, F, Mode).
'$process_stream_properties'([], _, _, _).
'$process_stream_properties'([file_name(F)|Props], Stream, F, Mode) :-
'$process_stream_properties'(Props, Stream, F, Mode).
'$process_stream_properties'([mode(Mode)|Props], Stream, F, Mode) :-
@ -849,21 +843,21 @@ stream_property(Stream, Props) :-
'$past_eof'(Stream), !.
'$show_stream_eof'(Stream, at) :-
'$peek'(Stream,N), N = -1, !.
'$show_stream_eof'(Stream, not).
'$show_stream_eof'(_, not).
'$show_stream_eof_action'(Fl, error) :-
Fl /\ 16'0200 =:= 16'0200, !.
'$show_stream_eof_action'(Fl, reset) :-
Fl /\ 16'0400 =:= 16'0400, !.
'$show_stream_eof_action'(Fl, eof_code).
'$show_stream_eof_action'(_, eof_code).
'$show_stream_reposition'(Fl, true) :-
Fl /\ 16'2000 =:= 16'2000, !.
'$show_stream_reposition'(Fl, false).
'$show_stream_reposition'(_, false).
'$show_stream_type'(Fl, binary) :-
Fl /\ 16'0100 =:= 16'0100, !.
'$show_stream_type'(Fl, text).
'$show_stream_type'(_, text).
at_end_of_stream :-
current_input(S),