From b289d9ac9cfa10deba068eff486f4b45ff81e233 Mon Sep 17 00:00:00 2001 From: vsc Date: Thu, 15 Nov 2001 00:01:43 +0000 Subject: [PATCH] new module system. BEWARE! BEWARE! BEWARE! git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@177 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/absmi.c | 112 +++++---- C/adtdefs.c | 108 +++----- C/amasm.c | 4 +- C/bb.c | 68 +++-- C/c_interface.c | 10 +- C/cdmgr.c | 521 +++++++++++++++++--------------------- C/compiler.c | 115 +++------ C/computils.c | 12 +- C/corout.c | 4 +- C/dbase.c | 93 +++---- C/exec.c | 299 +++++++++------------- C/grow.c | 4 - C/heapgc.c | 2 - C/init.c | 48 ++-- C/load_foreign.c | 6 +- C/modules.c | 18 +- C/save.c | 7 +- C/stdpreds.c | 55 ++-- C/tracer.c | 2 +- C/write.c | 4 +- CHR/Makefile.in | 8 +- CLPQR/Makefile.in | 34 +-- CLPQR/clpq/nfq.yap | 2 +- CLPQR/clpqr/bv.yap | 20 +- CLPQR/clpqr/expand.yap | 1 + CLPQR/clpqr/monash.pl | 2 +- CLPQR/clpr.pl | 1 + CLPQR/clpr.yap | 22 +- CLPQR/clpr/arith_r.pl | 1 + CLPQR/clpr/class.pl | 1 + CLPQR/clpr/geler.yap | 1 + CLPQR/clpr/nfr.yap | 3 +- H/Heap.h | 7 +- H/Regs.h | 7 +- H/Yapproto.h | 21 +- H/compile.h | 2 +- Makefile.in | 2 +- OPTYap/opt.preds.c | 77 ++++-- library/atts.yap | 4 +- m4/Yatom.h.m4 | 7 +- pl/boot.yap | 267 ++++++++++---------- pl/checker.yap | 116 +++++---- pl/consult.yap | 12 +- pl/corout.yap | 25 +- pl/debug.yap | 542 ++++++++++++++++++--------------------- pl/depth_bound.yap | 183 -------------- pl/directives.yap | 74 +++--- pl/errors.yap | 4 +- pl/grammar.yap | 7 +- pl/init.yap | 6 +- pl/listing.yap | 42 ++-- pl/modules.yap | 67 +++-- pl/preds.yap | 558 ++++++++++++++++++++++------------------- pl/tabling.yap | 53 ++-- pl/utils.yap | 308 ++++++++++------------- pl/yapor.yap | 39 +-- pl/yio.yap | 4 +- 57 files changed, 1859 insertions(+), 2163 deletions(-) diff --git a/C/absmi.c b/C/absmi.c index 568ca9095..b5a6451c7 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -1789,7 +1789,7 @@ absmi(int inp) NoStackComitY: /* find something to fool S */ if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) { - SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2)); + SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0)); PREG = NEXTOP(PREG,x); XREGS[0] = XREG(PREG->u.y.y); goto creep_either; @@ -1801,7 +1801,7 @@ absmi(int inp) NoStackComitX: /* find something to fool S */ if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) { - SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,2)); + SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0)); PREG = NEXTOP(PREG,x); #if USE_THREADED_CODE if (PREG->opc == (OPCODE)OpAddress[_fcall]) @@ -1827,7 +1827,7 @@ absmi(int inp) /* don't forget I cannot creep at ; */ NoStackEither: /* find something to fool S */ - SREG = (CELL *)RepPredProp(GetPredProp(AtomRestoreRegs,1)); + SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,1),0)); #ifdef YAPOR /* abort_optyap("NoStackCall in function absmi"); */ if (HeapTop > GlobalBase - MinHeapGap) @@ -5948,7 +5948,7 @@ absmi(int inp) at = FullLookupAtom("$undefp"); { - Prop p = GetPredProp (at, 1); + Prop p = GetPredPropByFunc(MkFunctor(at, 1),0); if (p == NIL) { CFREG = CalculateStackGap(); FAIL(); @@ -9557,7 +9557,7 @@ absmi(int inp) Op(p_dif, e); #ifdef LOW_LEVEL_TRACER if (do_low_level_trace) - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("\\="),2)),XREGS+1); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("\\="),2),0)),XREGS+1); #endif /* LOW_LEVEL_TRACE */ BEGD(d0); BEGD(d1); @@ -9651,7 +9651,7 @@ absmi(int inp) Op(p_eq, e); #ifdef LOW_LEVEL_TRACER if (do_low_level_trace) - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("=="),2)),XREGS+1); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("=="),2),0)),XREGS+1); #endif /* LOW_LEVEL_TRACE */ BEGD(d0); BEGD(d1); @@ -9775,7 +9775,7 @@ absmi(int inp) H[0] = XREG(PREG->u.xxx.x1); H[1] = XREG(PREG->u.xxx.x2); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -9864,7 +9864,7 @@ absmi(int inp) H[0] = t; H[1] = XREG(PREG->u.xxc.xi); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H); H = Ho; } #endif /* LOW_LEVEL_TRACE */ @@ -9935,7 +9935,7 @@ absmi(int inp) H[0] = XREG(PREG->u.yxx.x1); H[1] = XREG(PREG->u.yxx.x2); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10038,7 +10038,7 @@ absmi(int inp) H[0] = t; H[1] = XREG(PREG->u.yxc.xi); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("arg"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("arg"),3),0)),H); H = Ho; } #endif /* LOW_LEVEL_TRACE */ @@ -10125,7 +10125,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.xxx.x1); H[2] = XREG(PREG->u.xxx.x2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ /* We have to build the structure */ @@ -10230,7 +10230,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.xcx.c); H[2] = XREG(PREG->u.xcx.xi); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10325,7 +10325,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.xxc.xi); H[2] = ti; - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); H = hi; } #endif /* LOW_LEVEL_TRACE */ @@ -10410,7 +10410,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.yxx.x1); H[2] = XREG(PREG->u.yxx.x2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ /* We have to build the structure */ @@ -10533,7 +10533,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.ycx.c); H[2] = XREG(PREG->u.ycx.xi); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ /* We have to build the structure */ @@ -10650,7 +10650,7 @@ absmi(int inp) RESET_VARIABLE(H); H[1] = XREG(PREG->u.yxc.xi); H[2] = ti; - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); H = hi; } #endif /* LOW_LEVEL_TRACE */ @@ -10758,7 +10758,7 @@ absmi(int inp) H[0] = XREG(PREG->u.xxx.x); RESET_VARIABLE(H+1); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10804,7 +10804,7 @@ absmi(int inp) H[0] = XREG(PREG->u.xyx.x); RESET_VARIABLE(H+1); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10853,7 +10853,7 @@ absmi(int inp) H[0] = XREG(PREG->u.yxx.x2); RESET_VARIABLE(H+1); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10902,7 +10902,7 @@ absmi(int inp) H[0] = XREG(PREG->u.yyx.x); RESET_VARIABLE(H+1); RESET_VARIABLE(H+2); - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),H); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),H); } #endif /* LOW_LEVEL_TRACE */ BEGD(d0); @@ -10951,7 +10951,7 @@ absmi(int inp) Op(p_functor, e); #ifdef LOW_LEVEL_TRACER if (do_low_level_trace) - low_level_trace(enter_pred,RepPredProp(GetPredProp(LookupAtom("functor"),3)),XREGS+1); + low_level_trace(enter_pred,RepPredProp(GetPredPropByFunc(MkFunctor(LookupAtom("functor"),3),0)),XREGS+1); #endif /* LOW_LEVEL_TRACE */ restart_functor: BEGD(d0); @@ -11135,24 +11135,33 @@ absmi(int inp) BOp(p_execute, sla); { PredEntry *pen; + int mod = IntOfTerm(ARG2); CACHE_Y_AS_ENV(Y); BEGD(d0); d0 = ARG1; if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); } deref_head(d0, execute_unk); execute_nvar: if (IsApplTerm(d0)) { Functor f = FunctorOfTerm(d0); if (IsExtensionFunctor(f)) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_nvar; } - pen = RepPredProp(PredPropByFunc(f, ARG2)); + pen = RepPredProp(PredPropByFunc(f, mod)); if (pen->PredFlags & MetaPredFlag) { - d0 = ExecuteCallMetaCall(); + if (f == FunctorModule) { + Term tmod = LookupModule(ArgOfTerm(1,d0)); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + d0 = ArgOfTerm(2,d0); + goto execute_nvar; + } + } + d0 = ExecuteCallMetaCall(mod); goto execute_nvar; } BEGP(pt1); @@ -11174,9 +11183,9 @@ absmi(int inp) ENDP(pt1); CACHE_A1(); } else if (IsAtomTerm(d0)) { - pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), ARG2)); + pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod)); } else { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_nvar; } @@ -11230,7 +11239,7 @@ absmi(int inp) BEGP(pt1); deref_body(d0, pt1, execute_unk, execute_nvar); - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_nvar; ENDP(pt1); ENDD(d0); @@ -11248,24 +11257,34 @@ absmi(int inp) BOp(p_execute_within, sla); { PredEntry *pen; + int mod = CurrentModule; CACHE_Y_AS_ENV(Y); BEGD(d0); d0 = ARG1; if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); } deref_head(d0, execute_within_unk); execute_within_nvar: if (IsApplTerm(d0)) { Functor f = FunctorOfTerm(d0); if (IsExtensionFunctor(f)) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_within_nvar; } - pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr)); + pen = RepPredProp(PredPropByFunc(f, mod)); if (pen->PredFlags & MetaPredFlag) { - d0 = ExecuteCallMetaCall(); + if (f == FunctorModule) { + Term tmod; + tmod = ArgOfTerm(1,d0); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + d0 = ArgOfTerm(2,d0); + goto execute_within_nvar; + } + } + d0 = ExecuteCallMetaCall(mod); goto execute_within_nvar; } BEGP(pt1); @@ -11310,9 +11329,9 @@ absmi(int inp) PREG = NEXTOP(PREG, sla); JMPNext(); }else - pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), *CurrentModulePtr)); + pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod)); } else { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_within_nvar; } @@ -11366,7 +11385,7 @@ absmi(int inp) BEGP(pt1); deref_body(d0, pt1, execute_within_unk, execute_within_nvar); - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto execute_within_nvar; ENDP(pt1); ENDD(d0); @@ -11383,24 +11402,33 @@ absmi(int inp) BOp(p_last_execute_within, sla); { PredEntry *pen; + int mod = CurrentModule; CACHE_Y_AS_ENV(Y); BEGD(d0); d0 = ARG1; if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); } deref_head(d0, last_execute_within_unk); last_execute_within_nvar: if (IsApplTerm(d0)) { Functor f = FunctorOfTerm(d0); if (IsExtensionFunctor(f)) { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto last_execute_within_nvar; } - pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr)); + pen = RepPredProp(PredPropByFunc(f, mod)); if (pen->PredFlags & MetaPredFlag) { - d0 = ExecuteCallMetaCall(); + if (f == FunctorModule) { + Term tmod = ArgOfTerm(1,d0); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + d0 = ArgOfTerm(2,d0); + goto last_execute_within_nvar; + } + } + d0 = ExecuteCallMetaCall(mod); goto last_execute_within_nvar; } BEGP(pt1); @@ -11445,9 +11473,9 @@ absmi(int inp) PREG = NEXTOP(PREG, sla); JMPNext(); }else - pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), *CurrentModulePtr)); + pen = RepPredProp(PredPropByAtom(AtomOfTerm(d0), mod)); } else { - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto last_execute_within_nvar; } @@ -11489,7 +11517,7 @@ absmi(int inp) BEGP(pt1); deref_body(d0, pt1, last_execute_within_unk, last_execute_within_nvar); - d0 = ExecuteCallMetaCall(); + d0 = ExecuteCallMetaCall(mod); goto last_execute_within_nvar; ENDP(pt1); ENDD(d0); diff --git a/C/adtdefs.c b/C/adtdefs.c index 25a3fd9b9..06142a134 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -22,8 +22,8 @@ static char SccsId[] = "%W% %G%"; #define ADTDEFS_C #include "Yap.h" -Prop STD_PROTO(PredPropByFunc,(Functor, Term)); -Prop STD_PROTO(PredPropByAtom,(Atom, Term)); +Prop STD_PROTO(PredPropByFunc,(Functor, SMALLUNSGN)); +Prop STD_PROTO(PredPropByAtom,(Atom, SMALLUNSGN)); #include "Yatom.h" #include "Heap.h" #include "yapio.h" @@ -263,22 +263,7 @@ GetAProp(Atom a, PropFlags kind) } inline static Prop -UnlockedFunctorGetPredProp(Functor f, Term cur_mod) - /* get predicate entry for ap/arity; */ -{ - Prop p0; - FunctorEntry *fe = (FunctorEntry *)f; - PredEntry *p; - - p = RepPredProp(p0 = fe->PropsOfFE); - while (p0 && (/* p->KindOfPE != PEProp || only preds in here */ - (p->ModuleOfPred != cur_mod && p->ModuleOfPred))) - p = RepPredProp(p0 = p->NextOfPE); - return (p0); -} - -inline static Prop -GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod) +GetPredPropByAtomHavingLock(AtomEntry* ae, int cur_mod) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; @@ -296,7 +281,7 @@ GetPredPropByAtomHavingLock(AtomEntry* ae, Term cur_mod) } Prop -GetPredPropByAtom(Atom at, Term cur_mod) +GetPredPropByAtom(Atom at, int cur_mod) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; @@ -309,39 +294,39 @@ GetPredPropByAtom(Atom at, Term cur_mod) } -Prop -GetPredProp(Atom ap, unsigned int arity) - /* get predicate entry for ap/arity; */ +static inline Prop +GetPredPropByFuncHavingLock(Functor f, SMALLUNSGN cur_mod) +/* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; - AtomEntry *ae = RepAtom(ap); - Functor f; + FunctorEntry *fe = (FunctorEntry *)f; - if (arity == 0) - return(GetPredPropByAtom(ap, *CurrentModulePtr)); - WRITE_LOCK(ae->ARWLock); - f = InlinedUnlockedMkFunctor(ae, arity); - WRITE_UNLOCK(ae->ARWLock); - READ_LOCK(f->FRWLock); - p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr); - READ_UNLOCK(f->FRWLock); - return (p0); + p0 = fe->PropsOfFE; + while (p0) { + PredEntry *p = RepPredProp(p0); + if (/* p->KindOfPE != 0 || only props */ + (p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) { + return (p0); + } + p0 = p->NextOfPE; + } + return(NIL); } Prop -GetPredPropByFunc(Functor f, Term t) +GetPredPropByFunc(Functor f, int cur_mod) /* get predicate entry for ap/arity; */ { Prop p0; READ_LOCK(f->FRWLock); - p0 = UnlockedFunctorGetPredProp(f, t); + p0 = GetPredPropByFuncHavingLock(f, cur_mod); READ_UNLOCK(f->FRWLock); return (p0); } Prop -GetPredPropHavingLock(Atom ap, unsigned int arity) +GetPredPropHavingLock(Atom ap, unsigned int arity, SMALLUNSGN mod) /* get predicate entry for ap/arity; */ { Prop p0; @@ -349,11 +334,11 @@ GetPredPropHavingLock(Atom ap, unsigned int arity) Functor f; if (arity == 0) { - GetPredPropByAtomHavingLock(ae, *CurrentModulePtr); + GetPredPropByAtomHavingLock(ae, mod); } f = InlinedUnlockedMkFunctor(ae, arity); READ_LOCK(f->FRWLock); - p0 = UnlockedFunctorGetPredProp(f, *CurrentModulePtr); + p0 = GetPredPropByFuncHavingLock(f, mod); READ_UNLOCK(f->FRWLock); return (p0); } @@ -388,11 +373,12 @@ GetExpPropHavingLock(AtomEntry *ae, unsigned int arity) } Prop -NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) +NewPredPropByFunctor(FunctorEntry *fe, SMALLUNSGN cur_mod) { Prop p0; PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p)); - Int m = IntOfTerm(cur_mod); + + /* printf("entering %s:%s/%d\n", RepAtom(AtomOfTerm(ModuleName[cur_mod]))->StrOfAE, RepAtom(fe->NameOfFE)->StrOfAE, fe->ArityOfFE); */ INIT_RWLOCK(p->PRWLock); p->KindOfPE = PEProp; @@ -403,12 +389,9 @@ NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) p->OwnerFile = AtomNil; p->OpcodeOfPred = UNDEF_OPCODE; p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred)); - if (m == 0) - p->ModuleOfPred = 0; - else - p->ModuleOfPred = cur_mod; - p->NextPredOfModule = ModulePred[m]; - ModulePred[m] = p; + p->ModuleOfPred = cur_mod; + p->NextPredOfModule = ModulePred[cur_mod]; + ModulePred[cur_mod] = p; INIT_LOCK(p->StatisticsForPred.lock); p->StatisticsForPred.NOfEntries = 0; p->StatisticsForPred.NOfHeadSuccesses = 0; @@ -425,11 +408,12 @@ NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) } Prop -NewPredPropByAtom(AtomEntry *ae, Term cur_mod) +NewPredPropByAtom(AtomEntry *ae, SMALLUNSGN cur_mod) { Prop p0; PredEntry *p = (PredEntry *) AllocAtomSpace(sizeof(*p)); - int m = IntOfTerm(cur_mod); + +/* Printf("entering %s:%s/0\n", RepAtom(AtomOfTerm(ModuleName[cur_mod]))->StrOfAE, ae->StrOfAE); */ INIT_RWLOCK(p->PRWLock); p->KindOfPE = PEProp; @@ -440,12 +424,9 @@ NewPredPropByAtom(AtomEntry *ae, Term cur_mod) p->OwnerFile = AtomNil; p->OpcodeOfPred = UNDEF_OPCODE; p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred)); - if (!m) - p->ModuleOfPred = 0; - else - p->ModuleOfPred = cur_mod; - p->NextPredOfModule = ModulePred[m]; - ModulePred[m] = p; + p->ModuleOfPred = cur_mod; + p->NextPredOfModule = ModulePred[cur_mod]; + ModulePred[cur_mod] = p; INIT_LOCK(p->StatisticsForPred.lock); p->StatisticsForPred.NOfEntries = 0; p->StatisticsForPred.NOfHeadSuccesses = 0; @@ -461,25 +442,6 @@ NewPredPropByAtom(AtomEntry *ae, Term cur_mod) return (p0); } -Prop -PredProp(Atom ap, unsigned int arity) - /* get predicate entry for ap/arity; create it if neccessary. */ -{ - Prop p0; - AtomEntry *ae; - Functor f; - - if (arity == 0) { - return(PredPropByAtom(ap, *CurrentModulePtr)); - } - ae = RepAtom(ap); - WRITE_LOCK(ae->ARWLock); - f = InlinedUnlockedMkFunctor(ae, arity); - p0 = PredPropByFunc(f, *CurrentModulePtr); - WRITE_UNLOCK(ae->ARWLock); - return(p0); -} - Term GetValue(Atom a) { diff --git a/C/amasm.c b/C/amasm.c index 096615637..2eaed3da3 100644 --- a/C/amasm.c +++ b/C/amasm.c @@ -858,7 +858,7 @@ a_empty_call(void) code_p->opc = emit_op(_fcall); } if (pass_no) { - PredEntry *pe = RepPredProp(GetPredProp(AtomTrue,0)); + PredEntry *pe = RepPredProp(GetPredPropByAtom(AtomTrue,0)); code_p->u.sla.s = emit_count(-Signed(RealEnvSize) - CELLSIZE * cpc->rnd2); code_p->u.sla.l = emit_a((CELL)&(pe->StateOfPred)); @@ -1184,7 +1184,7 @@ a_either(op_numbers opcode, CELL opr, CELL lab) #endif /* YAPOR */ { if (pass_no) { - Prop fe = GetPredProp(AtomTrue,0); + Prop fe = GetPredPropByAtom(AtomTrue,0); code_p->opc = emit_op(opcode); code_p->u.sla.s = emit_count(opr); code_p->u.sla.l = emit_a(lab); diff --git a/C/bb.c b/C/bb.c index 1e56676b7..e9e46e867 100644 --- a/C/bb.c +++ b/C/bb.c @@ -26,7 +26,7 @@ static char SccsId[] = "%W% %G%"; #endif static BBProp -PutBBProp(AtomEntry *ae) /* get BBentry for at; */ +PutBBProp(AtomEntry *ae, SMALLUNSGN mod) /* get BBentry for at; */ { Prop p0; BBProp p; @@ -34,7 +34,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */ WRITE_LOCK(ae->ARWLock); p = RepBBProp(p0 = ae->PropsOfAE); while (p0 != NIL && (!IsBBProperty(p->KindOfPE) || - (p->ModuleOfBB != CurrentModule))) { + (p->ModuleOfBB != mod))) { p = RepBBProp(p0 = p->NextOfPE); } if (p0 == NIL) { @@ -46,7 +46,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */ } p->NextOfPE = ae->PropsOfAE; ae->PropsOfAE = AbsBBProp(p); - p->ModuleOfBB = CurrentModule; + p->ModuleOfBB = mod; p->Element = NULL; p->KeyOfBB = AbsAtom(ae); p->KindOfPE = BBProperty; @@ -57,7 +57,7 @@ PutBBProp(AtomEntry *ae) /* get BBentry for at; */ } static BBProp -PutIntBBProp(Int key) /* get BBentry for at; */ +PutIntBBProp(Int key, SMALLUNSGN mod) /* get BBentry for at; */ { Prop p0; BBProp p; @@ -82,7 +82,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */ p = RepBBProp(p0); while (p0 != NIL && (!IsBBProperty(p->KindOfPE) || key != (Int)(p->KeyOfBB) || - (p->ModuleOfBB != CurrentModule))) { + (p->ModuleOfBB != mod))) { p = RepBBProp(p0 = p->NextOfPE); } if (p0 == NIL) { @@ -93,7 +93,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */ Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2"); return(NULL); } - p->ModuleOfBB = CurrentModule; + p->ModuleOfBB = mod; p->Element = NULL; p->KeyOfBB = (Atom)key; p->KindOfPE = BBProperty; @@ -105,7 +105,7 @@ PutIntBBProp(Int key) /* get BBentry for at; */ } static BBProp -GetBBProp(AtomEntry *ae) /* get BBentry for at; */ +GetBBProp(AtomEntry *ae, SMALLUNSGN mod) /* get BBentry for at; */ { Prop p0; BBProp p; @@ -113,7 +113,7 @@ GetBBProp(AtomEntry *ae) /* get BBentry for at; */ READ_LOCK(ae->ARWLock); p = RepBBProp(p0 = ae->PropsOfAE); while (p0 != NIL && (!IsBBProperty(p->KindOfPE) || - (p->ModuleOfBB != CurrentModule))) { + (p->ModuleOfBB != mod))) { p = RepBBProp(p0 = p->NextOfPE); } READ_UNLOCK(ae->ARWLock); @@ -124,7 +124,7 @@ GetBBProp(AtomEntry *ae) /* get BBentry for at; */ } static BBProp -GetIntBBProp(Int key) /* get BBentry for at; */ +GetIntBBProp(Int key, SMALLUNSGN mod) /* get BBentry for at; */ { Prop p0; BBProp p; @@ -137,7 +137,7 @@ GetIntBBProp(Int key) /* get BBentry for at; */ p = RepBBProp(p0); while (p0 != NIL && (!IsBBProperty(p->KindOfPE) || key != (Int)(p->KeyOfBB) || - (p->ModuleOfBB != CurrentModule))) { + (p->ModuleOfBB != mod))) { p = RepBBProp(p0 = p->NextOfPE); } if (p0 == NIL) { @@ -187,70 +187,62 @@ resize_bb_int_keys(UInt new_size) { } static BBProp -AddBBProp(Term t1, char *msg) +AddBBProp(Term t1, char *msg, SMALLUNSGN mod) { - SMALLUNSGN old_module = CurrentModule; BBProp p; + restart: if (IsVarTerm(t1)) { Error(INSTANTIATION_ERROR, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } if (IsAtomTerm(t1)) { - p = PutBBProp(RepAtom(AtomOfTerm(t1))); + p = PutBBProp(RepAtom(AtomOfTerm(t1)), mod); } else if (IsIntegerTerm(t1)) { - p = PutIntBBProp(IntegerOfTerm(t1)); + p = PutIntBBProp(IntegerOfTerm(t1), mod); } else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) { - Term mod = ArgOfTerm(1, t1); - if (!IsVarTerm(mod) ) { - *CurrentModulePtr = MkIntTerm(LookupModule(mod)); + Term tmod = ArgOfTerm(1, t1); + if (!IsVarTerm(tmod) ) { t1 = ArgOfTerm(2, t1); - p = AddBBProp(t1, msg); + mod = LookupModule(tmod); + goto restart; } else { Error(INSTANTIATION_ERROR, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } } else { Error(TYPE_ERROR_ATOM, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } - *CurrentModulePtr = MkIntTerm(old_module); return(p); } static BBProp -FetchBBProp(Term t1, char *msg) +FetchBBProp(Term t1, char *msg, SMALLUNSGN mod) { - SMALLUNSGN old_module = CurrentModule; BBProp p; + restart: if (IsVarTerm(t1)) { Error(INSTANTIATION_ERROR, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } if (IsAtomTerm(t1)) { - p = GetBBProp(RepAtom(AtomOfTerm(t1))); + p = GetBBProp(RepAtom(AtomOfTerm(t1)), mod); } else if (IsIntegerTerm(t1)) { - p = GetIntBBProp(IntegerOfTerm(t1)); + p = GetIntBBProp(IntegerOfTerm(t1), mod); } else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) { - Term mod = ArgOfTerm(1, t1); - if (!IsVarTerm(mod) ) { - *CurrentModulePtr = MkIntTerm(LookupModule(mod)); + Term tmod = ArgOfTerm(1, t1); + if (!IsVarTerm(tmod) ) { + mod = LookupModule(tmod); t1 = ArgOfTerm(2, t1); - p = FetchBBProp(t1, msg); + goto restart; } else { Error(INSTANTIATION_ERROR, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } } else { Error(TYPE_ERROR_ATOM, t1, msg); - *CurrentModulePtr = MkIntTerm(old_module); return(NULL); } - *CurrentModulePtr = MkIntTerm(old_module); return(p); } @@ -258,7 +250,7 @@ static Int p_bb_put(void) { Term t1 = Deref(ARG1); - BBProp p = AddBBProp(t1, "bb_put/2"); + BBProp p = AddBBProp(t1, "bb_put/2", CurrentModule); if (p == NULL) return(FALSE); WRITE_LOCK(p->BBRWLock); @@ -274,7 +266,7 @@ static Int p_bb_get(void) { Term t1 = Deref(ARG1); - BBProp p = FetchBBProp(t1, "bb_get/2"); + BBProp p = FetchBBProp(t1, "bb_get/2", CurrentModule); Term out; if (p == NULL || p->Element == NULL) return(FALSE); @@ -291,7 +283,7 @@ p_bb_delete(void) BBProp p; Term out; - p = FetchBBProp(t1, "bb_delete/2"); + p = FetchBBProp(t1, "bb_delete/2", CurrentModule); if (p == NULL || p->Element == NULL) return(FALSE); out = FetchTermFromDB(p->Element,3); @@ -309,7 +301,7 @@ p_bb_update(void) BBProp p; Term out; - p = FetchBBProp(t1, "bb_update/3"); + p = FetchBBProp(t1, "bb_update/3", CurrentModule); if (p == NULL || p->Element == NULL) return(FALSE); WRITE_LOCK(p->BBRWLock); diff --git a/C/c_interface.c b/C/c_interface.c index 9d6477dfe..98a87b7d1 100644 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -376,7 +376,7 @@ YapCallProlog(Term t) Int out; BACKUP_MACHINE_REGS(); - out = execute_goal(t,0); + out = execute_goal(t, 0, CurrentModule); RECOVER_MACHINE_REGS(); return(out); @@ -594,14 +594,16 @@ YapCompileClause(Term t) { char *ErrorMessage; CODEADDR codeaddr; + int mod = CurrentModule; + BACKUP_MACHINE_REGS(); ErrorMessage = NULL; ARG1 = t; - codeaddr = cclause (t,0); + codeaddr = cclause (t,0, mod); if (codeaddr != NULL) { t = Deref(ARG1); /* just in case there was an heap overflow */ - addclause (t, codeaddr, TRUE); + addclause (t, codeaddr, TRUE, mod); } RECOVER_MACHINE_REGS(); @@ -677,7 +679,7 @@ YapInit(yap_init_args *yap_init) InitYaamRegs(); #endif /* slaves, waiting for work */ - *CurrentModulePtr = MkIntTerm(1); + CurrentModule = 1; P = GETWORK_FIRST_TIME; exec_absmi(FALSE); abort_optyap("abstract machine unexpected exit"); diff --git a/C/cdmgr.c b/C/cdmgr.c index ab283d59d..10fa71943 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -52,8 +52,6 @@ STATIC_PROTO(void do_toggle_static_predicates_in_use, (int)); STATIC_PROTO(void recover_log_upd_clause, (Clause *)); STATIC_PROTO(PredEntry *NextPred, (PredEntry *,AtomEntry *)); STATIC_PROTO(Int p_number_of_clauses, (void)); -STATIC_PROTO(Int p_find_dynamic, (void)); -STATIC_PROTO(Int p_next_dynamic, (void)); STATIC_PROTO(Int p_compile, (void)); STATIC_PROTO(Int p_compile_dynamic, (void)); STATIC_PROTO(Int p_purge_clauses, (void)); @@ -66,7 +64,6 @@ STATIC_PROTO(Int p_undefined, (void)); STATIC_PROTO(Int p_in_use, (void)); STATIC_PROTO(Int p_new_multifile, (void)); STATIC_PROTO(Int p_is_multifile, (void)); -STATIC_PROTO(Int p_is_logical_updatable, (void)); STATIC_PROTO(Int p_optimizer_on, (void)); STATIC_PROTO(Int p_optimizer_off, (void)); STATIC_PROTO(Int p_in_this_f_before, (void)); @@ -79,7 +76,6 @@ STATIC_PROTO(Int p_is_profiled, (void)); STATIC_PROTO(Int p_profile_info, (void)); STATIC_PROTO(Int p_profile_reset, (void)); STATIC_PROTO(Int p_toggle_static_predicates_in_use, (void)); -STATIC_PROTO(Int p_search_for_static_predicate_in_use, (void)); #define PredArity(p) (p->ArityOfPE) #define TRYCODE(G,F,N) ( (N)<5 ? (op_numbers)((int)F+(N)*3) : G) @@ -787,34 +783,35 @@ addcl_permission_error(AtomEntry *ap, Int Arity) void -addclause(Term t, CODEADDR cp, int mode) +addclause(Term t, CODEADDR cp, int mode, int mod) /* * mode 0 assertz 1 consult 2 asserta */ { - AtomEntry *ap; - Int Arity; PredEntry *p; int spy_flag = FALSE; - SMALLUNSGN mod = CurrentModule; + Atom at; + UInt Arity; if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert) t = ArgOfTerm(1, t); if (IsAtomTerm(t)) { + at = AtomOfTerm(t); + p = RepPredProp(PredPropByAtom(at, mod)); Arity = 0; - ap = RepAtom(AtomOfTerm(t)); } else { Functor f = FunctorOfTerm(t); - ap = RepAtom(NameOfFunctor(f)); Arity = ArityOfFunctor(f); + at = NameOfFunctor(f); + p = RepPredProp(PredPropByFunc(f, mod)); } - p = RepPredProp(PredProp(AbsAtom(ap), Arity)); PutValue(AtomAbol, TermNil); WRITE_LOCK(p->PRWLock); /* we are redefining a prolog module predicate */ if (mod != 0 && p->ModuleOfPred == 0) { - addcl_permission_error(ap, Arity); + WRITE_UNLOCK(p->PRWLock); + addcl_permission_error(RepAtom(at), Arity); return; } /* The only problem we have now is when we need to throw away @@ -824,7 +821,7 @@ addclause(Term t, CODEADDR cp, int mode) if (!RemoveIndexation(p)) { /* should never happen */ WRITE_UNLOCK(p->PRWLock); - addcl_permission_error(ap,Arity); + addcl_permission_error(RepAtom(at),Arity); return; } } @@ -877,12 +874,13 @@ addclause(Term t, CODEADDR cp, int mode) static Int p_in_this_f_before(void) -{ /* '$in_this_file_before'(N,A) */ +{ /* '$in_this_file_before'(N,A,M) */ unsigned int arity; Atom at; Term t; register consult_obj *fp; Prop p0; + SMALLUNSGN mod; if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t)) return (FALSE); @@ -892,7 +890,14 @@ p_in_this_f_before(void) return (FALSE); else arity = IntOfTerm(t); - p0 = PredProp(at, arity); + if (IsVarTerm(t = Deref(ARG3)) && !IsAtomTerm(t)) + return (FALSE); + else + mod = LookupModule(t); + if (arity) + p0 = PredPropByFunc(MkFunctor(at, arity),CurrentModule); + else + p0 = PredPropByAtom(at, CurrentModule); if (ConsultSp == ConsultBase || (fp = ConsultSp)->p == p0) return (FALSE); else @@ -908,12 +913,14 @@ p_in_this_f_before(void) static Int p_first_cl_in_f(void) -{ /* '$first_cl_in_file'(+N,+Ar) */ +{ /* '$first_cl_in_file'(+N,+Ar,+Mod) */ unsigned int arity; Atom at; Term t; register consult_obj *fp; Prop p0; + SMALLUNSGN mod; + if (IsVarTerm(t = Deref(ARG1)) && !IsAtomTerm(t)) return (FALSE); @@ -923,7 +930,14 @@ p_first_cl_in_f(void) return (FALSE); else arity = IntOfTerm(t); - p0 = PredProp(at, arity); + if (IsVarTerm(t = Deref(ARG3)) && !IsAtomTerm(t)) + return (FALSE); + else + mod = LookupModule(t); + if (arity) + p0 = PredPropByFunc(MkFunctor(at, arity),mod); + else + p0 = PredPropByAtom(at, mod); for (fp = ConsultSp; fp < ConsultBase; ++fp) if (fp->p == p0) break; @@ -948,7 +962,10 @@ p_mk_cl_not_first(void) return (FALSE); else arity = IntOfTerm(t); - p0 = PredProp(at, arity); + if (arity) + p0 = PredPropByFunc(MkFunctor(at, arity),CurrentModule); + else + p0 = PredPropByAtom(at, CurrentModule); --ConsultSp; ConsultSp->p = p0; return (TRUE); @@ -991,18 +1008,23 @@ where_new_clause(pred_prop, mode) static Int p_compile(void) -{ /* '$compile'(+C,+Flags) */ +{ /* '$compile'(+C,+Flags, Mod) */ Term t = Deref(ARG1); Term t1 = Deref(ARG2); + Term t3 = Deref(ARG3); CODEADDR codeadr; + Int mod; if (IsVarTerm(t1) || !IsIntTerm(t1)) return (FALSE); - codeadr = cclause(t, 2); /* vsc: give the number of arguments + if (IsVarTerm(t3) || !IsAtomTerm(t3)) + return (FALSE); + mod = LookupModule(t3); + codeadr = cclause(t, 2, mod); /* vsc: give the number of arguments to cclause in case there is overflow */ t = Deref(ARG1); /* just in case there was an heap overflow */ if (!ErrorMessage) - addclause(t, codeadr, (int) (IntOfTerm(t1) & 3)); + addclause(t, codeadr, (int) (IntOfTerm(t1) & 3), mod); if (ErrorMessage) { if (IntOfTerm(t1) & 4) { Error(Error_TYPE, Error_Term, @@ -1016,25 +1038,30 @@ p_compile(void) static Int p_compile_dynamic(void) -{ /* '$compile_dynamic'(+C,+Flags,-Ref) */ +{ /* '$compile_dynamic'(+C,+Flags,Mod,-Ref) */ Term t = Deref(ARG1); Term t1 = Deref(ARG2); + Term t3 = Deref(ARG3); Clause *cl; CODEADDR code_adr; int old_optimize; + Int mod; if (IsVarTerm(t1) || !IsIntTerm(t1)) return (FALSE); + if (IsVarTerm(t3) || !IsAtomTerm(t3)) + return (FALSE); old_optimize = optimizer_on; optimizer_on = FALSE; - code_adr = cclause(t, 3); /* vsc: give the number of arguments to + mod = LookupModule(t3); + code_adr = cclause(t, 3, mod); /* vsc: give the number of arguments to cclause() in case there is a overflow */ t = Deref(ARG1); /* just in case there was an heap overflow */ if (!ErrorMessage) { optimizer_on = old_optimize; cl = ClauseCodeToClause(code_adr); - addclause(t, code_adr, (int) (IntOfTerm(t1) & 3)); + addclause(t, code_adr, (int) (IntOfTerm(t1) & 3), mod); } if (ErrorMessage) { if (IntOfTerm(t1) & 4) { @@ -1047,7 +1074,7 @@ p_compile_dynamic(void) if (!(cl->ClFlags & LogUpdMask)) cl->ClFlags = DynamicMask; t = MkIntegerTerm((Int)code_adr); - return(unify(ARG3, t)); + return(unify(ARG4, t)); } @@ -1145,17 +1172,23 @@ p_purge_clauses(void) { /* '$purge_clauses'(+Func) */ PredEntry *pred; Term t = Deref(ARG1); + Term t2 = Deref(ARG2); CODEADDR q, q1; + int mod; PutValue(AtomAbol, MkAtomTerm(AtomNil)); if (IsVarTerm(t)) return (FALSE); + if (IsVarTerm(t2) || !IsAtomTerm(t2)) { + return (FALSE); + } + mod = LookupModule(t2); if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pred = RepPredProp(PredProp(at, 0)); + pred = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); + pred = RepPredProp(PredPropByFunc(fun, mod)); } else return (FALSE); WRITE_LOCK(pred->PRWLock); @@ -1197,24 +1230,30 @@ p_purge_clauses(void) static Int p_setspy(void) -{ /* '$set_spy'(+Fun) */ +{ /* '$set_spy'(+Fun,+M) */ Atom at; PredEntry *pred; CELL fg; Term t; + Term t2; + SMALLUNSGN mod; at = FullLookupAtom("$spy"); - pred = RepPredProp(PredProp(at, 1)); + pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0)); SpyCode = pred; t = Deref(ARG1); + t2 = Deref(ARG2); if (IsVarTerm(t)) return (FALSE); + if (IsVarTerm(t2) || !IsAtomTerm(t2)) + return (FALSE); + mod = LookupModule(t2); if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pred = RepPredProp(PredProp(at, 0)); + pred = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); + pred = RepPredProp(PredPropByFunc(fun, mod)); } else { return (FALSE); } @@ -1249,20 +1288,26 @@ p_setspy(void) static Int p_rmspy(void) -{ /* '$rm_spy'(+T) */ +{ /* '$rm_spy'(+T,+Mod) */ Atom at; PredEntry *pred; Term t; + Term t2; + SMALLUNSGN mod; t = Deref(ARG1); + t2 = Deref(ARG2); + if (IsVarTerm(t2) || !IsAtomTerm(t2)) + return (FALSE); + mod = LookupModule(t2); if (IsVarTerm(t)) return (FALSE); if (IsAtomTerm(t)) { at = AtomOfTerm(t); - pred = RepPredProp(PredProp(at, 0)); + pred = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - pred = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); + pred = RepPredProp(PredPropByFunc(fun, mod)); } else return (FALSE); WRITE_LOCK(pred->PRWLock); @@ -1294,19 +1339,25 @@ p_rmspy(void) static Int p_number_of_clauses(void) -{ /* '$number_of_clauses'(Predicate,N) */ +{ /* '$number_of_clauses'(Predicate,M,N) */ Term t = Deref(ARG1); + Term t2 = Deref(ARG2); int ncl = 0; Prop pe; CODEADDR q; int testing; + int mod; + if (IsVarTerm(t2) || !IsAtomTerm(t2)) { + return(FALSE); + } + mod = LookupModule(t2); if (IsAtomTerm(t)) { Atom a = AtomOfTerm(t); - pe = PredProp(a, 0); + pe = PredPropByAtom(a, mod); } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); - pe = PredPropByFunc(f, *CurrentModulePtr); + pe = PredPropByFunc(f, mod); } else return (FALSE); q = RepPredProp(pe)->FirstClause; @@ -1328,113 +1379,29 @@ p_number_of_clauses(void) } READ_UNLOCK(RepPredProp(pe)->PRWLock); t = MkIntTerm(ncl); - return (unify_constant(ARG2, t)); -} - -static Int -p_find_dynamic(void) -{ /* '$find_dynamic'(+G,+N,-C) */ - Term t = Deref(ARG1); - Prop pe; - CODEADDR q; - int position; - - if (IsAtomTerm(t)) { - Atom a = AtomOfTerm(t); - pe = PredProp(a, 0); - } else if (IsApplTerm(t)) { - register Functor f = FunctorOfTerm(t); - pe = PredPropByFunc(f, *CurrentModulePtr); - } else - return (FALSE); - q = RepPredProp(pe)->FirstClause; - t = Deref(ARG2); - if (IsVarTerm(t) || !IsIntTerm(t)) - return (FALSE); - position = IntOfTerm(t); - READ_LOCK(RepPredProp(pe)->PRWLock); - if (!(RepPredProp(pe)->PredFlags & DynamicPredFlag)) - return (FALSE); - while (position > 1) { - while (ClauseCodeToClause(q)->ClFlags & ErasedMask) - q = NextClause(q); - position--; - q = NextClause(q); - } - while (ClauseCodeToClause(q)->ClFlags & ErasedMask) - q = NextClause(q); -#if defined(YAPOR) || defined(THREADS) - { - Clause *cl = ClauseCodeToClause(q); - LOCK(cl->ClLock); - TRAIL_CLREF(cl); - INC_CLREF_COUNT(cl); - UNLOCK(cl->ClLock); - } -#else - if (!(ClauseCodeToClause(q)->ClFlags & InUseMask)) { - OPREG *opp = &(ClauseCodeToClause(q)->ClFlags); - TRAIL_CLREF(ClauseCodeToClause(q)); - *opp |= InUseMask; - } -#endif - READ_UNLOCK(RepPredProp(pe)->PRWLock); - t = MkIntegerTerm((Int)q); - return (unify(ARG3, t)); -} - -static Int -p_next_dynamic(void) -{ /* '$next_dynamic'(+G,+C,-N) */ - Term t = Deref(ARG1); - Prop pe; - CODEADDR q, oldq; - int position; - - t = Deref(ARG2); - if (IsVarTerm(t) || !IsIntegerTerm(t)) - return (FALSE); - if (IsAtomTerm(t)) { - Atom a = AtomOfTerm(t); - pe = PredProp(a, 0); - } else if (IsApplTerm(t)) { - register Functor f = FunctorOfTerm(t); - pe = PredPropByFunc(f, *CurrentModulePtr); - } else - return (FALSE); - q = RepPredProp(pe)->FirstClause; - READ_LOCK(RepPredProp(pe)->PRWLock); - if (!(RepPredProp(pe)->PredFlags & DynamicPredFlag)) - return (FALSE); - oldq = (CODEADDR)IntegerOfTerm(t); - position = 1; - while (q != oldq) { - if (!(ClauseCodeToClause(q)->ClFlags & ErasedMask)) - position++; - q = NextClause(q); - } - if (!(ClauseCodeToClause(q)->ClFlags & ErasedMask)) - position++; - READ_UNLOCK(RepPredProp(pe)->PRWLock); - t = MkIntTerm(position); return (unify_constant(ARG3, t)); } static Int p_in_use(void) -{ /* '$in_use'(+P) */ +{ /* '$in_use'(+P,+Mod) */ Term t = Deref(ARG1); + Term t2 = Deref(ARG2); PredEntry *pe; Int out; + int mod; if (IsVarTerm(t)) return (FALSE); + if (IsVarTerm(t2) || !IsAtomTerm(t2)) + return (FALSE); + mod = LookupModule(t2); if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pe = RepPredProp(PredProp(at, 0)); + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); + pe = RepPredProp(PredPropByFunc(fun, mod)); } else return (FALSE); READ_LOCK(pe->PRWLock); @@ -1445,11 +1412,12 @@ p_in_use(void) static Int p_new_multifile(void) -{ /* '$new_multifile'(+N,+Ar) */ +{ /* '$new_multifile'(+N,+Ar,+Mod) */ Atom at; int arity; PredEntry *pe; Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG3)); if (IsVarTerm(t)) return (FALSE); @@ -1464,7 +1432,10 @@ p_new_multifile(void) arity = IntOfTerm(t); else return (FALSE); - pe = RepPredProp(PredProp(at, arity)); + if (arity == 0) + pe = RepPredProp(PredPropByAtom(at, mod)); + else + pe = RepPredProp(PredPropByFunc(MkFunctor(at, arity),mod)); WRITE_LOCK(pe->PRWLock); pe->PredFlags |= MultiFileFlag; WRITE_UNLOCK(pe->PRWLock); @@ -1474,28 +1445,27 @@ p_new_multifile(void) static Int p_is_multifile(void) -{ /* '$is_multifile'(+N,+Ar) */ - Atom at; - int arity; +{ /* '$is_multifile'(+S,+Mod) */ PredEntry *pe; Term t = Deref(ARG1); + Term t2 = Deref(ARG2); Int out; + int mod; if (IsVarTerm(t)) return (FALSE); - if (IsAtomTerm(t)) - at = AtomOfTerm(t); - else + if (IsVarTerm(t2)) return (FALSE); - t = Deref(ARG2); - if (IsVarTerm(t)) + if (!IsAtomTerm(t2)) return (FALSE); - if (IsIntTerm(t)) - arity = IntOfTerm(t); - else - return (FALSE); - pe = RepPredProp(PredProp(at, arity)); - if (pe == NIL) + mod = LookupModule(t2); + if (IsAtomTerm(t)) { + pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod)); + } else if (IsApplTerm(t)) { + pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod)); + } else + return(FALSE); + if (EndOfPAEntr(pe)) return (FALSE); READ_LOCK(pe->PRWLock); out = (pe->PredFlags & MultiFileFlag); @@ -1503,52 +1473,23 @@ p_is_multifile(void) return(out); } -static Int -p_is_logical_updatable(void) -{ /* '$is_logical_updatable'(+N,+Ar) */ - Atom at; - int arity; - PredEntry *pe; - Term t = Deref(ARG1); - Int out; - - if (IsVarTerm(t)) - return (FALSE); - if (IsAtomTerm(t)) - at = AtomOfTerm(t); - else - return (FALSE); - t = Deref(ARG2); - if (IsVarTerm(t)) - return (FALSE); - if (IsIntTerm(t)) - arity = IntOfTerm(t); - else - return (FALSE); - pe = RepPredProp(PredProp(at, arity)); - if (pe == NIL) - return (FALSE); - READ_LOCK(pe->PRWLock); - out = (pe->PredFlags & LogUpdatePredFlag); - READ_UNLOCK(pe->PRWLock); - return(out); -} - static Int p_is_dynamic(void) { /* '$is_dynamic'(+P) */ PredEntry *pe; Term t = Deref(ARG1); + Term t2 = Deref(ARG2); Int out; - + SMALLUNSGN mod = LookupModule(t2); + if (IsVarTerm(t)) { return (FALSE); } else if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pe = RepPredProp(PredProp(at, 0)); + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - pe = RepPredProp(PredPropByFunc(fun, *CurrentModulePtr)); + pe = RepPredProp(PredPropByFunc(fun, mod)); } else return (FALSE); if (pe == NIL) @@ -1562,31 +1503,40 @@ p_is_dynamic(void) static Int p_set_pred_module(void) { /* '$set_pred_module'(+P,+Mod) */ - Atom at; - int arity; PredEntry *pe; Term t = Deref(ARG1); + SMALLUNSGN mod = CurrentModule; + + restart_set_pred: if (IsVarTerm(t)) { return (FALSE); } else if (IsAtomTerm(t)) { - at = AtomOfTerm(t); - arity = 0; + pe = RepPredProp(PredPropByAtom(AtomOfTerm(t), mod)); } else if (IsApplTerm(t)) { Functor fun = FunctorOfTerm(t); - at = NameOfFunctor(fun); - arity = ArityOfFunctor(fun); + if (fun == FunctorModule) { + Term tmod = ArgOfTerm(1, t); + if (IsVarTerm(tmod) ) { + Error(INSTANTIATION_ERROR,ARG1,"set_pred_module/1"); + return(FALSE); + } + if (!IsAtomTerm(tmod) ) { + Error(TYPE_ERROR_ATOM,ARG1,"set_pred_module/1"); + return(FALSE); + } + mod = LookupModule(tmod); + t = ArgOfTerm(2, t); + goto restart_set_pred; + } + pe = RepPredProp(PredPropByFunc(fun, mod)); } else return (FALSE); - pe = RepPredProp(PredProp(at, arity)); - if (pe == NIL) + if (EndOfPAEntr(pe)) return (FALSE); WRITE_LOCK(pe->PRWLock); { SMALLUNSGN mod = LookupModule(Deref(ARG2)); - if (mod) - pe->ModuleOfPred = MkIntTerm(mod); - else - pe->ModuleOfPred = 0; + pe->ModuleOfPred = mod; } WRITE_UNLOCK(pe->PRWLock); return(TRUE); @@ -1594,12 +1544,23 @@ p_set_pred_module(void) static Int p_undefined(void) -{ /* '$undefined'(P) */ +{ /* '$undefined'(P,Mod) */ PredEntry *pe; Term t; - Term tmod = *CurrentModulePtr; + Term t2; + SMALLUNSGN mod; t = Deref(ARG1); + t2 = Deref(ARG2); + if (IsVarTerm(t2)) { + Error(INSTANTIATION_ERROR,ARG2,"undefined/1"); + return(FALSE); + } + if (!IsAtomTerm(t2)) { + Error(TYPE_ERROR_ATOM,ARG2,"undefined/1"); + return(FALSE); + } + mod = LookupModule(t2); restart_undefined: if (IsVarTerm(t)) { Error(INSTANTIATION_ERROR,ARG1,"undefined/1"); @@ -1607,24 +1568,24 @@ p_undefined(void) } if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pe = RepPredProp(GetPredPropByAtom(at,tmod)); + pe = RepPredProp(GetPredPropByAtom(at,mod)); } else if (IsApplTerm(t)) { Functor funt = FunctorOfTerm(t); if (funt == FunctorModule) { - Term mod = ArgOfTerm(1, t); - if (IsVarTerm(mod) ) { + Term tmod = ArgOfTerm(1, t); + if (IsVarTerm(tmod) ) { Error(INSTANTIATION_ERROR,ARG1,"undefined/1"); return(FALSE); } - if (!IsAtomTerm(mod) ) { + if (!IsAtomTerm(tmod) ) { Error(TYPE_ERROR_ATOM,ARG1,"undefined/1"); return(FALSE); } - tmod = MkIntTerm(LookupModule(mod)); + mod = LookupModule(tmod); t = ArgOfTerm(2, t); goto restart_undefined; } - pe = RepPredProp(GetPredPropByFunc(funt, tmod)); + pe = RepPredProp(GetPredPropByFunc(funt, mod)); } else { return (FALSE); } @@ -1650,20 +1611,32 @@ p_undefined(void) static Int p_kill_dynamic(void) -{ /* '$kill_dynamic'(P) */ +{ /* '$kill_dynamic'(P,M) */ PredEntry *pe; Term t; - + Term t2; + SMALLUNSGN mod; + + t2 = Deref(ARG2); + if (IsVarTerm(t2)) { + Error(INSTANTIATION_ERROR,ARG2,"undefined/1"); + return(FALSE); + } + if (!IsAtomTerm(t2)) { + Error(TYPE_ERROR_ATOM,ARG2,"undefined/1"); + return(FALSE); + } + mod = LookupModule(t2); t = Deref(ARG1); if (IsAtomTerm(t)) { Atom at = AtomOfTerm(t); - pe = RepPredProp(PredProp(at, 0)); + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor funt = FunctorOfTerm(t); - pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr)); + pe = RepPredProp(PredPropByFunc(funt, mod)); } else return (FALSE); - if (pe == NIL) + if (EndOfPAEntr(pe)) return (TRUE); WRITE_LOCK(pe->PRWLock); if (!(pe->PredFlags & DynamicPredFlag)) { @@ -1845,43 +1818,6 @@ do_toggle_static_predicates_in_use(int mask) #endif -static Int -p_search_for_static_predicate_in_use(void) -{ -#if defined(YAPOR) || defined(THREADS) - return(FALSE); -#else - PredEntry *pe; - Term t; - Int out; - - t = Deref(ARG1); - if (IsAtomTerm(t)) { - Atom at = AtomOfTerm(t); - pe = RepPredProp(PredProp(at, 0)); - } else if (IsApplTerm(t)) { - Functor funt = FunctorOfTerm(ARG1); - pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr)); - } else - return(FALSE); - /* do nothing if we are in consult */ - if (STATIC_PREDICATES_MARKED) - return (pe->StateOfPred & InUseMask); - /* if it was not defined, surely it was not in use */ - if (pe == NIL) - return (TRUE); - READ_LOCK(pe->PRWLock); - if (pe->PredFlags & (BasicPredFlag|StandardPredFlag|DynamicPredFlag|CPredFlag)) { - READ_UNLOCK(pe->PRWLock); - return(FALSE); - } - out = search_for_static_predicate_in_use(pe, TRUE); - READ_UNLOCK(pe->PRWLock); - return(out); -#endif -} - - /* This predicate is to be used by reconsult to mark all predicates currently in use as being executed. @@ -2039,22 +1975,30 @@ p_is_profiled(void) static Int p_profile_info(void) { - Term tname = Deref(ARG1); - Term tarity = Deref(ARG2); + Term tmod = Deref(ARG1); + Term tfun = Deref(ARG2); + int mod; Term out; PredEntry *pe; - Int arity; - Atom name; Term p[3]; - if (IsVarTerm(tname) || !IsAtomTerm(tname)) + if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) return(FALSE); - if (IsVarTerm(tarity) || !IsIntTerm(tarity)) + mod = LookupModule(tmod); + if (IsVarTerm(tfun)) { return(FALSE); - name = AtomOfTerm(tname); - arity = IntOfTerm(tarity); - pe = RepPredProp(GetPredProp(name, arity)); - if (pe == NULL) + } else if (IsApplTerm(tfun)) { + Functor f = FunctorOfTerm(tfun); + if (IsExtensionFunctor(f)) { + return(FALSE); + } + pe = RepPredProp(GetPredPropByFunc(f, mod)); + } else if (IsAtomTerm(tfun)) { + pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(tfun), mod)); + } else { + return(FALSE); + } + if (EndOfPAEntr(pe)) return(FALSE); LOCK(pe->StatisticsForPred.lock); if (!(pe->StatisticsForPred.NOfEntries)) { @@ -2072,20 +2016,28 @@ p_profile_info(void) static Int p_profile_reset(void) { - Term tname = Deref(ARG1); - Term tarity = Deref(ARG2); + Term tmod = Deref(ARG1); + Term tfun = Deref(ARG2); + int mod; PredEntry *pe; - Int arity; - Atom name; - if (IsVarTerm(tname) || !IsAtomTerm(tname)) + if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) return(FALSE); - if (IsVarTerm(tarity) || !IsIntTerm(tarity)) + mod = LookupModule(tmod); + if (IsVarTerm(tfun)) { return(FALSE); - name = AtomOfTerm(tname); - arity = IntOfTerm(tarity); - pe = RepPredProp(GetPredProp(name, arity)); - if (pe == NULL) + } else if (IsApplTerm(tfun)) { + Functor f = FunctorOfTerm(tfun); + if (IsExtensionFunctor(f)) { + return(FALSE); + } + pe = RepPredProp(GetPredPropByFunc(f, mod)); + } else if (IsAtomTerm(tfun)) { + pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(tfun), mod)); + } else { + return(FALSE); + } + if (EndOfPAEntr(pe)) return(FALSE); LOCK(pe->StatisticsForPred.lock); pe->StatisticsForPred.NOfEntries = 0; @@ -2124,21 +2076,23 @@ p_parent_pred(void) unify(ARG3, MkIntTerm(arity))); } -static Int /* $parent_pred(Module, Name, Arity) */ +static Int /* $system_predicate(P) */ p_system_pred(void) { PredEntry *pe; - Term mod = *CurrentModulePtr; Term t1 = Deref(ARG1); - restart: + restart_system_pred: if (IsVarTerm(t1)) return (FALSE); if (IsAtomTerm(t1)) { - pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)); + pe = RepPredProp(GetPredPropByAtom(AtomOfTerm(t1), 0)); } else if (IsApplTerm(t1)) { Functor funt = FunctorOfTerm(t1); - if (funt == FunctorModule) { + if (IsExtensionFunctor(funt)) { + return(FALSE); + } + while (funt == FunctorModule) { Term nmod = ArgOfTerm(1, t1); if (IsVarTerm(nmod)) { Error(INSTANTIATION_ERROR,ARG1,"system_predicate/1"); @@ -2148,13 +2102,14 @@ p_system_pred(void) Error(TYPE_ERROR_ATOM,ARG1,"system_predicate/1"); return(FALSE); } - mod = MkIntTerm(LookupModule(nmod)); t1 = ArgOfTerm(2, t1); - goto restart; + goto restart_system_pred; } - pe = RepPredProp(PredPropByFunc(funt, mod)); + pe = RepPredProp(GetPredPropByFunc(funt, 0)); } else return (FALSE); + if (EndOfPAEntr(pe)) + return(FALSE); return(pe->ModuleOfPred == 0); } @@ -2165,33 +2120,29 @@ InitCdMgr(void) InitCPred("$start_consult", 3, p_startconsult, SafePredFlag|SyncPredFlag); InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag); InitCPred("$end_consult", 0, p_endconsult, SafePredFlag|SyncPredFlag); - InitCPred("$set_spy", 1, p_setspy, SafePredFlag|SyncPredFlag); - InitCPred("$rm_spy", 1, p_rmspy, SafePredFlag|SyncPredFlag); + InitCPred("$set_spy", 2, p_setspy, SafePredFlag|SyncPredFlag); + InitCPred("$rm_spy", 2, p_rmspy, SafePredFlag|SyncPredFlag); /* gc() may happen during compilation, hence these predicates are now unsafe */ - InitCPred("$compile", 2, p_compile, SyncPredFlag); - InitCPred("$compile_dynamic", 3, p_compile_dynamic, SyncPredFlag); - InitCPred("$purge_clauses", 1, p_purge_clauses, SafePredFlag|SyncPredFlag); - InitCPred("$in_use", 1, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag); - InitCPred("$is_logical_updatable", 1, p_is_logical_updatable, TestPredFlag | SafePredFlag); - InitCPred("$is_dynamic", 1, p_is_dynamic, TestPredFlag | SafePredFlag); - InitCPred("$number_of_clauses", 2, p_number_of_clauses, SafePredFlag|SyncPredFlag); - InitCPred("$find_dynamic", 3, p_find_dynamic, SafePredFlag|SyncPredFlag); - InitCPred("$next_dynamic", 3, p_next_dynamic, SafePredFlag|SyncPredFlag); - InitCPred("$undefined", 1, p_undefined, SafePredFlag|TestPredFlag); + InitCPred("$compile", 3, p_compile, SyncPredFlag); + InitCPred("$compile_dynamic", 4, p_compile_dynamic, SyncPredFlag); + InitCPred("$purge_clauses", 2, p_purge_clauses, SafePredFlag|SyncPredFlag); + InitCPred("$in_use", 2, p_in_use, TestPredFlag | SafePredFlag|SyncPredFlag); + InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag); + InitCPred("$number_of_clauses", 3, p_number_of_clauses, SafePredFlag|SyncPredFlag); + InitCPred("$undefined", 2, p_undefined, SafePredFlag|TestPredFlag); InitCPred("$optimizer_on", 0, p_optimizer_on, SafePredFlag|SyncPredFlag); InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag); InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag); InitCPred("$kill_dynamic", 1, p_kill_dynamic, SafePredFlag|SyncPredFlag); - InitCPred("$in_this_file_before", 2, p_in_this_f_before, SafePredFlag); - InitCPred("$first_clause_in_file", 2, p_first_cl_in_f, SafePredFlag); + InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag); + InitCPred("$first_clause_in_file", 3, p_first_cl_in_f, SafePredFlag); InitCPred("$mk_cl_not_first", 2, p_mk_cl_not_first, SafePredFlag); - InitCPred("$new_multifile", 2, p_new_multifile, SafePredFlag|SyncPredFlag); + InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag); InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag); InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag); InitCPred("$profile_info", 3, p_profile_info, SafePredFlag|SyncPredFlag); InitCPred("$profile_reset", 2, p_profile_reset, SafePredFlag|SyncPredFlag); - InitCPred("$search_for_static_predicates_in_use", 1, p_search_for_static_predicate_in_use, TestPredFlag|SafePredFlag|SyncPredFlag); InitCPred("$toggle_static_predicates_in_use", 0, p_toggle_static_predicates_in_use, SafePredFlag|SyncPredFlag); InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag); InitCPred("$parent_pred", 3, p_parent_pred, SafePredFlag); diff --git a/C/compiler.c b/C/compiler.c index 20378910f..9b82dc69f 100644 --- a/C/compiler.c +++ b/C/compiler.c @@ -34,10 +34,10 @@ STATIC_PROTO(void c_arg, (Int, Term, unsigned int)); STATIC_PROTO(void c_args, (Term)); STATIC_PROTO(void c_eq, (Term, Term)); STATIC_PROTO(void c_test, (Int, Term)); -STATIC_PROTO(void c_bifun, (Int, Term, Term, Term)); -STATIC_PROTO(void c_goal, (Term)); +STATIC_PROTO(void c_bifun, (Int, Term, Term, Term, int)); +STATIC_PROTO(void c_goal, (Term, int)); STATIC_PROTO(void get_type_info, (Term)); -STATIC_PROTO(void c_body, (Term)); +STATIC_PROTO(void c_body, (Term, int)); STATIC_PROTO(void get_cl_info, (Term)); STATIC_PROTO(void c_head, (Term)); STATIC_PROTO(int usesvar, (int)); @@ -702,7 +702,7 @@ bip_cons Op,Xk,Ri,C */ static void -c_bifun(Int Op, Term t1, Term t2, Term t3) +c_bifun(Int Op, Term t1, Term t2, Term t3, int mod) { /* compile Z = X Op Y arithmetic function */ /* first we fetch the arguments */ @@ -821,7 +821,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3) if (IsNumTerm(t1)) { /* we will always fail */ if (i2) - c_goal(MkAtomTerm(AtomFalse)); + c_goal(MkAtomTerm(AtomFalse), mod); } else if (!IsAtomTerm(t1)) { char s[32]; @@ -892,7 +892,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3) } else if (IsApplTerm(t2)) { Functor f = FunctorOfTerm(t2); if (i1 < 1 || i1 > ArityOfFunctor(f)) { - c_goal(MkAtomTerm(AtomFalse)); + c_goal(MkAtomTerm(AtomFalse), mod); } else { c_eq(ArgOfTerm(i1, t2), t3); } @@ -906,7 +906,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3) c_eq(TailOfTerm(t2), t3); return; default: - c_goal(MkAtomTerm(AtomFalse)); + c_goal(MkAtomTerm(AtomFalse), mod); return; } } @@ -1066,13 +1066,13 @@ c_bifun(Int Op, Term t1, Term t2, Term t3) } static void -c_functor(Term Goal) +c_functor(Term Goal, int mod) { Term t1 = ArgOfTerm(1, Goal); Term t2 = ArgOfTerm(2, Goal); Term t3 = ArgOfTerm(3, Goal); if (IsVarTerm(t1) && IsNewVar(t1)) { - c_bifun(_functor, t2, t3, t1); + c_bifun(_functor, t2, t3, t1, mod); } else if (IsNonVarTerm(t1)) { /* just split the structure */ if (IsAtomicTerm(t1)) { @@ -1095,7 +1095,7 @@ c_functor(Term Goal) c_var(t3,f_flag,(unsigned int)_functor); } else { Functor f = FunctorOfTerm(Goal); - Prop p0 = PredPropByFunc(f, *CurrentModulePtr); + Prop p0 = PredPropByFunc(f, mod); if (profiling) emit(enter_profiling_op, (CELL)RepPredProp(p0), Zero); c_args(Goal); @@ -1122,16 +1122,14 @@ IsTrueGoal(Term t) { } static void -c_goal(Term Goal) +c_goal(Term Goal, int mod) { Functor f; PredEntry *p; Prop p0; - int save_CurrentModule = CurrentModule; if (IsVarTerm(Goal)) { Goal = MkApplTerm(FunctorCall, 1, &Goal); - *CurrentModulePtr = MkIntTerm(PrimitivesModule); } if (IsNumTerm(Goal)) { FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal); @@ -1142,7 +1140,6 @@ c_goal(Term Goal) FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal); } else if (IsPairTerm(Goal)) { Goal = MkApplTerm(FunctorCall, 1, &Goal); - *CurrentModulePtr = MkIntTerm(PrimitivesModule); } else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) { Term M = ArgOfTerm(1, Goal); @@ -1153,19 +1150,17 @@ c_goal(Term Goal) save_machine_regs(); longjmp(CompilerBotch, 1); } - *CurrentModulePtr = MkIntTerm(LookupModule(M)); Goal = ArgOfTerm(2, Goal); + mod = LookupModule(M); } if (IsVarTerm(Goal)) { Goal = MkApplTerm(FunctorCall, 1, &Goal); - *CurrentModulePtr = MkIntTerm(PrimitivesModule); } if (IsAtomTerm(Goal)) { Atom atom = AtomOfTerm(Goal); if (atom == AtomFail || atom == AtomFalse) { emit(fail_op, Zero, Zero); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else if (atom == AtomTrue || atom == AtomOtherwise) { @@ -1178,13 +1173,12 @@ c_goal(Term Goal) #endif /* TABLING */ emit(procceed_op, Zero, Zero); } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else if (atom == AtomCut) { if (profiling) - emit(enter_profiling_op, (CELL)RepPredProp(PredProp(AtomCut,0)), Zero); + emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomCut,0)), Zero); if (onlast) { /* never a problem here with a -> b, !, c ; d */ emit(deallocate_op, Zero, Zero); @@ -1207,7 +1201,6 @@ c_goal(Term Goal) /* needs to adjust previous commits */ adjust_current_commits(); } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } #ifndef YAPOR @@ -1216,7 +1209,7 @@ c_goal(Term Goal) CELL l2 = ++labelno; if (profiling) - emit(enter_profiling_op, (CELL)RepPredProp(PredProp(AtomRepeat,0)), Zero); + emit(enter_profiling_op, (CELL)RepPredProp(PredPropByAtom(AtomRepeat,0)), Zero); or_found = 1; push_branch(onbranch, TermNil); cur_branch++; @@ -1247,20 +1240,17 @@ c_goal(Term Goal) onbranch = pop_branch(); emit(pop_or_op, Zero, Zero); /* --onbranch; */ - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } #endif /* YAPOR */ - else - f = MkFunctor(atom, 0); - p = RepPredProp(p0 = PredProp(atom, 0)); + p = RepPredProp(p0 = PredPropByAtom(atom, mod)); /* if we are profiling, make sure we register we entered this predicate */ if (profiling) emit(enter_profiling_op, (CELL)p, Zero); } else { f = FunctorOfTerm(Goal); - p = RepPredProp(p0 = PredPropByFunc(f, *CurrentModulePtr)); + p = RepPredProp(p0 = PredPropByFunc(f, mod)); if (f == FunctorOr) { CELL l = ++labelno; CELL m = ++labelno; @@ -1289,7 +1279,7 @@ c_goal(Term Goal) } emit_3ops(push_or_op, l, Zero, Zero); if (looking_at_comit && - is_a_test_pred(ArgOfTerm(1, arg))) { + is_a_test_pred(ArgOfTerm(1, arg), mod)) { /* * let them think they are still the * first @@ -1346,16 +1336,16 @@ c_goal(Term Goal) } save = onlast; onlast = FALSE; - c_goal(ArgOfTerm(1, arg)); + c_goal(ArgOfTerm(1, arg), mod); if (!optimizing_comit) { c_var((Term) comitvar, comit_b_flag, 1); } onlast = save; - c_goal(ArgOfTerm(2, arg)); + c_goal(ArgOfTerm(2, arg), mod); } else - c_goal(ArgOfTerm(1, Goal)); + c_goal(ArgOfTerm(1, Goal), mod); if (!onlast) { emit(jump_op, m, Zero); } @@ -1372,16 +1362,15 @@ c_goal(Term Goal) else { optimizing_comit = FALSE; /* not really necessary */ } - c_goal(Goal); + c_goal(Goal, mod); /* --onbranch; */ onbranch = pop_branch(); if (!onlast) { emit(label_op, m, Zero); if ((onlast = save)) - c_goal(MkAtomTerm(AtomTrue)); + c_goal(MkAtomTerm(AtomTrue), mod); } emit(pop_or_op, Zero, Zero); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else if (f == FunctorComma) { @@ -1389,10 +1378,9 @@ c_goal(Term Goal) int t2 = ArgOfTerm(2, Goal); onlast = FALSE; - c_goal(ArgOfTerm(1, Goal)); + c_goal(ArgOfTerm(1, Goal), mod); onlast = save; - c_goal(t2); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); + c_goal(t2, mod); return; } else if (f == FunctorNot || f == FunctorAltNot) { @@ -1416,7 +1404,7 @@ c_goal(Term Goal) emit_3ops(push_or_op, label, Zero, Zero); emit_3ops(either_op, label, Zero, Zero); emit(restore_tmps_op, Zero, Zero); - c_goal(ArgOfTerm(1, Goal)); + c_goal(ArgOfTerm(1, Goal), mod); c_var(comitvar, comit_b_flag, 1); onlast = save; emit(fail_op, end_label, Zero); @@ -1427,10 +1415,9 @@ c_goal(Term Goal) onlast = save; /* --onbranch; */ onbranch = pop_branch(); - c_goal(MkAtomTerm(AtomTrue)); + c_goal(MkAtomTerm(AtomTrue), mod); ++goalno; emit(pop_or_op, Zero, Zero); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else if (f == FunctorArrow) { @@ -1445,11 +1432,10 @@ c_goal(Term Goal) } onlast = FALSE; c_var(comitvar, save_b_flag, 1); - c_goal(ArgOfTerm(1, Goal)); + c_goal(ArgOfTerm(1, Goal), mod); c_var(comitvar, comit_b_flag, 1); onlast = save; - c_goal(ArgOfTerm(2, Goal)); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); + c_goal(ArgOfTerm(2, Goal), mod); return; } else if (f == FunctorEq) { if (profiling) @@ -1468,23 +1454,6 @@ c_goal(Term Goal) READ_UNLOCK(CurrentPred->PRWLock); #endif } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); - return; - } else if (f == FunctorModSwitch) { - Term omod = MkVarTerm(); - Term mod = ArgOfTerm(1, Goal); - Term goal = ArgOfTerm(2, Goal); - Term a[1]; - int cp_onlast = onlast; - onlast = FALSE; - a[0] = omod; - c_goal(MkApplTerm(FunctorCurrentModule, 1, a)); - a[0] = mod; - c_goal(MkApplTerm(FunctorChangeModule, 1, a)); - c_goal(goal); - a[0] = omod; - onlast = cp_onlast; - c_goal(MkApplTerm(FunctorChangeModule, 1, a)); return; } else if (p->PredFlags & BasicPredFlag) { int op = p->PredFlags & 0x7f; @@ -1505,16 +1474,16 @@ c_goal(Term Goal) READ_UNLOCK(CurrentPred->PRWLock); #endif } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else if (op >= _plus && op <= _functor) { if (op == _functor) { - c_functor(Goal); + c_functor(Goal, mod); } else { c_bifun(op, ArgOfTerm(1, Goal), ArgOfTerm(2, Goal), - ArgOfTerm(3, Goal)); + ArgOfTerm(3, Goal), + mod); } if (onlast) { emit(deallocate_op, Zero, Zero); @@ -1529,7 +1498,6 @@ c_goal(Term Goal) READ_UNLOCK(CurrentPred->PRWLock); #endif } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else { c_args(Goal); @@ -1604,7 +1572,6 @@ c_goal(Term Goal) READ_UNLOCK(CurrentPred->PRWLock); #endif } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); return; } else { if (profiling) @@ -1678,7 +1645,6 @@ c_goal(Term Goal) if (!onlast) ++goalno; } - *CurrentModulePtr = MkIntTerm(save_CurrentModule); } static void @@ -1707,7 +1673,7 @@ get_type_info(Term Goal) } static void -c_body(Term Body) +c_body(Term Body, int mod) { onhead = FALSE; BodyStart = cpc; @@ -1728,11 +1694,11 @@ c_body(Term Body) Body = ArgOfTerm(1, Body); break; } - c_goal(ArgOfTerm(1, Body)); + c_goal(ArgOfTerm(1, Body), mod); Body = t2; } onlast = TRUE; - c_goal(Body); + c_goal(Body, mod); } static void @@ -2739,7 +2705,7 @@ c_optimize(PInstr *pc) } CODEADDR -cclause(Term inp_clause, int NOfArgs) +cclause(Term inp_clause, int NOfArgs, int mod) { /* compile a prolog clause, copy of clause myst be in ARG1 */ /* returns address of code for clause */ Term head, body; @@ -2750,7 +2716,6 @@ cclause(Term inp_clause, int NOfArgs) int botch_why; volatile Term my_clause = inp_clause; /* may botch while doing a different module */ - volatile int save_CurrentModule = CurrentModule; /* first, initialise CompilerBotch to handle all cases of interruptions */ ErrorMessage = NIL; @@ -2760,7 +2725,6 @@ cclause(Term inp_clause, int NOfArgs) reset_vars(); { Int osize = 2*sizeof(CELL)*(ASP-H); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); ARG1 = my_clause; if (!gc(2, ENV, P)) { Error_TYPE = SYSTEM_ERROR; @@ -2780,7 +2744,6 @@ cclause(Term inp_clause, int NOfArgs) /* out of temporary cells */ restore_machine_regs(); reset_vars(); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); if (maxvnum < 16*1024) { maxvnum *= 2; } else { @@ -2790,7 +2753,6 @@ cclause(Term inp_clause, int NOfArgs) /* not enough heap */ restore_machine_regs(); reset_vars(); - *CurrentModulePtr = MkIntTerm(save_CurrentModule); Error_TYPE = SYSTEM_ERROR; Error_Term = TermNil; ErrorMessage = "not enough heap space to compile clause"; @@ -2798,7 +2760,6 @@ cclause(Term inp_clause, int NOfArgs) } restart_compilation: if (ErrorMessage != NIL) { - *CurrentModulePtr = MkIntTerm(save_CurrentModule); reset_vars(); return (0); } @@ -2852,9 +2813,9 @@ cclause(Term inp_clause, int NOfArgs) /* find out which predicate we are compiling for */ if (IsAtomTerm(head)) { Atom ap = AtomOfTerm(head); - CurrentPred = RepPredProp(PredProp(ap, 0)); + CurrentPred = RepPredProp(PredPropByAtom(ap, mod)); } else { - CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),*CurrentModulePtr)); + CurrentPred = RepPredProp(PredPropByFunc(FunctorOfTerm(head),mod)); } /* insert extra instructions to count calls */ READ_LOCK(CurrentPred->PRWLock); @@ -2868,7 +2829,7 @@ cclause(Term inp_clause, int NOfArgs) /* phase 1 : produce skeleton code and variable information */ c_head(head); emit(allocate_op, Zero, Zero); - c_body(body); + c_body(body, mod); /* Insert blobs at the very end */ if (BlobsStart != NULL) { cpc->nextInst = BlobsStart; diff --git a/C/computils.c b/C/computils.c index d0fcb0f28..96f95da3e 100644 --- a/C/computils.c +++ b/C/computils.c @@ -68,23 +68,25 @@ AllocCMem (int size) } int -is_a_test_pred (Term arg) +is_a_test_pred (Term arg, SMALLUNSGN mod) { if (IsVarTerm (arg)) return (FALSE); else if (IsAtomTerm (arg)) { Atom At = AtomOfTerm (arg); - if (RepPredProp (PredProp (At, 0)) == NULL) + PredEntry *pe = RepPredProp(PredPropByAtom(At, mod)); + if (EndOfPAEntr(pe)) return (FALSE); - return (RepPredProp (PredProp (At, 0))->PredFlags & TestPredFlag); + return (pe->PredFlags & TestPredFlag); } else if (IsApplTerm (arg)) { Functor f = FunctorOfTerm (arg); - if (RepPredProp (PredPropByFunc (f, *CurrentModulePtr)) == NULL) + PredEntry *pe = RepPredProp(PredPropByFunc(f, mod)); + if (EndOfPAEntr(pe)) return (FALSE); - return (RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->PredFlags & TestPredFlag); + return (pe->PredFlags & TestPredFlag); } else return (FALSE); diff --git a/C/corout.c b/C/corout.c index f45fa1de6..bb85775db 100644 --- a/C/corout.c +++ b/C/corout.c @@ -1158,8 +1158,8 @@ void InitCoroutPreds(void) attas[susp_ext].mark_op = mark_suspended_goal; #endif /* FIXED_STACKS */ at = LookupAtom("$wake_up_goal"); - pred = RepPredProp(PredProp(at, 2)); - WakeUpCode = (CELL *) pred; + pred = RepPredProp(PredPropByFunc(MkFunctor(at, 2),0)); + WakeUpCode = pred; InitAttVarPreds(); #endif /* COROUTINING */ InitCPred("$read_svar_list", 2, p_read_svar_list, SafePredFlag); diff --git a/C/dbase.c b/C/dbase.c index 095dc379f..43570104f 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -164,8 +164,6 @@ static Term DBErrorTerm; /* error term */ static char *DBErrorMsg; /* Error Message */ static DBRef *tofref; /* place the refs also up */ -static SMALLUNSGN DBModule; - CELL *next_float = NULL; #ifdef SFUNC @@ -197,7 +195,7 @@ STATIC_PROTO(void linkblk,(link_entry *,CELL *)); STATIC_PROTO(CELL *linkcells,(CELL *,Int)); #endif STATIC_PROTO(Int cmpclls,(CELL *,CELL *,Int)); -STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int)); +STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int, SMALLUNSGN)); STATIC_PROTO(CELL CalcKey, (Term)); STATIC_PROTO(CELL *MkDBTerm, (CELL *, CELL *, CELL *, CELL *, CELL *, int *)); STATIC_PROTO(DBRef CreateDBStruct, (Term, DBProp, int)); @@ -392,7 +390,7 @@ int DBTrailOverflow(void) /* get DB entry for ap/arity; */ static Prop -FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity) +FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity, SMALLUNSGN dbmod) { Prop p0; DBProp p; @@ -400,7 +398,7 @@ FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity) p = RepDBProp(p0 = ae->PropsOfAE); while (p0 && (((p->KindOfPE & ~0x1) != (CodeDB|DBProperty)) || (p->ArityOfDB != arity) || - ((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != DBModule ))) { + ((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != dbmod))) { p = RepDBProp(p0 = p->NextOfPE); } return (p0); @@ -409,12 +407,12 @@ FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity) /* get DB entry for ap/arity; */ static Prop -FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity) +FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity, SMALLUNSGN dbmod) { Prop out; READ_LOCK(ae->ARWLock); - out = FindDBPropHavingLock(ae, CodeDB, arity); + out = FindDBPropHavingLock(ae, CodeDB, arity, dbmod); READ_UNLOCK(ae->ARWLock); return(out); } @@ -1551,7 +1549,6 @@ p_rcda(void) /* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */ Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2); - DBModule = 0; if (!IsVarTerm(Deref(ARG3))) return (FALSE); restart_record: @@ -1591,7 +1588,6 @@ p_rcdap(void) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2); - DBModule = CurrentModule; if (!IsVarTerm(Deref(ARG3))) return (FALSE); restart_record: @@ -1631,7 +1627,6 @@ p_rcdz(void) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2); - DBModule = 0; if (!IsVarTerm(Deref(ARG3))) return (FALSE); restart_record: @@ -1671,7 +1666,6 @@ p_rcdzp(void) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2); - DBModule = CurrentModule; if (!IsVarTerm(Deref(ARG3))) return (FALSE); restart_record: @@ -1713,7 +1707,6 @@ p_rcdstatp(void) int mk_first; Term TRef; - DBModule = CurrentModule; if (IsVarTerm(t3) || !IsIntTerm(t3)) return (FALSE); if (IsVarTerm(t3) || !IsIntTerm(t3)) @@ -1759,7 +1752,6 @@ p_drcdap(void) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4); - DBModule = CurrentModule; if (!IsVarTerm(Deref(ARG3))) return (FALSE); if (IsVarTerm(t4) || !IsIntegerTerm(t4)) @@ -1803,7 +1795,6 @@ p_drcdzp(void) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4); - DBModule = CurrentModule; if (!IsVarTerm(Deref(ARG3))) return (FALSE); if (IsVarTerm(t4) || !IsIntegerTerm(t4)) @@ -1849,7 +1840,6 @@ p_rcdaifnot(void) DBRef db_ref; restart_record: - DBModule = 0; if (!IsVarTerm(Deref(ARG3))) return (FALSE); found_one = NIL; @@ -1892,7 +1882,6 @@ p_rcdzifnot(void) DBRef db_ref; restart_record: - DBModule = 0; if (!IsVarTerm(Deref(ARG3))) return (FALSE); found_one = NIL; @@ -2062,7 +2051,7 @@ FetchIntDBPropFromKey(Int key, int flag, int new, char *error_mssg) } p->ArityOfDB = 0; p->First = p->Last = NIL; - p->ModuleOfDB = DBModule; + p->ModuleOfDB = 0; p->FunctorOfDB = fun; p->NextOfPE = INT_KEYS[hash_key]; INIT_RWLOCK(p->DBRWLock); @@ -2078,7 +2067,37 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg) { Atom At; Int arity; + SMALLUNSGN dbmod; + if (flag & MkCode) { + if (IsVarTerm(twork)) { + Error(INSTANTIATION_ERROR, twork, error_mssg); + return(RepDBProp(NIL)); + } + if (!IsApplTerm(twork)) { + Error(SYSTEM_ERROR, twork, "missing module"); + return(RepDBProp(NIL)); + } else { + Functor f = FunctorOfTerm(twork); + Term tmod; + if (f != FunctorModule) { + Error(SYSTEM_ERROR, twork, "missing module"); + return(RepDBProp(NIL)); + } + tmod = ArgOfTerm(1, twork); + if (IsVarTerm(tmod)) { + Error(INSTANTIATION_ERROR, twork, "var in module"); + return(RepDBProp(NIL)); + } + if (!IsAtomTerm(tmod)) { + Error(TYPE_ERROR_ATOM, twork, "not atom in module"); + return(RepDBProp(NIL)); + } + dbmod = LookupModule(tmod); + twork = ArgOfTerm(2, twork); + } + } else + dbmod = 0; if (IsVarTerm(twork)) { Error(INSTANTIATION_ERROR, twork, error_mssg); return(RepDBProp(NIL)); @@ -2106,11 +2125,13 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg) AtomEntry *ae = RepAtom(At); WRITE_LOCK(ae->ARWLock); - if (EndOfPAEntr(p = RepDBProp(FindDBPropHavingLock(ae, flag, arity)))) { + if (EndOfPAEntr(p = RepDBProp(FindDBPropHavingLock(ae, flag, arity, dbmod)))) { /* create a new DBProp */ int OLD_UPDATE_MODE = UPDATE_MODE; if (flag & MkCode) { - PredEntry *pp = RepPredProp(GetPredPropHavingLock(At, arity)); + PredEntry *pp; + pp = RepPredProp(GetPredPropHavingLock(At, arity, dbmod)); + if (!EndOfPAEntr(pp)) { READ_LOCK(pp->PRWLock); if(pp->PredFlags & LogUpdatePredFlag) @@ -2139,7 +2160,7 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg) UPDATE_MODE = OLD_UPDATE_MODE; p->ArityOfDB = arity; p->First = p->Last = NIL; - p->ModuleOfDB = DBModule; + p->ModuleOfDB = dbmod; /* This is NOT standard but is QUITE convenient */ INIT_RWLOCK(p->DBRWLock); if (arity == 0) @@ -2152,7 +2173,7 @@ FetchDBPropFromKey(Term twork, int flag, int new, char *error_mssg) WRITE_UNLOCK(ae->ARWLock); return(p); } else - return(RepDBProp(FindDBProp(RepAtom(At), flag, arity))); + return(RepDBProp(FindDBProp(RepAtom(At), flag, arity, dbmod))); } /* Finds a term recorded under the key ARG1 */ @@ -2335,7 +2356,6 @@ p_db_key(void) Register Term twork = Deref(ARG1); /* fetch the key */ DBProp AtProp; - DBModule = 0; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, TRUE, "db_key/3"))) { /* should never happen */ return(FALSE); @@ -2733,7 +2753,6 @@ in_rded(void) * ARG1 */ - DBModule = 0; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "recorded/3"))) { if (b0 == B) cut_fail(); @@ -2754,7 +2773,6 @@ in_rded_with_key(void) static Int co_rded(void) { - DBModule = 0; return (c_recorded(0)); } @@ -2767,7 +2785,6 @@ in_rdedp(void) Register Term twork = Deref(ARG1); /* initially working with * ARG1 */ - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE, "recorded/3"))) { if (b0 == B) cut_fail(); @@ -2781,7 +2798,6 @@ in_rdedp(void) static Int co_rdedp(void) { - DBModule = CurrentModule; return (c_recorded(MkCode)); } @@ -2793,7 +2809,6 @@ p_somercdedp(void) DBProp AtProp; Register Term twork = Deref(ARG1); /* initially working with * ARG1 */ - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE, "some_recorded/3"))) { return(FALSE); } @@ -2823,7 +2838,6 @@ p_first_instance(void) if (!IsVarTerm(ARG3)) { cut_fail(); } - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "first_instance/3"))) { return(FALSE); } @@ -3121,11 +3135,10 @@ MyEraseClause(Clause *clau) father = ref->Parent; if ((arity = father->ArityOfDB) == 0) { Atom name = (Atom) father->FunctorOfDB; - pred = RepPredProp(PredProp(name, 0)); + pred = RepPredProp(PredPropByAtom(name, father->ModuleOfDB)); } else { - pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr)); + pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, father->ModuleOfDB)); } - DBModule = father->ModuleOfDB; WRITE_LOCK(pred->PRWLock); if (StillInChain((CODEADDR)(clau->ClCode), pred)) { if (previous == NIL && next != NIL) { @@ -3315,11 +3328,10 @@ PrepareToEraseClause(Clause *clau, DBRef dbr) /* inefficient, but that will do for the moment, sir. */ if (father->ArityOfDB == 0) { Atom name = (Atom) father->FunctorOfDB; - pred = RepPredProp(PredProp(name, 0)); + pred = RepPredProp(PredPropByAtom(name, father->ModuleOfDB)); } else { - pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, *CurrentModulePtr)); + pred = RepPredProp(PredPropByFunc(father->FunctorOfDB, father->ModuleOfDB)); } - DBModule = father->ModuleOfDB; WRITE_LOCK(pred->PRWLock); /* got my pred entry, let's have some fun! */ clau_code = (CODEADDR)(clau->ClCode); @@ -3465,7 +3477,6 @@ p_eraseall(void) Register DBRef entryref; DBProp p; - DBModule = 0; if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, FALSE, "eraseall/3"))) { return(TRUE); } @@ -3947,7 +3958,6 @@ p_first_age(void) Term to; DBProp AtProp; - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(t1, MkCode, FALSE, "first_age/3"))) { return(FALSE); } @@ -3984,7 +3994,6 @@ p_db_nb_to_ref(void) else if (IsLongIntTerm(t1)) age = LongIntOfTerm(t1); else return(FALSE); - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = FetchDBPropFromKey(t2, MkCode, FALSE, "recorded/3"))) { return(FALSE); } @@ -4024,7 +4033,6 @@ p_last_age(void) DBProp AtProp; Term last_age; - DBModule = CurrentModule; if ((AtProp = FetchDBPropFromKey(t1, MkCode, FALSE, "$last_age/2")) == NIL) { return(FALSE); } @@ -4065,7 +4073,6 @@ p_hold_index(void) DBRef index; - DBModule = CurrentModule; if (EndOfPAEntr(AtProp = (LogUpdDBProp)FetchDBPropFromKey(Deref(ARG1), MkCode, FALSE, "recorded/3"))) { return(FALSE); } @@ -4173,16 +4180,16 @@ InitBackDB(void) InitCPredBack("recorded", 3, 3, in_rded, co_rded, SyncPredFlag); /* internal version, just to prevent the debugger from nosying around */ RETRY_C_RECORDED_CODE = NEXTOP((yamop *) - (RepPredProp(PredProp(LookupAtom("recorded"), 3))->FirstClause),lds); + (RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("recorded"), 3),0))->FirstClause),lds); InitCPredBack("$recorded_with_key", 3, 3, in_rded_with_key, co_rded, SyncPredFlag); RETRY_C_RECORDED_K_CODE = NEXTOP((yamop *) - (RepPredProp(PredProp(LookupAtom("$recorded_with_key"), 3))->FirstClause),lds); + (RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recorded_with_key"), 3),0))->FirstClause),lds); InitCPredBack("$recorded", 3, 3, in_rded, co_rded, SyncPredFlag); RETRY_C_DRECORDED_CODE = NEXTOP((yamop *) - (RepPredProp(PredProp(LookupAtom("$recorded"), 3))->FirstClause),lds); + (RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recorded"), 3),0))->FirstClause),lds); InitCPredBack("$recordedp", 3, 3, in_rdedp, co_rdedp, SyncPredFlag); RETRY_C_RECORDEDP_CODE = NEXTOP((yamop *) - (RepPredProp(PredProp(LookupAtom("$recordedp"), 3))->FirstClause),lds); + (RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("$recordedp"), 3),0))->FirstClause),lds); InitCPredBack("current_key", 2, 4, init_current_key, cont_current_key, SyncPredFlag); } diff --git a/C/exec.c b/C/exec.c index ea2306b86..24e012a8c 100644 --- a/C/exec.c +++ b/C/exec.c @@ -61,26 +61,28 @@ CallPredicate(PredEntry *pen, choiceptr cut_pt) { } inline static Int -CallMetaCall(void) { +CallMetaCall(SMALLUNSGN mod) { ARG2 = current_cp_as_integer(); /* p_save_cp */ ARG3 = ARG1; + ARG4 = ModuleName[mod]; return (CallPredicate(PredMetaCall, B)); } Term -ExecuteCallMetaCall(void) { - Term ts[3]; +ExecuteCallMetaCall(SMALLUNSGN mod) { + Term ts[4]; ts[0] = ARG1; ts[1] = current_cp_as_integer(); /* p_save_cp */ ts[2] = ARG1; - return(MkApplTerm(PredMetaCall->FunctorOfPred,3,ts)); + ts[3] = ModuleName[mod]; + return(MkApplTerm(PredMetaCall->FunctorOfPred,4,ts)); } static Int -CallError(yap_error_number err) +CallError(yap_error_number err, SMALLUNSGN mod) { if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { - return(CallMetaCall()); + return(CallMetaCall(mod)); } else { Error(err, ARG1, "call/1"); return(FALSE); @@ -189,42 +191,51 @@ p_save_cp(void) } inline static Int -EnterCreepMode(PredEntry *pen) { - PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,*CurrentModulePtr)); - ARG1 = MkPairTerm(Module_Name((CODEADDR)(pen)),ARG1); +EnterCreepMode(PredEntry *pen, Term t) { + PredEntry *PredSpy = RepPredProp(PredPropByFunc(FunctorSpy,0)); + ARG1 = MkPairTerm(Module_Name((CODEADDR)(pen)),t); CreepFlag = CalculateStackGap(); P_before_spy = P; return (CallPredicate(PredSpy, B)); } inline static Int -do_execute(Term t) +do_execute(Term t, int mod) { - if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { - return(CallMetaCall()); + return(CallMetaCall(mod)); } + restart_exec: if (IsVarTerm(t)) { - return CallError(INSTANTIATION_ERROR); + return CallError(INSTANTIATION_ERROR, mod); } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); register CELL *pt; PredEntry *pen; unsigned int i, arity; + f = FunctorOfTerm(t); if (IsExtensionFunctor(f)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, mod); } arity = ArityOfFunctor(f); - pen = RepPredProp(PredPropByFunc(f, *CurrentModulePtr)); + pen = RepPredProp(PredPropByFunc(f, mod)); /* You thought we would be over by now */ /* but no meta calls require special preprocessing */ if (pen->PredFlags & MetaPredFlag) { - return(CallMetaCall()); + if (f == FunctorModule) { + Term tmod = ArgOfTerm(1,t); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + t = ArgOfTerm(2,t); + goto restart_exec; + } + } + return(CallMetaCall(mod)); } if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(pen)); + return(EnterCreepMode(pen, t)); } /* now let us do what we wanted to do from the beginning !! */ /* I cannot use the standard macro here because @@ -252,16 +263,16 @@ do_execute(Term t) else if (a == AtomFail || a == AtomFalse) return(FALSE); /* call may not define new system predicates!! */ - pe = RepPredProp(PredPropByAtom(a, *CurrentModulePtr)); + pe = RepPredProp(PredPropByAtom(a, mod)); if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(pe)); + return(EnterCreepMode(pe, t)); } return (CallPredicate(pe, B)); } else if (IsIntTerm(t)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, mod); } else { /* Is Pair Term */ - return(CallMetaCall()); + return(CallMetaCall(mod)); } } @@ -269,21 +280,13 @@ static Int p_execute(void) { /* '$execute'(Goal) */ Term t = Deref(ARG1); - return(do_execute(t)); + return(do_execute(t, CurrentModule)); } static Int p_execute_in_mod(void) { /* '$execute'(Goal) */ - if (ARG2 != ModuleName[CurrentModule]) { - /* switch modules, but do it in Prolog */ - Term ts[2]; - - ts[0] = ARG2; - ts[1] = ARG1; - ARG1 = MkApplTerm(FunctorModule, 2, ts); - } - return(do_execute(Deref(ARG1))); + return(do_execute(Deref(ARG1), IntOfTerm(ARG2))); } inline static Int @@ -292,62 +295,54 @@ CallMetaCallWithin(void) return (CallPredicate(PredMetaCall, B)); } -/* '$execute_within'(Goal,CutPt,OrigGoal) */ +/* '$execute_within'(Goal,CutPt,OrigGoal,Mod) */ static Int p_execute_within(void) { Term t = Deref(ARG1); + Term tmod = Deref(ARG4); unsigned int arity; Prop pe; Atom a; + SMALLUNSGN mod = LookupModule(tmod); restart_exec: if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { return(CallMetaCallWithin()); } else if (IsVarTerm(t)) { - return CallError(INSTANTIATION_ERROR); + return CallError(INSTANTIATION_ERROR, mod); } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); register unsigned int i; register CELL *pt; if (IsExtensionFunctor(f)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, mod); } - if (f == FunctorModule) { - Term mod = ArgOfTerm(1, t); - if (mod == ModuleName[CurrentModule]) { - /* we can skip this operation */ - /* should catch most cases */ - t = ArgOfTerm(2, t); - goto restart_exec; - } else { - /* I can't do better because I don't have a way of restoring the module */ - return(CallMetaCallWithin()); - } - } else { + { PredEntry *pen; arity = ArityOfFunctor(f); a = NameOfFunctor(f); - if (CurrentModule) - pe = PredPropByFunc(f, *CurrentModulePtr); - else { - pe = GetPredPropByFunc(f, *CurrentModulePtr); - if (pe == NIL) { - return(CallMetaCallWithin()); - } - } + pe = PredPropByFunc(f, mod); pen = RepPredProp(pe); /* You thought we would be over by now */ /* but no meta calls require special preprocessing */ if (pen->PredFlags & MetaPredFlag) { + if (f == FunctorModule) { + Term tmod = ArgOfTerm(1,t); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + t = ArgOfTerm(2,t); + goto restart_exec; + } + } return(CallMetaCallWithin()); } /* at this point check if we should enter creep mode */ if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(pen)); + return(EnterCreepMode(pen,t)); } /* now let us do what we wanted to do from the beginning !! */ /* I cannot use the standard macro here because @@ -369,7 +364,7 @@ p_execute_within(void) } } else if (IsAtomOrIntTerm(t)) { if (IsIntTerm(t)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, mod); } a = AtomOfTerm(t); if (a == AtomTrue || a == AtomOtherwise) @@ -401,9 +396,9 @@ p_execute_within(void) return(FALSE); } else { /* call may not define new system predicates!! */ - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, mod); if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(RepPredProp(pe))); + return(EnterCreepMode(RepPredProp(pe),t)); } return (CallPredicate(RepPredProp(pe), B)); } @@ -423,12 +418,12 @@ p_execute_within2(void) if (PredGoalExpansion->OpcodeOfPred != UNDEF_OPCODE) { return(CallMetaCallWithin()); } else if (IsVarTerm(t)) { - return CallError(INSTANTIATION_ERROR); + return CallError(INSTANTIATION_ERROR, CurrentModule); } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); if (IsExtensionFunctor(f)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, CurrentModule); } { @@ -438,7 +433,7 @@ p_execute_within2(void) register unsigned int i; unsigned int arity = ArityOfFunctor(f); - pe = PredPropByFunc(f, *CurrentModulePtr); + pe = PredPropByFunc(f, CurrentModule); pen = RepPredProp(pe); /* You thought we would be over by now */ /* but no meta calls require special preprocessing */ @@ -447,7 +442,7 @@ p_execute_within2(void) } /* at this point check if we should enter creep mode */ if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(pen)); + return(EnterCreepMode(pen,t)); } /* now let us do what we wanted to do from the beginning !! */ /* I cannot use the standard macro here because @@ -498,13 +493,13 @@ p_execute_within2(void) return(FALSE); } /* call may not define new system predicates!! */ - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, CurrentModule); if (yap_flags[SPY_CREEP_FLAG]) { - return(EnterCreepMode(RepPredProp(pe))); + return(EnterCreepMode(RepPredProp(pe),t)); } return (CallPredicate(RepPredProp(pe), B)); } else if (IsIntTerm(t)) { - return CallError(TYPE_ERROR_CALLABLE); + return CallError(TYPE_ERROR_CALLABLE, CurrentModule); } else { /* Is Pair Term */ return(CallMetaCallWithin()); @@ -514,14 +509,16 @@ p_execute_within2(void) static Int p_execute0(void) -{ /* '$execute'(Goal) */ +{ /* '$execute0'(Goal,Mod) */ Term t = Deref(ARG1); + Term tmod = Deref(ARG2); unsigned int arity; Prop pe; + SMALLUNSGN mod = LookupModule(tmod); if (IsAtomTerm(t)) { Atom a = AtomOfTerm(t); - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, mod); } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); register unsigned int i; @@ -545,7 +542,7 @@ p_execute0(void) XREGS[i] = *pt++; #endif } - pe = GetPredPropByFunc(f, *CurrentModulePtr); + pe = PredPropByFunc(f, mod); } else return (FALSE); /* for the moment */ /* N = arity; */ @@ -557,11 +554,12 @@ static Int p_execute_0(void) { /* '$execute_0'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG2)); Prop pe; Atom a; a = AtomOfTerm(t); - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -569,18 +567,13 @@ static Int p_execute_1(void) { /* '$execute_0'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG3)); Prop pe; Atom a; a = AtomOfTerm(t); ARG1 = ARG2; - if (CurrentModule) - pe = PredProp(a, 1); - else { - pe = GetPredProp(a, 1); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a,1),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -588,19 +581,14 @@ static Int p_execute_2(void) { /* '$execute_2'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG4)); Prop pe; Atom a; a = AtomOfTerm(t); ARG1 = ARG2; ARG2 = ARG3; - if (CurrentModule) - pe = PredProp(a, 2); - else { - pe = GetPredProp(a, 2); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 2),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -608,6 +596,7 @@ static Int p_execute_3(void) { /* '$execute_3'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG5)); Prop pe; Atom a; @@ -615,13 +604,7 @@ p_execute_3(void) ARG1 = ARG2; ARG2 = ARG3; ARG3 = ARG4; - if (CurrentModule) - pe = PredProp(a, 3); - else { - pe = GetPredProp(a, 3); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 3),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -629,6 +612,7 @@ static Int p_execute_4(void) { /* '$execute_4'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG6)); Prop pe; Atom a; @@ -637,13 +621,7 @@ p_execute_4(void) ARG2 = ARG3; ARG3 = ARG4; ARG4 = ARG5; - if (CurrentModule) - pe = PredProp(a, 4); - else { - pe = GetPredProp(a, 4); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 4),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -651,6 +629,7 @@ static Int p_execute_5(void) { /* '$execute_5'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG7)); Prop pe; Atom a; @@ -660,13 +639,7 @@ p_execute_5(void) ARG3 = ARG4; ARG4 = ARG5; ARG5 = ARG6; - if (CurrentModule) - pe = PredProp(a, 5); - else { - pe = GetPredProp(a, 5); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 5),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -674,6 +647,7 @@ static Int p_execute_6(void) { /* '$execute_6'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG8)); Prop pe; Atom a; @@ -684,13 +658,7 @@ p_execute_6(void) ARG4 = ARG5; ARG5 = ARG6; ARG6 = ARG7; - if (CurrentModule) - pe = PredProp(a, 6); - else { - pe = GetPredProp(a, 6); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 6),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -698,6 +666,7 @@ static Int p_execute_7(void) { /* '$execute_7'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG9)); Prop pe; Atom a; @@ -709,13 +678,7 @@ p_execute_7(void) ARG5 = ARG6; ARG6 = ARG7; ARG7 = ARG8; - if (CurrentModule) - pe = PredProp(a, 7); - else { - pe = GetPredProp(a, 7); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 6),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -723,6 +686,7 @@ static Int p_execute_8(void) { /* '$execute_8'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG10)); Prop pe; Atom a; @@ -735,13 +699,7 @@ p_execute_8(void) ARG6 = ARG7; ARG7 = ARG8; ARG8 = ARG9; - if (CurrentModule) - pe = PredProp(a, 8); - else { - pe = GetPredProp(a, 8); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 8),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -749,6 +707,7 @@ static Int p_execute_9(void) { /* '$execute_9'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG11)); Prop pe; Atom a; @@ -762,13 +721,7 @@ p_execute_9(void) ARG7 = ARG8; ARG8 = ARG9; ARG9 = ARG10; - if (CurrentModule) - pe = PredProp(a, 9); - else { - pe = GetPredProp(a, 9); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 9),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -776,6 +729,7 @@ static Int p_execute_10(void) { /* '$execute_10'(Goal) */ Term t = Deref(ARG1); + SMALLUNSGN mod = LookupModule(Deref(ARG12)); Prop pe; Atom a; @@ -790,13 +744,7 @@ p_execute_10(void) ARG8 = ARG9; ARG9 = ARG10; ARG10 = ARG11; - if (CurrentModule) - pe = PredProp(a, 10); - else { - pe = GetPredProp(a, 10); - if (pe == NIL) - return(FALSE); - } + pe = PredPropByFunc(MkFunctor(a, 10),mod); return (CallPredicate(RepPredProp(pe), B)); } @@ -825,20 +773,36 @@ p_pred_goal_expansion_on(void) { static Int p_at_execute(void) { /* '$execute'(Goal,ClauseNumber) */ - Term t = Deref(ARG1), t2 = Deref(ARG2); - unsigned int arity; + Term t = Deref(ARG1), tmod = Deref(ARG2), t2 = Deref(ARG3); + unsigned int arity; Prop pe; Atom a; + SMALLUNSGN mod = LookupModule(tmod); - if (IsAtomTerm(t)) - arity = 0, a = AtomOfTerm(t); - else if (IsApplTerm(t)) { + restart_exec: + if (IsAtomTerm(t)) { + a = AtomOfTerm(t); + pe = PredPropByAtom(a, mod); + arity = 0; + } else if (IsApplTerm(t)) { register Functor f = FunctorOfTerm(t); register unsigned int i; register CELL *pt; if (IsBlobFunctor(f)) return(FALSE); + if (f == FunctorModule) { + Term tmod = ArgOfTerm(1,t); + if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) { + mod = LookupModule(tmod); + t = ArgOfTerm(2,t); + goto restart_exec; + } + if (IsVarTerm(tmod)) { + Error(INSTANTIATION_ERROR, ARG1, "calling clause in debugger"); + } + Error(TYPE_ERROR_ATOM, ARG1, "calling clause in debugger"); + } arity = ArityOfFunctor(f); a = NameOfFunctor(f); /* I cannot use the standard macro here because @@ -857,19 +821,13 @@ p_at_execute(void) #else XREGS[i] = *pt++; #endif + pe = PredPropByFunc(f,mod); } else return (FALSE); /* for the moment */ if (IsVarTerm(t2) || !IsIntTerm(t2)) return (FALSE); /* N = arity; */ /* call may not define new system predicates!! */ - if (CurrentModule) { - pe = PredProp(a, arity); - } else { - pe = GetPredProp(a, arity); - if (pe == NIL) - return(FALSE); - } return (CallClause(RepPredProp(pe), arity, IntOfTerm(t2))); } @@ -973,7 +931,6 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top) B->cp_depth = DEPTH; #endif /* DEPTH_LIMIT */ if (top) { - Term t; #if COROUTINING RESET_VARIABLE((CELL *)GlobalBase); DelayedVars = NewTimedVar((CELL)GlobalBase); @@ -981,14 +938,12 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top) MutableList = NewTimedVar(TermNil); AttsMutableList = NewTimedVar(TermNil); #endif - t = NewTimedVar(MkIntTerm(0)); - CurrentModulePtr = RepAppl(t)+1; } YENV = ASP = (CELL *)B; HB = H; YENV[E_CB] = Unsigned (B); P = (yamop *) CodeAdr; - S = CellPtr (RepPredProp (PredProp (AtomCall, 1))); /* A1 mishaps */ + S = CellPtr (RepPredProp (PredPropByFunc (MkFunctor(AtomCall, 1),0))); /* A1 mishaps */ TopB = B; return(exec_absmi(top)); @@ -996,7 +951,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top) Int -execute_goal(Term t, int nargs) +execute_goal(Term t, int nargs, SMALLUNSGN mod) { Int out; CODEADDR CodeAdr; @@ -1021,7 +976,7 @@ execute_goal(Term t, int nargs) if (IsAtomTerm(t)) { Atom a = AtomOfTerm(t); pt = NULL; - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, mod); } else if (IsApplTerm(t)) { Functor f = FunctorOfTerm(t); @@ -1033,31 +988,23 @@ execute_goal(Term t, int nargs) otherwise I would dereference the argument and might skip a svar */ pt = RepAppl(t)+1; - pe = GetPredPropByFunc(f, *CurrentModulePtr); + pe = PredPropByFunc(f, mod); } else { Error(TYPE_ERROR_CALLABLE,t,"call/1"); return(FALSE); } ppe = RepPredProp(pe); - if (pe != NIL) { - READ_LOCK(ppe->PRWLock); - } - if (pe == NIL || - ppe->OpcodeOfPred == UNDEF_OPCODE || - ppe->PredFlags & (UserCPredFlag|CPredFlag|BasicPredFlag) ) { - if (pe != NIL) { - READ_UNLOCK(ppe->PRWLock); - } - return(CallMetaCall()); + if (pe == NIL) { + return(CallMetaCall(mod)); } + READ_LOCK(ppe->PRWLock); if (IsAtomTerm(t)) { - Atom at = AtomOfTerm(t); - CodeAdr = RepPredProp (PredPropByAtom(at, *CurrentModulePtr))->CodeOfPred; + CodeAdr = RepPredProp (pe)->CodeOfPred; READ_UNLOCK(ppe->PRWLock); out = do_goal(CodeAdr, 0, pt, nargs, FALSE); } else { Functor f = FunctorOfTerm(t); - CodeAdr = RepPredProp (PredPropByFunc (f, *CurrentModulePtr))->CodeOfPred; + CodeAdr = RepPredProp (pe)->CodeOfPred; READ_UNLOCK(ppe->PRWLock); out = do_goal(CodeAdr, ArityOfFunctor(f), pt, nargs, FALSE); } @@ -1181,7 +1128,7 @@ RunTopGoal(Term t) if (IsAtomTerm(t)) { Atom a = AtomOfTerm(t); pt = NULL; - pe = PredPropByAtom(a, *CurrentModulePtr); + pe = PredPropByAtom(a, CurrentModule); arity = 0; } else if (IsApplTerm(t)) { Functor f = FunctorOfTerm(t); @@ -1193,7 +1140,7 @@ RunTopGoal(Term t) /* I cannot use the standard macro here because otherwise I would dereference the argument and might skip a svar */ - pe = GetPredPropByFunc(f, *CurrentModulePtr); + pe = GetPredPropByFunc(f, CurrentModule); pt = RepAppl(t)+1; arity = ArityOfFunctor(f); } else { @@ -1325,10 +1272,10 @@ InitExecFs(void) { InitCPred("$execute", 1, p_execute, 0); InitCPred("$execute_in_mod", 2, p_execute_in_mod, 0); - InitCPred("$execute_within", 3, p_execute_within, 0); + InitCPred("$execute_within", 4, p_execute_within, 0); InitCPred("$execute_within", 1, p_execute_within2, 0); InitCPred("$last_execute_within", 1, p_execute_within2, 0); - InitCPred("$execute", 2, p_at_execute, 0); + InitCPred("$execute", 3, p_at_execute, 0); InitCPred("$call_with_args", 1, p_execute_0, 0); InitCPred("$call_with_args", 2, p_execute_1, 0); InitCPred("$call_with_args", 3, p_execute_2, 0); @@ -1343,7 +1290,7 @@ InitExecFs(void) #ifdef DEPTH_LIMIT InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0); #endif - InitCPred("$execute0", 1, p_execute0, 0); + InitCPred("$execute0", 2, p_execute0, 0); InitCPred("$save_current_choice_point", 1, p_save_cp, 0); InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag); InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag); diff --git a/C/grow.c b/C/grow.c index cea330713..83c6beb6a 100644 --- a/C/grow.c +++ b/C/grow.c @@ -142,8 +142,6 @@ SetHeapRegs(void) AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList))); WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals))); #endif - if (CurrentModulePtr) - CurrentModulePtr = PtoGloAdjust(CurrentModulePtr); } static void @@ -182,8 +180,6 @@ SetStackRegs(void) YENV = PtoLocAdjust(YENV); if (MyTR) MyTR = PtoTRAdjust(MyTR); - if (CurrentModulePtr) - CurrentModulePtr = PtoGloAdjust(CurrentModulePtr); } static void diff --git a/C/heapgc.c b/C/heapgc.c index 4e184093d..bef922985 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -359,7 +359,6 @@ push_registers(Int num_regs, yamop *nextop) TrailTerm(TR+3) = DelayedVars; TR += 4; #endif - TrailTerm(TR++) = AbsAppl(CurrentModulePtr-1); for (i = 1; i <= num_regs; i++) TrailTerm(TR++) = (CELL) XREGS[i]; /* push any live registers we might have hanging around */ @@ -403,7 +402,6 @@ pop_registers(Int num_regs, yamop *nextop) DelayedVars = TrailTerm(ptr++); #endif #endif - CurrentModulePtr = RepAppl(TrailTerm(ptr++))+1; for (i = 1; i <= num_regs; i++) XREGS[i] = TrailTerm(ptr++); /* pop any live registers we might have hanging around */ diff --git a/C/init.c b/C/init.c index 50a469bc4..235f36462 100644 --- a/C/init.c +++ b/C/init.c @@ -169,8 +169,6 @@ sigjmp_buf RestartEnv; /* used to restart after an abort execution */ CPredicate c_predicates[MAX_C_PREDS]; cmp_entry cmp_funcs[MAX_CMP_FUNCS]; -static CELL InitModuleAddress; - /************** declarations local to init.c ************************/ static char *optypes[] = {"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"}; @@ -511,9 +509,13 @@ void InitCPred(char *Name, int Arity, CPredicate code, int flags) { Atom atom = LookupAtom(Name); - PredEntry *pe = RepPredProp(PredProp(atom, Arity)); + PredEntry *pe; yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); + if (Arity) + pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule)); + else + pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); pe->PredFlags = flags | StandardPredFlag | CPredFlag; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; @@ -528,7 +530,6 @@ InitCPred(char *Name, int Arity, CPredicate code, int flags) p_code->opc = opcode(_procceed); { Term mod = CurrentModule; - if (mod) mod = MkIntTerm(mod); pe->ModuleOfPred = mod; } if (!(flags & UserCPredFlag)) { @@ -542,12 +543,17 @@ void InitCmpPred(char *Name, int Arity, CmpPredicate cmp_code, CPredicate code, int flags) { Atom atom = LookupAtom(Name); - PredEntry *pe = RepPredProp(PredProp(atom, Arity)); + PredEntry *pe; yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); + if (Arity) + pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule)); + else + pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); pe->PredFlags = flags | StandardPredFlag | CPredFlag; p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) code; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; + pe->ModuleOfPred = CurrentModule; p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); p_code->u.sla.l2 = (CELL)NIL; p_code->u.sla.s = -Signed(RealEnvSize); @@ -567,14 +573,19 @@ void InitAsmPred(char *Name, int Arity, int code, CPredicate def, int flags) { Atom atom = LookupAtom(Name); - PredEntry *pe = RepPredProp(PredProp(atom, Arity)); + PredEntry *pe; + if (Arity) + pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule)); + else + pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); pe->PredFlags = flags | StandardPredFlag | (code); if (def != NULL) { yamop *p_code = (yamop *)AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)NULL),sla),e)); p_code->u.sla.l = pe->TrueCodeOfPred = (CODEADDR) def; pe->CodeOfPred = pe->FirstClause = pe->LastClause = (CODEADDR) p_code; + pe->ModuleOfPred = CurrentModule; p_code->opc = pe->OpcodeOfPred = opcode(_call_cpred); p_code->u.sla.l2 = (CELL)NIL; p_code->u.sla.s = -Signed(RealEnvSize); @@ -634,7 +645,10 @@ InitCPredBack(char *Name, int Arity, int Extra, CPredicate Start, CPredicate Con PredEntry *pe; Atom atom = LookupAtom(Name); - pe = RepPredProp(PredProp(atom, Arity)); + if (Arity) + pe = RepPredProp(PredPropByFunc(MkFunctor(atom, Arity),CurrentModule)); + else + pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); if (pe->FirstClause != NIL) CleanBack(pe, Start, Cont); else { @@ -753,11 +767,11 @@ InitCodes(void) heap_regs->seq_def = TRUE; heap_regs->getworkfirsttimecode.opc = opcode(_getwork_first_time); heap_regs->getworkcode.opc = opcode(_getwork); - heap_regs->getworkcode.u.ld.p = (CODEADDR)RepPredProp(PredProp(LookupAtom("$getwork"), 0)); + heap_regs->getworkcode.u.ld.p = (CODEADDR)RepPredProp(PredPropByAtom(LookupAtom("$getwork"), 0)); INIT_YAMOP_LTT(&(heap_regs->getworkcode), 0); heap_regs->getworkcode_seq.opc = opcode(_getwork_seq); INIT_YAMOP_LTT(&(heap_regs->getworkcode_seq), 0); - heap_regs->getworkcode_seq.u.ld.p = (CODEADDR)RepPredProp(PredProp(LookupAtom("$getwork_seq"), 0)); + heap_regs->getworkcode_seq.u.ld.p = (CODEADDR)RepPredProp(PredPropByAtom(LookupAtom("$getwork_seq"), 0)); #endif /* YAPOR */ #ifdef TABLING heap_regs->tablecompletioncode.opc = opcode(_table_completion); @@ -970,7 +984,6 @@ InitCodes(void) heap_regs->functor_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1); heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1); heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_module"), 1); - heap_regs->functor_mod_switch = MkFunctor (LookupAtom("$mod_switch"), 2); heap_regs->functor_u_minus = MkFunctor (heap_regs->atom_minus, 1); heap_regs->functor_u_plus = MkFunctor (heap_regs->atom_plus, 1); heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2); @@ -986,12 +999,16 @@ InitCodes(void) heap_regs->yap_lib_dir = NULL; heap_regs->size_of_overflow = 0; /* make sure no one else can use these two atoms */ - *CurrentModulePtr = MkIntTerm(1); - heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),MkIntTerm(1))); - *CurrentModulePtr = MkIntTerm(0); + heap_regs->pred_goal_expansion = RepPredProp(PredPropByFunc(MkFunctor(LookupAtom("goal_expansion"),3),1)); + CurrentModule = 0; heap_regs->dead_clauses = NULL; - heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,3),MkIntTerm(0))); + heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(heap_regs->atom_meta_call,4),0)); ReleaseAtom(AtomOfTerm(heap_regs->term_refound_var)); + { + /* make sure we know about the module predicate */ + PredEntry *modp = RepPredProp(PredPropByFunc(heap_regs->functor_module,0)); + modp->PredFlags |= MetaPredFlag; + } } static void @@ -1032,7 +1049,7 @@ InitYaamRegs(void) #endif at = FullLookupAtom("$undefp"); { - Prop p = GetPredProp (at, 1); + Prop p = GetPredPropByFunc(MkFunctor(at, 1),0); if (p == NIL) { UndefCode = NULL; } else { @@ -1116,7 +1133,6 @@ InitStacks(int Heap, /* the emulator will eventually copy them to its own local register array, but for now they exist */ #endif /* PUSH_REGS */ - CurrentModulePtr = &InitModuleAddress; /* Init signal handling and time */ /* also init memory page size, required by later functions */ diff --git a/C/load_foreign.c b/C/load_foreign.c index d96d0c95a..0931ced75 100644 --- a/C/load_foreign.c +++ b/C/load_foreign.c @@ -121,17 +121,17 @@ void ReOpenLoadForeign(void) { ForeignObj *f_code = ForeignCodeLoaded; - int OldModule = CurrentModule; + SMALLUNSGN OldModule = CurrentModule; YapInitProc InitProc = NULL; while (f_code != NULL) { - *CurrentModulePtr = MkIntTerm(f_code->module); + CurrentModule = f_code->module; if(ReLoadForeign(f_code->objs,f_code->libs,f_code->f,&InitProc)==LOAD_SUCCEEDED) { (*InitProc)(); } f_code = f_code->next; } - *CurrentModulePtr = MkIntTerm(OldModule); + CurrentModule = OldModule; } diff --git a/C/modules.c b/C/modules.c index 0e885cda9..2158fb762 100644 --- a/C/modules.c +++ b/C/modules.c @@ -42,8 +42,6 @@ Module_Name(CODEADDR cap) */ return(ModuleName[CurrentModule]); else { - if (ap->ModuleOfPred) - return (ModuleName[IntOfTerm(ap->ModuleOfPred)]); return (ModuleName[ap->ModuleOfPred]); } } @@ -73,10 +71,10 @@ p_current_module(void) return (0); for (i = 0; i < NoOfModules; ++i) if (ModuleName[i] == t) { - *CurrentModulePtr = MkIntTerm(i); + CurrentModule = i; return (TRUE); } - *CurrentModulePtr = MkIntTerm(NoOfModules); + CurrentModule = NoOfModules; ModuleName[NoOfModules++] = t; return (TRUE); } @@ -92,8 +90,8 @@ p_current_module1(void) static Int p_change_module(void) { /* $change_module(New) */ - Term t = MkIntTerm(LookupModule(Deref(ARG1))); - UpdateTimedVar(AbsAppl(CurrentModulePtr-1), t); + SMALLUNSGN mod = LookupModule(Deref(ARG1)); + CurrentModule = mod; return (TRUE); } @@ -101,7 +99,9 @@ static Int p_module_number(void) { /* $change_module(New) */ Term t = MkIntTerm(LookupModule(Deref(ARG1))); - return (unify(ARG2,t)); + unify(t,ARG2); + ARG2 = t; + return(TRUE); } void @@ -109,10 +109,10 @@ InitModules(void) { ModuleName[PrimitivesModule = 0] = MkAtomTerm(LookupAtom("prolog")); - *CurrentModulePtr = MkIntTerm(0); + CurrentModule = 0; ModuleName[1] = MkAtomTerm(LookupAtom("user")); InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag); InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag); InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag); - InitCPred("$module_number", 2, p_module_number, SafePredFlag|SyncPredFlag); + InitCPred("$module_number", 2, p_module_number, SafePredFlag); } diff --git a/C/save.c b/C/save.c index 3c4cd6961..03a253aec 100644 --- a/C/save.c +++ b/C/save.c @@ -377,7 +377,7 @@ save_regs(int mode) putcellptr((CELL *)TopB); putcellptr((CELL *)DelayedB); putout(FlipFlop); - putcellptr(CurrentModulePtr); + putout(CurrentModule); #ifdef COROUTINING putout(DelayedVars); #endif @@ -672,7 +672,7 @@ get_regs(int flag) TopB = (choiceptr)get_cellptr(); DelayedB = (choiceptr)get_cellptr(); FlipFlop = get_cell(); - CurrentModulePtr = get_cellptr(); + CurrentModule = get_cell(); #ifdef COROUTINING DelayedVars = get_cell(); #endif @@ -1097,7 +1097,6 @@ restore_codes(void) heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS); heap_regs->functor_change_module = FuncAdjust(heap_regs->functor_change_module); heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_module); - heap_regs->functor_mod_switch = FuncAdjust(heap_regs->functor_mod_switch); heap_regs->functor_u_minus = FuncAdjust(heap_regs->functor_u_minus); heap_regs->functor_u_plus = FuncAdjust(heap_regs->functor_u_plus); heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar); @@ -1164,8 +1163,6 @@ restore_regs(int flag) HeapPlus = AddrAdjust(HeapPlus); if (MyTR) MyTR = PtoTRAdjust(MyTR); - if (CurrentModulePtr) - CurrentModulePtr = PtoGloAdjust(CurrentModulePtr); #ifdef COROUTINING DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars))); #ifdef MULTI_ASSIGNMENT_VARIABLES diff --git a/C/stdpreds.c b/C/stdpreds.c index 17ccd9895..ffeab27fb 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -140,7 +140,7 @@ p_flipflop(void) PredEntry *pred; at = FullLookupAtom("$spy"); - pred = RepPredProp(PredProp(at, 1)); + pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0)); SpyCode = pred; return ((int) (FlipFlop = (1 - FlipFlop))); } @@ -164,7 +164,7 @@ p_creep(void) PredEntry *pred; at = FullLookupAtom("$creep"); - pred = RepPredProp(PredProp(at, 1)); + pred = RepPredProp(PredPropByFunc(MkFunctor(at, 1),0)); CreepCode = pred; CreepFlag = Unsigned(LCL0)-Unsigned(H0); return (TRUE); @@ -1362,26 +1362,29 @@ init_current_atom(void) static Int cont_current_predicate(void) { - PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(2,1)); + PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(3,1)); UInt Arity; Atom name; if (pp == NULL) cut_fail(); - EXTRA_CBACK_ARG(2,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule)); + EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule)); Arity = pp->ArityOfPE; if (Arity) name = NameOfFunctor(pp->FunctorOfPred); else name = (Atom)pp->FunctorOfPred; - return (unify(ARG1,MkAtomTerm(name)) && - unify(ARG2, MkIntegerTerm(Arity))); + return (unify(ARG2,MkAtomTerm(name)) && + unify(ARG3, MkIntegerTerm(Arity))); } static Int init_current_predicate(void) { - EXTRA_CBACK_ARG(2,1) = (CELL)MkIntegerTerm((Int)ModulePred[CurrentModule]); + Term t1 = Deref(ARG1); + + if (IsVarTerm(t1) || !IsAtomTerm(t1)) cut_fail(); + EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)ModulePred[LookupModule(t1)]); return (cont_current_predicate()); } @@ -1555,43 +1558,51 @@ p_debug() static Int p_flags(void) -{ /* $flags(+Functor,?OldFlags,?NewFlags) */ +{ /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */ PredEntry *pe; Int newFl; - Term t1 = Deref(ARG1); + Term t2 = Deref(ARG2); + int mod; + + if (IsVarTerm(t1)) + return (FALSE); + if (!IsAtomTerm(t2)) { + return(FALSE); + } + mod = LookupModule(t2); if (IsVarTerm(t1)) return (FALSE); if (IsAtomTerm(t1)) { - pe = RepPredProp(PredProp(AtomOfTerm(t1), 0)); + pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)); } else if (IsApplTerm(t1)) { Functor funt = FunctorOfTerm(t1); - pe = RepPredProp(PredPropByFunc(funt, *CurrentModulePtr)); + pe = RepPredProp(PredPropByFunc(funt, mod)); } else return (FALSE); if (EndOfPAEntr(pe)) return (FALSE); WRITE_LOCK(pe->PRWLock); - if (!unify_constant(ARG2, MkIntTerm(pe->PredFlags))) { + if (!unify_constant(ARG3, MkIntTerm(pe->PredFlags))) { WRITE_UNLOCK(pe->PRWLock); return(FALSE); } - ARG3 = Deref(ARG3); - if (IsVarTerm(ARG3)) { + ARG4 = Deref(ARG4); + if (IsVarTerm(ARG4)) { WRITE_UNLOCK(pe->PRWLock); return (TRUE); - } else if (!IsIntTerm(ARG3)) { + } else if (!IsIntTerm(ARG4)) { union arith_ret v; - if (Eval(ARG3, &v) == long_int_e) { + if (Eval(ARG4, &v) == long_int_e) { newFl = v.Int; } else { WRITE_UNLOCK(pe->PRWLock); - Error(TYPE_ERROR_INTEGER, ARG3, "flags"); + Error(TYPE_ERROR_INTEGER, ARG4, "flags"); return(FALSE); } } else - newFl = IntOfTerm(ARG3); + newFl = IntOfTerm(ARG4); pe->PredFlags = (SMALLUNSGN) newFl; WRITE_UNLOCK(pe->PRWLock); return (TRUE); @@ -2005,10 +2016,10 @@ p_set_yap_flags(void) if (value < 0 || value > 2) return(FALSE); if (value == 1) { - heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,4)); + heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0)); set_fpu_exceptions(TRUE); } else { - heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,3)); + heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(MkFunctor(AtomMetaCall,4),0)); set_fpu_exceptions(FALSE); } yap_flags[LANGUAGE_MODE_FLAG] = value; @@ -2073,7 +2084,7 @@ InitBackCPreds(void) { InitCPredBack("$current_atom", 1, 2, init_current_atom, cont_current_atom, SafePredFlag|SyncPredFlag); - InitCPredBack("$current_predicate", 2, 1, init_current_predicate, cont_current_predicate, + InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate, SafePredFlag|SyncPredFlag); InitCPredBack("current_op", 3, 3, init_current_op, cont_current_op, SafePredFlag|SyncPredFlag); @@ -2134,7 +2145,7 @@ InitCPreds(void) InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag); #endif /* Accessing and changing the flags for a predicate */ - InitCPred("$flags", 3, p_flags, SafePredFlag|SyncPredFlag); + InitCPred("$flags", 4, p_flags, SafePredFlag|SyncPredFlag); /* hiding and unhiding some predicates */ InitCPred("hide", 1, p_hide, SafePredFlag|SyncPredFlag); InitCPred("unhide", 1, p_unhide, SafePredFlag|SyncPredFlag); diff --git a/C/tracer.c b/C/tracer.c index cf3229d8f..6d3b65f4a 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -133,7 +133,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) /* if (vsc_count < 24) return; */ /* if (vsc_count > 500000) exit(0); */ /* if (gc_calls < 1) return;*/ - YP_fprintf(YP_stderr,"%lu %p (%d)", vsc_count, B, CurrentModule); + YP_fprintf(YP_stderr,"%lu (%d)", vsc_count, CurrentModule); /* check_trail_consistency(); */ if (pred == NULL) { return; diff --git a/C/write.c b/C/write.c index 8ecc16cfa..dfa293cd4 100644 --- a/C/write.c +++ b/C/write.c @@ -379,7 +379,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg) Term targs[1]; targs[0] = t; PutValue(AtomPortray, MkAtomTerm(AtomNil)); - execute_goal(MkApplTerm(FunctorPortray, 1, targs),0); + execute_goal(MkApplTerm(FunctorPortray, 1, targs), 0, 1); Use_portray = TRUE; if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue)) return; @@ -456,7 +456,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg) Term targs[1]; targs[0] = t; PutValue(AtomPortray, MkAtomTerm(AtomNil)); - execute_goal(MkApplTerm(FunctorPortray, 1, targs),0); + execute_goal(MkApplTerm(FunctorPortray, 1, targs),0, 1); Use_portray = TRUE; if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue)) return; diff --git a/CHR/Makefile.in b/CHR/Makefile.in index 3164d577d..0993574f1 100644 --- a/CHR/Makefile.in +++ b/CHR/Makefile.in @@ -88,9 +88,9 @@ install: $(CHR_TOP) $(CHR_LICENSE) $(CHR_PROGRAMS) $(CHR_EXAMPLES) -mkdir $(DESTDIR)$(LIBDIR)/library -mkdir $(DESTDIR)$(LIBDIR)/library/chr -mkdir $(DESTDIR)$(LIBDIR)/library/chr/examples - $(INSTALL_DATA) $(CHR_TOP) $(DESTDIR)$(LIBDIR)/library - $(INSTALL_DATA) $(CHR_LICENSE) $(DESTDIR)$(LIBDIR)/library - $(INSTALL_DATA) $(CHR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/chr - $(INSTALL_DATA) $(CHR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/chr/examples + for h in $(CHR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done + for h in $(CHR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done + for h in $(CHR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/chr; done + for h in $(CHR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/chr/examples; done diff --git a/CLPQR/Makefile.in b/CLPQR/Makefile.in index 2f6474d07..b7bc96c74 100644 --- a/CLPQR/Makefile.in +++ b/CLPQR/Makefile.in @@ -27,7 +27,6 @@ CLPQR_PROGRAMS= $(srcdir)/clpqr/arith.pl \ $(srcdir)/clpqr/fourmotz.pl \ $(srcdir)/clpqr/ineq.yap \ $(srcdir)/clpqr/itf3.pl \ - $(srcdir)/clpqr/nf.yap \ $(srcdir)/clpqr/ordering.yap \ $(srcdir)/clpqr/project.pl \ $(srcdir)/clpqr/redund.pl \ @@ -38,19 +37,21 @@ CLPQR_LOCAL= \ $(srcdir)/clpqr/monash.pl \ $(srcdir)/clpqr/printf.pl -CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.pl \ - $(srcdir)/clpr/class.pl\ +CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.yap \ + $(srcdir)/clpr/class.yap\ $(srcdir)/clpr/geler.yap \ + $(srcdir)/clpr/nf.yap \ $(srcdir)/clpr/nfr.yap -CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.pl \ - $(srcdir)/clpq/class.pl\ +CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.yap \ + $(srcdir)/clpq/class.yap \ $(srcdir)/clpq/geler.yap \ + $(srcdir)/clpr/nf.yap \ $(srcdir)/clpq/nfq.yap CLPR_TOP= $(srcdir)/clpr.yap -CLPQ_TOP= $(srcdir)/clpq.pl +CLPQ_TOP= $(srcdir)/clpq.yap CLPQR_LICENSE= $(srcdir)/CLPQR.LICENSE @@ -135,16 +136,15 @@ install: $(CLPR_TOP) $(CLPQ_TOP) $(CLPQR_LICENSE) $(CLPQR_PROGRAMS) $(CLPQR_LOCA -mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples -mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION -mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash - $(INSTALL_DATA) $(CLPQ_TOP) $(DESTDIR)$(LIBDIR)/library - $(INSTALL_DATA) $(CLPR_TOP) $(DESTDIR)$(LIBDIR)/library - $(INSTALL_DATA) $(CLPQR_LICENSE) $(DESTDIR)$(LIBDIR)/library - $(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq - $(INSTALL_DATA) $(CLPQ_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq - $(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr - $(INSTALL_DATA) $(CLPR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr - $(INSTALL_DATA) $(CLPQR_LOCAL) $(DESTDIR)$(LIBDIR)/library/clpqr - $(INSTALL_DATA) $(CLPQR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/clpqr/examples - $(INSTALL_DATA) $(CLPQR_EXAMPLES_MONASH) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash - $(INSTALL_DATA) $(CLPQR_EXAMPLES_SESSION) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION + for h in $(CLPQ_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done + for h in $(CLPR_TOP); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done + for h in $(CLPQR_LICENSE); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library; done + for h in $(CLPQR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done + for h in $(CLPQ_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpq; done + for h in $(CLPR_PROGRAMS); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpr; done + for h in $(CLPQR_LOCAL); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr; done + for h in $(CLPQR_EXAMPLES); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples; done + for h in $(CLPQR_EXAMPLES_MONASH); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash; done + for h in $(CLPQR_EXAMPLES_SESSION); do $(INSTALL_DATA) $$h $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION; done diff --git a/CLPQR/clpq/nfq.yap b/CLPQR/clpq/nfq.yap index 23dd2a381..0cc127099 100644 --- a/CLPQR/clpq/nfq.yap +++ b/CLPQR/clpq/nfq.yap @@ -43,7 +43,7 @@ solve/1 ]). -:- ensure_loaded( nf). +:- ensure_loaded(nf). transg( resubmit_eq(Nf)) --> { diff --git a/CLPQR/clpqr/bv.yap b/CLPQR/clpqr/bv.yap index cade3506c..d1f62e1fc 100644 --- a/CLPQR/clpqr/bv.yap +++ b/CLPQR/clpqr/bv.yap @@ -75,7 +75,7 @@ % ----------------------------------- deref ------------------------------------ % -:- mode deref( +, -). +%:- mode deref( +, -). % deref( Lin, Lind) :- split( Lin, H, I), @@ -84,7 +84,7 @@ deref( Lin, Lind) :- log_deref( Len, H, [], Restd), add_linear_11( Nonvar, Restd, Lind). -:- mode log_deref( +, +, -, -). +%:- mode log_deref( +, +, -, -). % log_deref( 0, Vs, Vs, Lin) :- !, arith_eval( 0, Z), @@ -126,9 +126,11 @@ lin_deref( [v(K,[X^1])|Vs], Li, Lo) :- % % If we see a nonvar here, this is a fault % + deref_var( X, Lin) :- get_atts( X, lin(Lin)), !. -deref_var( X, Lin) :- % create a linear var + +deref_var( X, Lin) :- % create a linear var arith_eval( 0, Z), arith_eval( 1, One), Lin = [Z,Z,X*One], @@ -513,7 +515,7 @@ ub( X, Ub) :- basis( X, Deps), ub_first( Deps, X, Ub). -:- mode ub_first( +, ?, -). +%:- mode ub_first( +, ?, -). % ub_first( [Dep|Deps], X, Tightest) :- ( get_atts( Dep, [lin(Lin),type(Type)]), @@ -527,7 +529,7 @@ ub_first( [Dep|Deps], X, Tightest) :- % % Invariant: Ub >= 0 and decreasing % -:- mode ub( +, ?, +, -). +%:- mode ub( +, ?, +, -). % ub( [], _, T0,T0). ub( [Dep|Deps], X, T0,T1) :- @@ -545,7 +547,7 @@ lb( X, Lb) :- basis( X, Deps), lb_first( Deps, X, Lb). -:- mode lb_first( +, ?, -). +%:- mode lb_first( +, ?, -). % lb_first( [Dep|Deps], X, Tightest) :- ( get_atts( Dep, [lin(Lin),type(Type)]), @@ -559,7 +561,7 @@ lb_first( [Dep|Deps], X, Tightest) :- % % Invariant: Lb =< 0 and increasing % -:- mode lb( +, ?, +, -). +%:- mode lb( +, ?, +, -). % lb( [], _, T0,T0). lb( [Dep|Deps], X, T0,T1) :- @@ -576,7 +578,7 @@ lb( [Dep|Deps], X, T0,T1) :- % % Lb =< 0 for feasible rows % -:- mode lb_inner( +, ?, +, -, -). +%:- mode lb_inner( +, ?, +, -, -). % lb_inner( t_l(L), X, Lin, t_L(L), Lb) :- nf_rhs_x( Lin, X, Rhs, K), @@ -602,7 +604,7 @@ lb_inner( t_lu(L,U), X, Lin, W, Lb) :- % % Ub >= 0 for feasible rows % -:- mode ub_inner( +, ?, +, -, -). +%:- mode ub_inner( +, ?, +, -, -). % ub_inner( t_l(L), X, Lin, t_L(L), Ub) :- nf_rhs_x( Lin, X, Rhs, K), diff --git a/CLPQR/clpqr/expand.yap b/CLPQR/clpqr/expand.yap index 5aa4eff54..6e1fd981d 100644 --- a/CLPQR/clpqr/expand.yap +++ b/CLPQR/clpqr/expand.yap @@ -195,3 +195,4 @@ l2conj( [X|Xs], Conj) :- ( Xs = [], Conj = X ; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc) ). + diff --git a/CLPQR/clpqr/monash.pl b/CLPQR/clpqr/monash.pl index c3efaa392..6eabb455d 100644 --- a/CLPQR/clpqr/monash.pl +++ b/CLPQR/clpqr/monash.pl @@ -24,4 +24,4 @@ :- prolog_flag( unknown, _, fail). dump. % cheating -dump( L) :- ordering( L). \ No newline at end of file +dump( L) :- ordering( L). diff --git a/CLPQR/clpr.pl b/CLPQR/clpr.pl index ecffb306d..83e815035 100644 --- a/CLPQR/clpr.pl +++ b/CLPQR/clpr.pl @@ -58,3 +58,4 @@ this_linear_solver( clpr). 'clpr/bb', 'clpr/dump' ]). + diff --git a/CLPQR/clpr.yap b/CLPQR/clpr.yap index e41edad00..128e98255 100644 --- a/CLPQR/clpr.yap +++ b/CLPQR/clpr.yap @@ -10,9 +10,9 @@ % Author: Christian Holzbaur christian@ai.univie.ac.at % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -:- sequential. +% :- sequential. -:- default_sequential(X), write(X), nl. +% :- default_sequential(X), write(X), nl. :- module( clpr, [ {}/1, @@ -43,8 +43,8 @@ this_linear_solver( clpr). :- ensure_loaded( [ - 'clpr/itf3', - 'clpr/store' % early because of macros + 'clpqr/itf3', + 'clpqr/store' % early because of macros % but after itf3 ]). @@ -54,11 +54,11 @@ this_linear_solver( clpr). :- ensure_loaded( [ - 'clpr/project', - 'clpr/bv', - 'clpr/ineq', - 'clpr/redund', - 'clpr/fourmotz', - 'clpr/bb', - 'clpr/dump' + 'clpqr/project', + 'clpqr/bv', + 'clpqr/ineq', + 'clpqr/redund', + 'clpqr/fourmotz', + 'clpqr/bb', + 'clpqr/dump' ]). diff --git a/CLPQR/clpr/arith_r.pl b/CLPQR/clpr/arith_r.pl index c4930141a..12790d408 100644 --- a/CLPQR/clpr/arith_r.pl +++ b/CLPQR/clpr/arith_r.pl @@ -31,6 +31,7 @@ arith_module( nfr). :- dynamic user:goal_expansion/3. % + user:goal_expansion(arith_eval(Term,Res), Module, Expansion) :- arith_module( Module), compile_R( Term, Res, Code), diff --git a/CLPQR/clpr/class.pl b/CLPQR/clpr/class.pl index ef4d065e2..29134eb7f 100644 --- a/CLPQR/clpr/class.pl +++ b/CLPQR/clpr/class.pl @@ -110,3 +110,4 @@ delete_first( [Y|Ys], X, Res) :- Res = [Y|Tail], delete_first( Ys, X, Tail) ). + diff --git a/CLPQR/clpr/geler.yap b/CLPQR/clpr/geler.yap index 441e6deed..a0143168b 100644 --- a/CLPQR/clpr/geler.yap +++ b/CLPQR/clpr/geler.yap @@ -114,6 +114,7 @@ run( Mutex, G) :- var(Mutex), Mutex=done, call( G). :- meta_predicate geler(+,:). % + geler( Vars, Goal) :- attach( Vars, run(_Mutex,Goal)). diff --git a/CLPQR/clpr/nfr.yap b/CLPQR/clpr/nfr.yap index 6dc7a99a2..930146ce7 100644 --- a/CLPQR/clpr/nfr.yap +++ b/CLPQR/clpr/nfr.yap @@ -10,7 +10,6 @@ % Author: Christian Holzbaur christian@ai.univie.ac.at % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - :- module( nfr, [ {}/1, @@ -43,7 +42,7 @@ solve/1 ]). -:- ensure_loaded( nf). +:- ensure_loaded(nf). transg( resubmit_eq(Nf)) --> { diff --git a/H/Heap.h b/H/Heap.h index e305f75e0..aa5e54017 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -10,7 +10,7 @@ * File: Heap.h * * mods: * * comments: Heap Init Structure * -* version: $Id: Heap.h,v 1.12 2001-10-31 20:16:48 vsc Exp $ * +* version: $Id: Heap.h,v 1.13 2001-11-15 00:01:40 vsc Exp $ * *************************************************************************/ /* information that can be stored in Code Space */ @@ -97,7 +97,7 @@ typedef struct various_codes { Term mutable_list; Term atts_mutable_list; #endif - CELL *wake_up_code; + PredEntry *wake_up_code; #endif struct pred_entry *creep_code; struct pred_entry *undef_code; @@ -253,7 +253,6 @@ typedef struct various_codes { functor_stream_eOS, functor_change_module, functor_current_module, - functor_mod_switch, functor_u_minus, functor_u_plus, functor_v_bar, @@ -295,8 +294,6 @@ typedef struct various_codes { #define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode )) #endif /* TABLING */ #define FAILCODE ((CODEADDR)&(heap_regs->failcode )) -#define FAILCODE ((CODEADDR)&(heap_regs->failcode )) -#define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode )) #define TRUSTFAILCODE ((CODEADDR)&(heap_regs->trustfailcode )) #define YESCODE ((CODEADDR)&(heap_regs->yescode )) #define NOCODE ((CODEADDR)&(heap_regs->nocode )) diff --git a/H/Regs.h b/H/Regs.h index cc7c1bf62..a5cc22d94 100644 --- a/H/Regs.h +++ b/H/Regs.h @@ -10,7 +10,7 @@ * File: Regs.h * * mods: * * comments: YAP abstract machine registers * -* version: $Id: Regs.h,v 1.5 2001-09-24 18:07:16 vsc Exp $ * +* version: $Id: Regs.h,v 1.6 2001-11-15 00:01:43 vsc Exp $ * *************************************************************************/ @@ -96,7 +96,7 @@ typedef struct Term TermNil_; /* 20 */ #endif #endif - CELL *CurrentModulePtr_; + SMALLUNSGN CurrentModulePtr_; #if (defined(YAPOR) && defined(SBA)) || defined(TABLING) CELL *H_FZ_; choiceptr B_FZ_; @@ -639,8 +639,7 @@ EXTERN inline void restore_B(void) { #ifdef COROUTINING #define DelayedVars REGS.DelayedVars_ #endif -#define CurrentModulePtr REGS.CurrentModulePtr_ -#define CurrentModule IntOfTerm(*REGS.CurrentModulePtr_) +#define CurrentModule REGS.CurrentModulePtr_ #define REG_SIZE sizeof(REGS)/sizeof(CELL *) diff --git a/H/Yapproto.h b/H/Yapproto.h index 51e241bcb..07b5a832f 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -10,7 +10,7 @@ * File: Yap.proto * * mods: * * comments: Function declarations for YAP * -* version: $Id: Yapproto.h,v 1.4 2001-10-30 16:42:05 vsc Exp $ * +* version: $Id: Yapproto.h,v 1.5 2001-11-15 00:01:43 vsc Exp $ * *************************************************************************/ /* prototype file for Yap */ @@ -36,8 +36,8 @@ Atom STD_PROTO(LookupAtom,(char *)); Atom STD_PROTO(FullLookupAtom,(char *)); void STD_PROTO(LookupAtomWithAddress,(char *,AtomEntry *)); Term STD_PROTO(MkApplTerm,(Functor,unsigned int,Term *)); -Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, Term)); -Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, Term)); +Prop STD_PROTO(NewPredPropByFunctor,(struct FunctorEntryStruct *, SMALLUNSGN)); +Prop STD_PROTO(NewPredPropByAtom,(struct AtomEntryStruct *, SMALLUNSGN)); Functor STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int)); Functor STD_PROTO(MkFunctor,(Atom,unsigned int)); void STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *)); @@ -53,10 +53,9 @@ CELL STD_PROTO(*ArgsOfSFTerm,(Term)); #endif int STD_PROTO(LookupModule,(Term)); -Prop STD_PROTO(GetPredProp,(Atom,unsigned int)); -Prop STD_PROTO(GetPredPropByAtom,(Atom, Term)); -Prop STD_PROTO(GetPredPropByFunc,(Functor, Term)); -Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int)); +Prop STD_PROTO(GetPredPropByAtom,(Atom, int)); +Prop STD_PROTO(GetPredPropByFunc,(Functor, int)); +Prop STD_PROTO(GetPredPropHavingLock,(Atom,unsigned int,SMALLUNSGN)); Prop STD_PROTO(GetExpProp,(Atom,unsigned int)); Prop STD_PROTO(GetExpPropHavingLock,(AtomEntry *,unsigned int)); Term STD_PROTO(Module_Name, (CODEADDR)); @@ -120,7 +119,7 @@ int STD_PROTO(iequ,(Term,Term)); void STD_PROTO(InitCmpPreds,(void)); /* compiler.c */ -CODEADDR STD_PROTO(cclause,(Term, int)); +CODEADDR STD_PROTO(cclause,(Term, int, int)); /* computils.c */ @@ -149,10 +148,10 @@ void STD_PROTO(InitEval,(void)); Int STD_PROTO(EvFArt,(Term)); /* exec.c */ -Term STD_PROTO(ExecuteCallMetaCall,(void)); +Term STD_PROTO(ExecuteCallMetaCall,(SMALLUNSGN mod)); void STD_PROTO(InitExecFs,(void)); int STD_PROTO(RunTopGoal,(Term)); -Int STD_PROTO(execute_goal,(Term, int)); +Int STD_PROTO(execute_goal,(Term, int, SMALLUNSGN)); int STD_PROTO(exec_absmi,(int)); @@ -278,7 +277,7 @@ void STD_PROTO(InitUtilCPreds,(void)); /* yap.c */ void STD_PROTO(Abort,(char *msg, ...)); -void STD_PROTO(addclause,(Term,CODEADDR,int)); +void STD_PROTO(addclause,(Term,CODEADDR,int,int)); /* ypsocks.c */ void STD_PROTO(InitSockets,(void)); diff --git a/H/compile.h b/H/compile.h index d8a91d2e0..46cf59a18 100644 --- a/H/compile.h +++ b/H/compile.h @@ -250,7 +250,7 @@ void STD_PROTO(emit,(compiler_vm_op,Int,CELL)); void STD_PROTO(emit_3ops,(compiler_vm_op,CELL,CELL,CELL)); CELL *STD_PROTO(emit_extra_size,(compiler_vm_op,CELL,int)); char *STD_PROTO(AllocCMem,(int)); -int STD_PROTO(is_a_test_pred,(Term)); +int STD_PROTO(is_a_test_pred,(Term, SMALLUNSGN)); void STD_PROTO(bip_name,(Int, char *)); #ifdef DEBUG void STD_PROTO(ShowCode,(void)); diff --git a/Makefile.in b/Makefile.in index 7b23afd29..eecb9afc9 100644 --- a/Makefile.in +++ b/Makefile.in @@ -9,7 +9,7 @@ BINDIR = $(ROOTDIR)/bin # # where YAP should look for libraries # -LIBDIR=$(ROOTDIR)/lib/ +LIBDIR=$(ROOTDIR)/lib YAPLIBDIR=$(ROOTDIR)/lib/Yap # # where the includes should be stored diff --git a/OPTYap/opt.preds.c b/OPTYap/opt.preds.c index c0e78fa7a..7fb11dbde 100644 --- a/OPTYap/opt.preds.c +++ b/OPTYap/opt.preds.c @@ -79,9 +79,9 @@ void init_optyap_preds(void) { InitCPred("$parallel_yes_answer", 0, p_parallel_yes_answer, SafePredFlag); #endif /* YAPOR */ #ifdef TABLING - InitCPred("$table", 1, p_table, SafePredFlag); - InitCPred("$abolish_trie", 1, p_abolish_trie, SafePredFlag); - InitCPred("$show_trie", 2, p_show_trie, SafePredFlag); + InitCPred("$table", 2, p_table, SafePredFlag); + InitCPred("$do_abolish_trie", 2, p_abolish_trie, SafePredFlag); + InitCPred("$show_trie", 3, p_show_trie, SafePredFlag); #endif /* TABLING */ #ifdef STATISTICS InitCPred("show_frames", 0, p_show_frames, SafePredFlag); @@ -183,25 +183,31 @@ int start_yapor(void) { static int p_sequential(void) { - Term t; + Term t, tmod; Atom at; int arity; PredEntry *pe; + SMALLUNSGN mod; t = Deref(ARG1); + tmod = Deref(ARG2); + if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) { + return(FALSE); + } + mod = LookupModule(tmod); if (IsAtomTerm(t)) { at = AtomOfTerm(t); arity = 0; + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor func = FunctorOfTerm(t); at = NameOfFunctor(func); arity = ArityOfFunctor(func); + pe = RepPredProp(PredPropByFunc(func, mod)); } else { abort_optyap("unknown term in function p_sequential"); - at = NULL; /* just to avoid gcc warning */ - arity = 0; /* just to avoid gcc warning */ + return(FALSE); } - pe = RepPredProp(PredProp(at, arity)); pe->PredFlags |= SequentialPredFlag; return (TRUE); } @@ -449,25 +455,28 @@ void answer_to_stdout(char *answer) { #ifdef TABLING static int p_table(void) { - Term t; - Atom at; - int arity; + Term t, t2; PredEntry *pe; tab_ent_ptr te; sg_node_ptr sg_node; + SMALLUNSGN mod; t = Deref(ARG1); + t2 = Deref(ARG2); + if (IsVarTerm(t2) || !IsAtomTerm(t2)) { + return (FALSE); + } else { + mod = LookupModule(t2); + } if (IsAtomTerm(t)) { - at = AtomOfTerm(t); - arity = 0; + Atom at = AtomOfTerm(t); + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t)) { Functor func = FunctorOfTerm(t); - at = NameOfFunctor(func); - arity = ArityOfFunctor(func); + pe = RepPredProp(PredPropByFunc(func, mod)); } else return (FALSE); - pe = RepPredProp(PredProp(at, arity)); pe->PredFlags |= TabledPredFlag; new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); new_table_entry(te, sg_node); @@ -479,25 +488,31 @@ int p_table(void) { static int p_abolish_trie(void) { - Term t; - Atom at; - int arity; + Term t, tmod; + SMALLUNSGN mod; tab_ent_ptr tab_ent; sg_hash_ptr hash; sg_node_ptr sg_node; + UInt arity; t = Deref(ARG1); + tmod = Deref(ARG2); + if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) { + return (FALSE); + } else { + mod = LookupModule(tmod); + } if (IsAtomTerm(t)) { - at = AtomOfTerm(t); + Atom at = AtomOfTerm(t); + tab_ent = RepPredProp(PredPropByAtom(at, mod))->TableOfPred; arity = 0; } else if (IsApplTerm(t)) { Functor func = FunctorOfTerm(t); - at = NameOfFunctor(func); + tab_ent = RepPredProp(PredPropByFunc(func, mod))->TableOfPred; arity = ArityOfFunctor(func); } else return (FALSE); - tab_ent = RepPredProp(PredProp(at, arity))->TableOfPred; hash = TabEnt_hash_chain(tab_ent); TabEnt_hash_chain(tab_ent) = NULL; free_subgoal_hash_chain(hash); @@ -513,24 +528,32 @@ int p_abolish_trie(void) { static int p_show_trie(void) { - Term t1, t2; - Atom at; - int arity; + Term t1, t2, tmod; PredEntry *pe; + SMALLUNSGN mod; + Atom at; + UInt arity; t1 = Deref(ARG1); + tmod = Deref(ARG2); + if (IsVarTerm(tmod) || !IsAtomTerm(tmod)) { + return (FALSE); + } else { + mod = LookupModule(tmod); + } if (IsAtomTerm(t1)) { at = AtomOfTerm(t1); arity = 0; + pe = RepPredProp(PredPropByAtom(at, mod)); } else if (IsApplTerm(t1)) { Functor func = FunctorOfTerm(t1); at = NameOfFunctor(func); arity = ArityOfFunctor(func); + pe = RepPredProp(PredPropByFunc(func, mod)); } else - return(FALSE); - pe = RepPredProp(PredProp(at, arity)); + return (FALSE); - t2 = Deref(ARG2); + t2 = Deref(ARG3); if (IsVarTerm(t2)) { Term ta = MkAtomTerm(LookupAtom("stdout")); Bind((CELL *)t2, ta); diff --git a/library/atts.yap b/library/atts.yap index c57da8205..88343987e 100644 --- a/library/atts.yap +++ b/library/atts.yap @@ -134,7 +134,7 @@ do_verify_attributes([], _, _, []). do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :- existing_attribute(_,Mod,Key), get_att(AttVar,Key,_), - Mod:current_predicate(verify_attributes, verify_attributes(_,_,_)), !, + current_predicate(verify_attributes, Mod:verify_attributes(_,_,_)), !, do_verify_attributes(Mods, AttVar, Binding, Goals), Mod:verify_attributes(AttVar, Binding, Goal). do_verify_attributes([_|Mods], AttVar, Binding, Goals) :- @@ -171,7 +171,7 @@ fetch_att_goals([_|LMods], Att, LGoal) :- call_module_attributes(Mod, AttV, G1) :- existing_attribute(_,Mod,Key), get_att(AttV,Key,_), !, - Mod:current_predicate(attribute_goal, attribute_goal(AttV,G1)), + current_predicate(attribute_goal, Mod:attribute_goal(AttV,G1)), Mod:attribute_goal(AttV, G1). simplify_trues((A,B), NG) :- !, diff --git a/m4/Yatom.h.m4 b/m4/Yatom.h.m4 index 79fa3cf8c..2bac584b3 100644 --- a/m4/Yatom.h.m4 +++ b/m4/Yatom.h.m4 @@ -203,7 +203,7 @@ typedef struct pred_entry { Prop NextOfPE; /* used to chain properties */ PropFlags KindOfPE; /* kind of property */ unsigned int ArityOfPE; /* arity of property */ - Term ModuleOfPred; /* module for this definition */ + int ModuleOfPred; /* module for this definition */ CELL PredFlags; CODEADDR CodeOfPred; /* code address */ CODEADDR TrueCodeOfPred; /* if needing to spy or to lock */ @@ -496,10 +496,9 @@ Atom STD_PROTO(GetOp,(OpEntry *,int *,int)); /* vsc: redefined to GetAProp to avoid conflicts with Windows header files */ Prop STD_PROTO(GetAProp,(Atom,PropFlags)); Prop STD_PROTO(GetAPropHavingLock,(AtomEntry *,PropFlags)); -Prop STD_PROTO(PredProp,(Atom,unsigned int)); EXTERN inline Prop -PredPropByFunc(Functor f, Term cur_mod) +PredPropByFunc(Functor f, SMALLUNSGN cur_mod) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; @@ -520,7 +519,7 @@ PredPropByFunc(Functor f, Term cur_mod) } EXTERN inline Prop -PredPropByAtom(Atom at, Term cur_mod) +PredPropByAtom(Atom at, SMALLUNSGN cur_mod) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; diff --git a/pl/boot.yap b/pl/boot.yap index 2b17e2998..e89805116 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -242,12 +242,11 @@ repeat :- '$repeat'. '$execute_command'(R,_,top) :- db_reference(R), !, throw(error(type_error(callable,R),meta_call(R))). '$execute_command'((:-G),_,Option) :- !, - '$process_directive'(G, Option), + '$current_module'(M), + '$process_directive'(G, Option, M), fail. '$execute_command'((?-G),V,_) :- !, '$execute_command'(G,V,top). -'$execute_command'((Mod:G),V,Option) :- !, - '$mod_switch'(Mod,'$execute_command'(G,V,Option)). '$execute_command'(G,V,Option) :- '$continue_with_command'(Option,V,G). % @@ -257,38 +256,44 @@ repeat :- '$repeat'. % SICStus accepts everything in files % YAP accepts everything everywhere % -'$process_directive'(G, top) :- +'$process_directive'(G, top, M) :- '$access_yap_flags'(8, 0), !, % YAP mode, go in and do it, - '$process_directive'(G, consult). -'$process_directive'(G, top) :- !, + '$process_directive'(G, consult, M). +'$process_directive'(G, top, _) :- !, throw(error(context_error((:- G),clause),query)). % % always allow directives. % -'$process_directive'(D, Mode) :- +'$process_directive'(D, Mode, M) :- '$directive'(D), !, - ( '$exec_directive'(D, Mode) -> true ; true ). + ( '$exec_directive'(D, Mode, M) -> true ; true ). % % allow multiple directives % -'$process_directive'((G1,G2), Mode) :- +'$process_directive'((G1,G2), Mode, M) :- '$all_directives'(G1), '$all_directives'(G2), !, - '$exec_directives'(G1, Mode), - '$exec_directives'(G2, Mode). + '$exec_directives'(G1, Mode, M), + '$exec_directives'(G2, Mode, M). +% +% allow modules +% +'$process_directive'(M:G, Mode, _) :- !, + '$process_directive'(G, Mode, M). % % ISO does not allow goals (use initialization). % -'$process_directive'(D, _) :- +'$process_directive'(D, _, M) :- '$access_yap_flags'(8, 1), !, % ISO Prolog mode, go in and do it, throw(error(context_error((:- D),query),directive)). % % but YAP and SICStus does. % -'$process_directive'(G, _) :- - '$current_module'(M), +'$process_directive'(G, _, M) :- ( '$do_yes_no'(M:G) -> true ; '$format'(user_error,":- ~w:~w failed.~n",[M,G]) ). +'$all_directives'(M:G1) :- !, + '$all_directives'(G1). '$all_directives'((G1,G2)) :- !, '$all_directives'(G1), '$all_directives'(G2). @@ -309,7 +314,7 @@ repeat :- '$repeat'. % module prefixes all over the place, although unnecessarily so. % '$go_compile_clause'(M:G,V,N) :- !, - '$mod_switch'(M,'$go_compile_clause'(G,V,N)). + '$go_compile_clause'(G,V,N,Mod). '$go_compile_clause'((M:G :- B),V,N) :- !, '$current_module'(M1), (M1 = M -> @@ -317,35 +322,39 @@ repeat :- '$repeat'. ; '$preprocess_clause_before_mod_change'((G:-B),M1,M,NG) ), - '$mod_switch'(M,'$go_compile_clause'(NG,V,N)). + '$go_compile_clause'(NG,V,N,M). '$go_compile_clause'(G,V,N) :- - '$prepare_term'(G,V,G0,G1), - '$$compile'(G1,G0,N). + '$current_module'(Mod), + '$go_compile_clause'(G,V,N,Mod). -'$prepare_term'(G,V,G0,G1) :- +'$go_compile_clause'(G, V, N, Mod) :- + '$prepare_term'(G, V, G0, G1, Mod), + '$$compile'(G1, G0, N, Mod). + +'$prepare_term'(G,V,G0,G1, Mod) :- ( '$get_value'('$syntaxcheckflag',on) -> '$check_term'(G,V) ; true ), - '$precompile_term'(G, G0, G1). + '$precompile_term'(G, G0, G1, Mod). % process an input clause -'$$compile'(G,G0,L) :- +'$$compile'(G, G0, L, Mod) :- '$head_and_body'(G,H,_), '$inform_of_clause'(H,L), - '$flags'(H, Fl, Fl), - ( Fl /\ 16'002008 =\= 0 -> '$assertz_dynamic'(L,G,G0) ; - '$$compile_stat'(G,G0,L,H) ). + '$flags'(H, Mod, Fl, Fl), + ( Fl /\ 16'002008 =\= 0 -> '$assertz_dynamic'(L,G,G0,Mod) ; + '$$compile_stat'(G,G0,L,H, Mod) ). % process a clause for a static predicate -'$$compile_stat'(G,G0,L,H) :- - '$compile'(G,L), +'$$compile_stat'(G,G0,L,H, Mod) :- + '$compile'(G,L,Mod), % first occurrence of this predicate in this file, % check if we need to erase the source and if % it is a multifile procedure. - '$flags'(H,Fl,Fl), + '$flags'(H,Mod,Fl,Fl), ( '$get_value'('$abol',true) -> - ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ), - ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true ) + ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H, Mod) ; true ), + ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true ) ; true ), @@ -354,42 +363,40 @@ repeat :- '$repeat'. true ; % and store our clause - '$store_stat_clause'(G0, H, L) + '$store_stat_clause'(G0, H, L, Mod) ). -'$store_stat_clause'(G0, H, L) :- +'$store_stat_clause'(G0, H, L, M) :- '$head_and_body'(G0,H0,B0), - '$record_stat_source'(H,(H0:-B0),L,R), - functor(H, Na, Ar), - ( '$is_multifile'(Na,Ar) -> + '$record_stat_source'(M:H,(H0:-B0),L,R), + ( '$is_multifile'(H,M) -> '$get_value'('$consulting_file',F), - '$current_module'(M), + functor(H, Na, Ar), '$recordz'('$multifile'(_,_,_), '$mf'(Na,Ar,M,F,R), _) ; true ). -'$erase_source'(G) :- functor(G, Na, A), - '$is_multifile'(Na,A), !, - '$erase_mf_source'(Na,A). -'$erase_source'(G) :- '$recordedp'(G,_,R), erase(R), fail. -'$erase_source'(_). +'$erase_source'(G, M) :- + '$is_multifile'(G, M), !, + functor(G, Na, Ar), + '$erase_mf_source'(Na, Ar, M). +'$erase_source'(G, M) :- '$recordedp'(M:G,_,R), erase(R), fail. +'$erase_source'(_, _). -'$erase_mf_source'(Na,A) :- +'$erase_mf_source'(Na, Ar, M) :- '$get_value'('$consulting_file',F), - '$current_module'(M), '$recorded'('$multifile'(_,_,_), '$mf'(Na,A,M,F,R), R1), erase(R1), erase(R), fail. -'$erase_mf_source'(Na,A) :- +'$erase_mf_source'(Na, A, M) :- '$get_value'('$consulting_file',F), - '$current_module'(M), '$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1), erase(R1), erase(R), fail. -'$erase_mf_source'(_,_). +'$erase_mf_source'(_,_,_). '$check_if_reconsulted'(N,A) :- '$recorded'('$reconsulted',X,_), @@ -416,9 +423,9 @@ repeat :- '$repeat'. % *************************** '$query'(G,V) :- - \+ '$undefined'('$yapor_on'), + \+ '$undefined'('$yapor_on', prolog), '$yapor_on', - \+ '$undefined'('$start_yapor'), + \+ '$undefined'('$start_yapor', prolog), '$parallelizable'(G), !, '$parallel_query'(G,V), fail. @@ -614,31 +621,31 @@ incore(G) :- '$execute'(G). % % standard meta-call, called if $execute could not do everything. % -'$meta_call'(G) :- +'$meta_call'(G, M) :- '$save_current_choice_point'(CP), - '$call'(G, CP, G). + '$call'(G, CP, G, M). % % do it in ISO mode. % -'$meta_call'(G,_ISO) :- +'$meta_call'(G,_ISO,M) :- '$iso_check_goal'(G,G), '$save_current_choice_point'(CP), - '$call'(G, CP, G). + '$call'(G, CP, G, M). -'$meta_call'(G, CP, G0) :- - '$call'(G, CP,G0). +'$meta_call'(G, CP, G0, M) :- + '$call'(G, CP, G0, M). -'$spied_meta_call'(G) :- +'$spied_meta_call'(G, M) :- '$save_current_choice_point'(CP), - '$spied_call'(G, CP, G). + '$spied_call'(G, CP, G, M). -'$spied_meta_call'(G, CP, G0) :- - '$spied_call'(G, CP, G0). +'$spied_meta_call'(G, CP, G0, M) :- + '$spied_call'(G, CP, G0, M). -'$call'(G, CP, G0, _) :- /* iso version */ +'$call'(G, CP, G0, _, M) :- /* iso version */ '$iso_check_goal'(G,G0), - '$call'(G, CP,G0). + '$call'(G, CP, G0, M). ','(A,B) :- @@ -663,115 +670,110 @@ incore(G) :- '$execute'(G). not(A) :- \+ '$execute_within'(A). -Mod:G :- '$mod_switch'(Mod,'$execute_within'(G)). - -'$call'(M:_,_,G0) :- var(M), !, +'$call'(M:_,_,G0,_) :- var(M), !, throw(error(instantiation_error,call(G0))). -'$call'(M:G,CP,G0) :- !, - '$mod_switch'(M,'$call'(G,CP,G0)). -'$call'((X->Y),CP,G0) :- !, +'$call'(M:G,CP,G0,_) :- !, + '$call'(G,CP,G0,M). +'$call'((X,Y),CP,G0,M) :- !, + '$execute_within'(X,CP,G0,M), + '$execute_within'(Y,CP,G0,M). +'$call'((X->Y),CP,G0,M) :- !, ( - '$execute_within'(X,CP,G0) + '$execute_within'(X,CP,G0,M) -> - '$execute_within'(Y,CP,G0) + '$execute_within'(Y,CP,G0,M) ). -'$call'((X->Y; Z),CP,G0) :- !, +'$call'((X->Y; Z),CP,G0,M) :- !, ( - '$execute_within'(X,CP,G0) + '$execute_within'(X,CP,G0,M) -> - '$execute_within'(Y,CP,G0) + '$execute_within'(Y,CP,G0,M) ; - '$execute_within'(Z,CP,G0) + '$execute_within'(Z,CP,G0,M) ). -'$call'((A;B),CP,G0) :- !, +'$call'((A;B),CP,G0,M) :- !, ( - '$execute_within'(A,CP,G0) + '$execute_within'(A,CP,G0,M) ; - '$execute_within'(B,CP,G0) + '$execute_within'(B,CP,G0,M) ). -'$call'((A|B),CP, G0) :- !, +'$call'((A|B),CP, G0,M) :- !, ( - '$execute_within'(A,CP,G0) + '$execute_within'(A,CP,G0,M) ; - '$execute_within'(B,CP,G0) + '$execute_within'(B,CP,G0,M) ). -'$call'(\+ X, _, _) :- !, +'$call'(\+ X, _, _,_) :- !, \+ '$execute'(X). -'$call'(not(X), _, _) :- !, +'$call'(not(X), _, _,_) :- !, \+ '$execute'(X). -'$call'(!, CP, _) :- !, +'$call'(!, CP, _,_) :- !, '$$cut_by'(CP). -'$call'([A|B],_, _) :- !, +'$call'([A|B],_, _,_) :- !, '$csult'([A|B]). -'$call'(A, _, _) :- +'$call'(A, _, _,CurMod) :- ( % goal_expansion is defined, or '$pred_goal_expansion_on' ; % this is a meta-predicate - '$flags'(A,F,_), F /\ 0x200000 =:= 0x200000 + '$flags'(A,CurMod,F,_), F /\ 0x200000 =:= 0x200000 ), !, - '$current_module'(CurMod), '$exec_with_expansion'(A, CurMod, CurMod). -'$call'(A, _, _) :- - '$execute0'(A). +'$call'(A, _, _, M) :- + '$execute0'(A, M). -'$spied_call'(M:_,_,G0) :- var(M), !, - throw(error(instantiation_error,call(G0))). -'$spied_call'(M:G,CP,G0) :- !, - '$mod_switch'(M,'$spied_call'(G,CP,G0)). -'$spied_call'((A,B),CP,G0) :- !, - '$execute_within'(A,CP,G0), - '$execute_within'(B,CP,G0). -'$spied_call'((X->Y),CP,G0) :- !, +'$spied_call'((A,B),CP,G0,M) :- !, + '$execute_within'(A,CP,G0,M), + '$execute_within'(B,CP,G0,M). +'$spied_call'((X->Y),CP,G0,M) :- !, ( - '$execute_within'(X,CP,G0) + '$execute_within'(X,CP,G0,M) -> - '$execute_within'(Y,CP,G0) + '$execute_within'(Y,CP,G0,M) ). -'$spied_call'((X->Y; Z),CP,G0) :- !, +'$spied_call'((X->Y; Z),CP,G0,M) :- !, ( - '$execute_within'(X,CP,G0) + '$execute_within'(X,CP,G0,M) -> - '$execute_within'(Y,CP,G0) + '$execute_within'(Y,CP,G0,M) ; - '$execute_within'(Z,CP,G0) + '$execute_within'(Z,CP,G0,M) ). -'$spied_call'((A;B),CP,G0) :- !, +'$spied_call'((A;B),CP,G0,M) :- !, ( - '$execute_within'(A,CP,G0) + '$execute_within'(A,CP,G0,M) ; - '$execute_within'(B,CP,G0) + '$execute_within'(B,CP,G0,M) ). -'$spied_call'((A|B),CP,G0) :- !, +'$spied_call'((A|B),CP,G0,M) :- !, ( - '$execute_within'(A,CP,G0) + '$execute_within'(A,CP,G0,M) ; - '$execute_within'(B,CP,G0) + '$execute_within'(B,CP,G0,M) ). -'$spied_call'(\+ X,_,_) :- !, +'$spied_call'(\+ X,_,_,M) :- !, \+ '$execute'(X). -'$spied_call'(not X,_,_) :- !, +'$spied_call'(not X,_,_,_) :- !, \+ '$execute'(X). -'$spied_call'(!,CP,_) :- +'$spied_call'(!,CP,_,_) :- '$$cut_by'(CP). -'$spied_call'([A|B],_,_) :- !, +'$spied_call'([A|B],_,_,_) :- !, '$csult'([A|B]). -'$spied_call'(A, _CP, _G0) :- +'$spied_call'(A, _CP, _G0, CurMod) :- ( % goal_expansion is defined, or '$pred_goal_expansion_on' ; % this is a meta-predicate - '$flags'(A,F,_), F /\ 0x200000 =:= 0x200000 + '$flags'(A,CurMod,F,_), F /\ 0x200000 =:= 0x200000 ), !, - '$current_module'(CurMod), '$exec_with_expansion'(A, CurMod, CurMod). -'$spied_call'(A,CP,G0) :- - ( '$undefined'(A) -> - functor(A,F,N), '$current_module'(M), +'$spied_call'(A, CP, G0, M) :- + ( '$undefined'(A, M) -> + functor(A,F,N), ( '$recorded'('$import','$import'(S,M,F,N),_) -> - '$spied_call'(S:A,CP,G0) ; + '$spied_call'(S:A,CP,G0,M) ; '$spy'(A) ) ; @@ -797,10 +799,10 @@ Mod:G :- '$mod_switch'(Mod,'$execute_within'(G)). !, '$exec_with_expansion'(G, S, M). '$undefp'([M|G]) :- - \+ '$undefined'(user:unknown_predicate_handler(_,_,_)), + \+ '$undefined'(unknown_predicate_handler(_,_,_), user), user:unknown_predicate_handler(G,M,NG), !, '$execute'(M:NG). -'$undefp'([_|G]) :- '$is_dynamic'(G), !, fail. +'$undefp'([M|G]) :- '$is_dynamic'(G, M), !, fail. '$undefp'([M|G]) :- '$recorded'('$unknown','$unknown'(M:G,US),_), !, '$execute'(user:US). @@ -857,7 +859,11 @@ break :- '$get_value'('$break',BL), NBL is BL+1, throw(error(permission_error(input,stream,Y),consult(X))) ). '$consult'(M:X) :- !, - '$mod_switch'(M,'$consult'(X)). + % set the type-in module + '$current_module'(Mod), + module(M), + '$consult'(X), + '$current_module'(Mod). '$consult'(library(X)) :- !, '$find_in_path'(library(X),Y), ( '$open'(Y,'$csult',Stream,0), !, @@ -1058,19 +1064,19 @@ remove_from_path(New) :- '$check_path'(New,Path), % return two arguments: Expanded0 is the term after "USER" expansion. % Expanded is the final expanded term. % -'$precompile_term'(Term, Expanded0, Expanded) :- +'$precompile_term'(Term, Expanded0, Expanded, Mod) :- ( '$access_yap_flags'(9,1) /* strict_iso on */ -> - '$expand_term_modules'(Term, Expanded0, Expanded), + '$expand_term_modules'(Term, Expanded0, Expanded, Mod), '$check_iso_strict_clause'(Expanded0) ; - '$expand_term_modules'(Term, Expanded0, ExpandedI), + '$expand_term_modules'(Term, Expanded0, ExpandedI, Mod), '$expand_array_accesses_in_term'(ExpandedI,Expanded) ). expand_term(Term,Expanded) :- - ( \+ '$undefined'(user:term_expansion(_,_)), + ( \+ '$undefined'(term_expansion(_,_), user), user:term_expansion(Term,Expanded) ; '$expand_term_grammar'(Term,Expanded) @@ -1105,8 +1111,8 @@ expand_term(Term,Expanded) :- % % Module system expansion % -'$expand_term_modules'(A,B,C) :- '$module_expansion'(A,B,C), !. -'$expand_term_modules'(A,A,A). +'$expand_term_modules'(A,B,C,M) :- '$module_expansion'(A,B,C,M), !. +'$expand_term_modules'(A,A,A,_). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1164,7 +1170,7 @@ catch(G,C,A) :- % % system_catch is like catch, but it avoids the overhead of a full -% meta-call by calling '$execute0' and '$mod_switch' instead of $execute. +% meta-call by calling '$execute0' instead of $execute. % This way it % also avoids module preprocessing and goal_expansion % @@ -1189,8 +1195,8 @@ catch(G,C,A) :- '$db_clean_queues'(Lev), '$erase_catch_elements'(Lev), ( C=X -> - '$current_module'(_,M0), - (A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A)) + (A = M:G -> '$execute'(A) ; + '$current_module'(_,M0), '$execute'(M0:A) ) ; throw(X) ). @@ -1212,7 +1218,8 @@ catch(G,C,A) :- '$system_catch_call'(X,G,I, NX) :- array_element('$catch_queue', 0, OldCatch), update_array('$catch_queue', 0, catch(X,I,OldCatch)), - '$execute0'(G), + '$current_module'(M), + '$execute0'(G,M), NX is '$last_choice_pt', ( % on exit remove the catch array_element('$catch_queue', 0, catch(X,I,Catch)), diff --git a/pl/checker.yap b/pl/checker.yap index 8c75d85ac..7668988df 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -65,12 +65,14 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$check_term'(T,_) :- '$get_value'('$syntaxcheckdiscontiguous',on), - '$xtract_head'(T,_,F,A), - '$handle_discontiguous'(F,A), fail. + '$current_module'(M), + '$xtract_head'(T,M,NM,H,F,A), + '$handle_discontiguous'(F,A,NM), fail. '$check_term'(T,_) :- '$get_value'('$syntaxcheckmultiple',on), - '$xtract_head'(T,_,F,A), - '$handle_multiple'(F,A), fail. + '$current_module'(M), + '$xtract_head'(T,M,NM,H,F,A), + '$handle_multiple'(F,A,NM), fail. '$check_term'(T,VL) :- '$get_value'('$syntaxchecksinglevar',on), ( '$chk_binding_vars'(T), @@ -99,8 +101,9 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$sv_warning'([],_) :- !. -'$sv_warning'(SVs,T) :- - '$xtract_head'(T,H,Name,Arity), +'$sv_warning'(SVs,T) :- + '$current_module'(OM), + '$xtract_head'(T,OM,M,H,Name,Arity), write(user_error,'[ Warning: singleton variable'), '$write_svs'(SVs), write(user_error,' in '), @@ -111,22 +114,24 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). ( '$get_value'('$consulting',false), '$first_clause_in_file'(Name,Arity) -> ClN = 1 ; - '$number_of_clauses'(H,ClN0), + '$number_of_clauses'(H,M,ClN0), ClN is ClN0+1 ), write(user_error,ClN), write(user_error,') ]'), nl(user_error). -'$xtract_head'((H:-_),H,Name,Arity) :- !, - functor(H,Name,Arity). -'$xtract_head'((H,_),H1,Name,Arity) :- !, - '$xtract_head'(H,H1,Name,Arity). -'$xtract_head'((H-->_),HL,Name,Arity) :- !, - '$xtract_head'(H,_,Name,A1), +'$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !, + 'xtract_head'(H,OM,M,NH,Name,Arity). +'$xtract_head'((H,_),OM,M,H1,Name,Arity) :- !, + '$xtract_head'(H,OM,M,H1,Name,Arity). +'$xtract_head'((H-->_),OM,M,HL,Name,Arity) :- !, + '$xtract_head'(H,OM,M,Name,A1), Arity is A1+2, functor(HL,Name,Arity). -'$xtract_head'(H,H,Name,Arity) :- +'$xtract_head'(M:H,_,NM,NH,Name,Arity) :- !, + '$xtract_head'(H,M,NM,NH,Name,Arity). +'$xtract_head'(H,M,M,H,Name,Arity) :- functor(H,Name,Arity). '$write_svs'([H]) :- !, write(user_error,' '), '$write_svs1'([H]). @@ -145,10 +150,9 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$write_str_in_stderr'(T). -'$handle_discontiguous'(F,A) :- - '$current_module'(M), +'$handle_discontiguous'(F,A,M) :- '$recorded'('$discontiguous_defs','$df'(F,A,M),_), !. -'$handle_discontiguous'(F,A) :- +'$handle_discontiguous'(F,A,_) :- '$in_this_file_before'(F,A), write(user_error,'[ Warning: discontiguous definition of '), write(user_error,F/A), write(user_error,' (line '), @@ -156,22 +160,21 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). write(user_error,') ]'), nl(user_error). -'$handle_multiple'(F,A) :- - \+ '$first_clause_in_file'(F,A), !. -'$handle_multiple'(_,_) :- +'$handle_multiple'(F,A,_) :- + \+ '$first_clause_in_file'(F,A,M), !. +'$handle_multiple'(_,_,_) :- '$get_value'('$consulting',true), !. -'$handle_multiple'(F,A) :- - '$current_module'(M), +'$handle_multiple'(F,A,M) :- '$recorded'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !, - '$multiple_has_been_defined'(Fil,F/A), !. -'$handle_multiple'(F,A) :- + '$multiple_has_been_defined'(Fil, F/A, M), !. +'$handle_multiple'(F,A,M) :- ( '$recorded'('$reconsulting',Fil,_) -> true ), - '$current_module'(M), '$recorda'('$predicate_defs','$predicate_defs'(F,A,M,Fil),_). -'$multiple_has_been_defined'(_,F/A) :- - '$is_multifile'(F,A), !. -'$multiple_has_been_defined'(Fil,P) :- +'$multiple_has_been_defined'(_, F/A, M) :- + functor(S, F, A), + '$is_multifile'(S, M), !. +'$multiple_has_been_defined'(Fil,P,_) :- '$recorded'('$reconsulting',F,_), !, '$test_if_well_reconsulting'(F,Fil,P). @@ -184,59 +187,52 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). write(user_error,') ]'), nl(user_error). -'$multifile'(V) :- var(V), !, +'$multifile'(V, _) :- var(V), !, throw(error(instantiation_error,multifile(V))). -'$multifile'((X,Y)) :- '$multifile'(X), '$multifile'(Y). -'$multifile'(Mod:PredSpec) :- !, - ( '$current_module'(Mod) -> - '$multifile'(PredSpec) - ; - '$mod_switch'(Mod,'$multifile'(PredSpec)) - ). -'$multifile'(N/A) :- +'$multifile'((X,Y), M) :- '$multifile'(X, M), '$multifile'(Y, M). +'$multifile'(Mod:PredSpec, _) :- !, + '$multifile'(PredSpec, Mod). +'$multifile'(N/A, M) :- '$get_value'('$consulting_file',F), - '$current_module'(M), '$recordzifnot'('$multifile_defs','$defined'(F,N,A,M),_), fail. -'$multifile'(N/A) :- - '$is_multifile'(N,A), !. -'$multifile'(N/A) :- !, - '$new_multifile'(N,A). -'$multifile'(P) :- - throw(error(type_error(predicate_indicator,P),multifile(P))). +'$multifile'(N/A, M) :- + functor(S,N,A), + '$is_multifile'(S, M), !. +'$multifile'(N/A, M) :- !, + '$new_multifile'(N,A,M). +'$multifile'(P, M) :- + throw(error(type_error(predicate_indicator,P),multifile(M:P))). -'$discontiguous'(V) :- var(V), !, - throw(error(instantiation_error,discontiguous(V))). -'$discontiguous'((X,Y)) :- !, - '$discontiguous'(X), - '$discontiguous'(Y). -'$discontiguous'(M:A) :- !, - '$mod_switch'(M,'$discontiguous'(A)). -'$discontiguous'(N/A) :- !, - '$current_module'(M), +'$discontiguous'(V,M) :- var(V), !, + throw(error(instantiation_error,M:discontiguous(V))). +'$discontiguous'((X,Y),M) :- !, + '$discontiguous'(X,M), + '$discontiguous'(Y,M). +'$discontiguous'(M:A,_) :- !, + '$discontiguous'(A,M). +'$discontiguous'(N/A, M) :- !, ( '$recordzifnot'('$discontiguous_defs','$df'(N,A,M),_) -> true ; true ). -'$discontiguous'(P) :- - throw(error(type_error(predicate_indicator,P),discontiguous(P))). +'$discontiguous'(P,M) :- + throw(error(type_error(predicate_indicator,P),M:discontiguous(P))). % % did we declare multifile properly? % -'$check_multifile_pred'(Hd, _) :- +'$check_multifile_pred'(Hd, M, _) :- functor(Hd,Na,Ar), '$get_value'('$consulting_file',F), - '$current_module'(M), '$recorded'('$multifile_defs','$defined'(F,Na,Ar,M),_), !. % oops, we did not. -'$check_multifile_pred'(Hd, Fl) :- +'$check_multifile_pred'(Hd, M, Fl) :- % so this is not a multi-file predicate any longer. functor(Hd,Na,Ar), NFl is \(16'040000 ) /\ Fl, - '$flags'(Hd,Fl,NFl), - '$current_module'(M), + '$flags'(Hd,M,Fl,NFl), '$clear_multifile_pred'(Na,Ar,M), '$warn_mfile'(Na,Ar). diff --git a/pl/consult.yap b/pl/consult.yap index e890d8189..f0e33ba28 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -24,6 +24,11 @@ ensure_loaded(V) :- '$ensure_loaded'([F|Fs]) :- !, '$ensure_loaded'(F), '$ensure_loaded'(Fs). +'$ensure_loaded'(M:X) :- !, + '$current_module'(M0), + '$change_module'(M), + '$ensure_loaded'(X), + '$change_module'(M0). '$ensure_loaded'(X) :- atom(X), !, '$find_in_path'(X,Y), ( open(Y,'$csult',Stream), !, @@ -43,8 +48,6 @@ ensure_loaded(V) :- throw(error(permission_error(input,stream,X),ensure_loaded(X))) ). -'$ensure_loaded'(M:X) :- !, - '$mod_switch'(M,'$ensure_loaded'(X)). '$ensure_loaded'(library(X)) :- !, '$find_in_path'(library(X),Y), ( open(Y,'$csult',Stream), !, @@ -106,7 +109,10 @@ reconsult(Fs) :- throw(error(permission_error(input,stream,X),reconsult(X))) ). '$reconsult'(M:X) :- !, - '$mod_switch'(M,'$reconsult'(X)). + '$current_module'(M0), + '$change_module'(M), + '$reconsult'(X), + '$change_module'(M0). '$reconsult'(library(X)) :- !, '$find_in_path'(library(X),Y), ( open(Y,'$csult',Stream), !, diff --git a/pl/corout.yap b/pl/corout.yap index f8682331a..76000d05d 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -32,6 +32,7 @@ % % Tell the system how to present frozen goals. % + :- assert((extensions_to_present_answer(Level) :- '$show_frozen_goals'(Level))). @@ -75,17 +76,18 @@ '$do_continuation'('$restore_regs'(X,Y), _) :- !, '$restore_regs'(X,Y). '$do_continuation'(Continuation, Module1) :- - '$mod_switch'(Module1,'$execute_continuation'(Continuation,Module1)). + '$execute_continuation'(Continuation,Module1). '$execute_continuation'(Continuation, Module1) :- - '$undefined'(Continuation), !, + '$undefined'(Continuation, Module1), !, '$undefp'([Module1|Continuation]). -'$execute_continuation'(Continuation, _) :- +'$execute_continuation'(Continuation, Mod) :- % do not do meta-expansion nor any fancy stuff. - '$execute0'(Continuation). +'$module_number'(Mod,_), + '$execute0'(Continuation, Mod). -'$execute_woken_system_goals'([]). +'$execute_woken_system_goals'([]). '$execute_woken_system_goals'([G|LG]) :- '$execute_woken_system_goal'(G, G), '$execute_woken_system_goals'(LG). @@ -252,7 +254,8 @@ when(_,Goal) :- % '$declare_when'(Cond, G) :- '$generate_code_for_when'(Cond, G, Code), - '$$compile'(Code, Code, 5), fail. + '$current_module'(Module), + '$$compile'(Code, Code, 5, Module), fail. '$declare_when'(_,_). % @@ -378,7 +381,8 @@ when(_,Goal) :- % '$block'(Conds) :- '$generate_blocking_code'(Conds, _, Code), - '$$compile'(Code, Code, 5), fail. + '$current_module'(Mod), + '$$compile'(Code, Code, 5, Module), fail. '$block'(_). '$generate_blocking_code'(Conds, G, Code) :- @@ -458,7 +462,8 @@ when(_,Goal) :- '$wait'(Na/Ar) :- functor(S, Na, Ar), arg(1, S, A), - '$$compile'((S :- var(A), !, freeze(A, S)), (S :- var(A), !, freeze(A, S)), 5), fail. + '$current_module'(M), + '$$compile'((S :- var(A), !, freeze(A, S)), (S :- var(A), !, freeze(A, S)), 5, M), fail. '$wait'(_). frozen(V, G) :- nonvar(V), !, G = true. @@ -606,7 +611,7 @@ call_residue(Goal,Residue) :- '$project'(true,_,_,Gs,Gs) :- !. '$project'(_,_,_,Gs,Gs) :- - '$undefined'(attributes:modules_with_attributes(_)), !. + '$undefined'(modules_with_attributes(_), attributes), !. '$project'(_,LIV,LAV,Gs,Gs0) :- attributes:modules_with_attributes(LMods), (LAV = [] -> @@ -626,7 +631,7 @@ call_residue(Goal,Residue) :- '$project_module'([], _, _). '$project_module'([Mod|LMods], LIV, LAV) :- - \+ '$undefined'(Mod:project_attributes(LIV, LAV)), + \+ '$undefined'(project_attributes(LIV, LAV), Mod), '$execute'(Mod:project_attributes(LIV, LAV)), !, '$all_attvars'(NLAV), '$project_module'(LMods,LIV,NLAV). diff --git a/pl/debug.yap b/pl/debug.yap index ed1b68cd7..37c4c81fb 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -26,75 +26,73 @@ % First part : setting and reseting spy points % $suspy does most of the work -'$suspy'(V,S) :- var(V) , !, - throw(error(instantiation_error,spy(V,S))). -'$suspy'((M:S),P) :- !, - '$mod_switch'(M, '$suspy'(S,P)). -'$suspy'([],_) :- !. -'$suspy'([F|L],M) :- !, ( '$suspy'(F,M) ; '$suspy'(L,M) ). -'$suspy'(F/N,M) :- !, functor(T,F,N), +'$suspy'(V,S,M) :- var(V) , !, + throw(error(instantiation_error,M:spy(V,S))). +'$suspy'((M:S),P,_) :- !, + '$suspy'(S,P,M). +'$suspy'([],_,_) :- !. +'$suspy'([F|L],S,M) :- !, ( '$suspy'(F,S,M) ; '$suspy'(L,S,M) ). +'$suspy'(F/N,S,M) :- !, functor(T,F,N), ( '$system_predicate'(T) -> throw(error(permission_error(access,private_procedure,F/N),spy(F/N,S))); - '$undefined'(T) -> + '$undefined'(T,M) -> throw(error(existence_error(procedure,F/N),spy(F/N,S))); - '$suspy2'(M,F,N,T) ). -'$suspy'(A,S) :- \+ atom(A) , !, + '$suspy2'(S,F,N,T,M) ). +'$suspy'(A,S,_) :- \+ atom(A) , !, throw(error(type_error(predicate_indicator,A),spy(A,S))). -'$suspy'(A,spy) :- '$noclausesfor'(A), !, +'$suspy'(A,spy,M) :- '$noclausesfor'(A,M), !, throw(error(existence_error(procedure,A),spy(A))). -'$suspy'(A,nospy) :- '$noclausesfor'(A), !, +'$suspy'(A,nospy,M) :- '$noclausesfor'(A,M), !, throw(error(existence_error(procedure,A),nospy(A))). -'$suspy'(A,M) :- current_predicate(A,T), - \+ '$undefined'(T), \+ '$system_predicate'(T), +'$suspy'(A,S,M) :- current_predicate(A,M:T), + \+ '$undefined'(T,M), \+ '$system_predicate'(T), functor(T,F,N), - '$suspy2'(M,F,N,T). + '$suspy2'(S,F,N,T,M). -'$noclausesfor'(A) :- current_predicate(A,T), - \+ '$undefined'(T) , \+ '$system_predicate'(T) , +'$noclausesfor'(A,M) :- current_predicate(A,M:T), + \+ '$undefined'(T,M) , \+ '$system_predicate'(T) , !, fail . -'$noclausesfor'(_). +'$noclausesfor'(_,_). -'$suspy2'(spy,F,N,T) :- - '$current_module'(M), +'$suspy2'(spy,F,N,T,M) :- '$recorded'('$spy','$spy'(T,M),_), !, - format('[ Warning: there is already a spy point on ~w ]~n',M:F/N). -'$suspy2'(spy,F,N,T) :- !, - '$warn_if_undef'(T,F,N), - '$current_module'(M), + '$format'(user_error, "[ Warning: there is already a spy point on ~w:~w/~w ]~n",[M,F,N]). +'$suspy2'(spy,F,N,T,M) :- !, + '$warn_if_undef'(T,F,N,M), '$recorda'('$spy','$spy'(T,M),_), '$set_value'('$spypoint_added', true), - '$set_spy'(T), - write(user_error,'[ Spy point set on '), write(user_error,F/N), - write(user_error,' ]'), nl(user_error). -'$suspy2'(nospy,F,N,T) :- - '$current_module'(M), + '$set_spy'(T,M), + '$format'(user_error,"[ Spy point set on ~w:~w/~w ]~n", [M,F,N]). +'$suspy2'(nospy,F,N,T,M) :- '$recorded'('$spy','$spy'(T,M),R), !, erase(R), - '$rm_spy'(T), - write(user_error,'[ Spy point on '), write(user_error,F/N), write(user_error,' removed ]'), - nl(user_error). -'$suspy2'(nospy,F,N,_) :- - write(user_error,'[ Warning: there is no spy-point on '), - write(user_error,F/N), write(user_error,' ]'), nl(user_error). + '$rm_spy'(T,M), + '$format'(user_error,"[ Spy point on ~w:~w/~w removed ]~n", [M,F,N]). +'$suspy2'(nospy,F,N,_,M) :- + '$format'(user_error,"[ Warning: there is no spy point on ~w:~w/~w ]~n", [M,F,N]). -'$warn_if_undef'(T,F,N) :- '$undefined'(T), !, +'$warn_if_undef'(T,F,N,M) :- '$undefined'(T,M), !, write(user_error,'[ Warning: you have no clauses for '), - write(user_error,F/N), write(user_error,' ]'), nl(user_error). -'$warn_if_undef'(_,_,_). + write(user_error,M:F/N), write(user_error,' ]'), nl(user_error). +'$warn_if_undef'(_,_,_,_). -'$pred_being_spied'(G) :- - '$current_module'(M), +'$pred_being_spied'(G, M) :- '$recorded'('$spy','$spy'(G,M),_), !. spy _ :- '$set_value'('$spypoint_added', false), fail. -spy L :- '$suspy'(L,spy), fail. +spy L :- + '$current_module'(M), + '$suspy'(L, spy, M), fail. spy _ :- '$get_value'('$spypoint_added', false), !. spy _ :- debug. -nospy L :- '$suspy'(L,nospy), fail. +nospy L :- + '$current_module'(M), + '$suspy'(L, nospy, M), fail. nospy _. -nospyall :- '$recorded'('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(M:F/N,nospy), fail. +nospyall :- + '$recorded'('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(F/N,nospy,M), fail. nospyall. % debug mode -> debug flag = 1 @@ -249,7 +247,7 @@ debugging :- '$awoken_goals'(LG), !, '$creep', '$wake_up_goal'(G, LG). -'$spy'([_Module|G]) :- +'$spy'([Module|G]) :- % '$format'(user_error,"$spym(~w,~w)~n",[Module,G]), ( '$hidden'(G) ; @@ -258,41 +256,37 @@ debugging :- ), !, /* called from prolog module */ - '$execute0'(G), + '$execute0'(G,Module), '$creep'. -'$spy'(G) :- - '$do_spy'(G). +'$spy'([Mod|G]) :- + '$do_spy'(G,Mod). '$direct_spy'(G) :- '$awoken_goals'(LG), !, '$creep', '$wake_up_goal'(G, LG). -'$direct_spy'([_|G]) :- +'$direct_spy'([M|G]) :- '$hidden'(G), !, /* called from prolog module */ - '$execute0'(G), + '$execute0'(G,M), '$creep'. -'$direct_spy'(G) :- - '$do_spy'(G). +'$direct_spy'([Mod|G]) :- + '$do_spy'(G, Mod). -'$do_spy'([Module|G]) :- !, - ( Module=prolog -> '$do_spy'(G); - '$mod_switch'(Module, '$do_spy'(G)) - ). -'$do_spy'(true) :- !, '$creep'. -'$do_spy'('$cut_by'(M)) :- !, '$cut_by'(M). -'$do_spy'(G) :- +'$do_spy'(true, _) :- !, '$creep'. +'$do_spy'('$cut_by'(M), _) :- !, '$cut_by'(M). +'$do_spy'(G, Module) :- % write(user_error,$spy(G)), nl, '$get_value'(debug,1), /* ditto if debug off */ '$get_value'(spy_fs,0), /* ditto if fast skipping */ ( '$access_yap_flags'(10,0) -> /* if not creeping ... */ - '$pred_being_spied'(G) /* ... spy only if at a spy-point */ + '$pred_being_spied'(G,M) /* ... spy only if at a spy-point */ ; true ), -% ( \+ '$undefined'(user_error_spy(_)) -> user_error_spy(G) ; +% ( \+ '$undefined'(user_error_spy(_), user) -> user_error_spy(G) ; % true ); !, /* you sure want to spy this ... */ '$get_value'(spy_gn,L), /* get goal no. */ @@ -301,16 +295,14 @@ debugging :- '$access_yap_flags'(10,SC), '$set_yap_flags'(10,1), /* set creep on */ '$get_value'(spy_cl,CL), /* save global clause no. */ - '$current_module'(Module), repeat, /* we need this to be able to implement retry */ - '$init_spy_cl'(G), - '$trace'(call,G,L), /* inform about call port */ + '$init_spy_cl'(G,Module), + '$trace'(call,G,Module,L), /* inform about call port */ /* the following choice point is where the predicate is called */ ( '$get_value'(spy_sp,0), /* make sure we are not skipping*/ - '$current_module'(_,Module), - '$spycalls'(G,Res) /* go execute the predicate */ + '$spycalls'(G,Module,Res) /* go execute the predicate */ ; /* we get here when the predicate fails */ - '$trace'(fail,G,L), /* inform at fail port */ + '$trace'(fail,G,Module,L), /* inform at fail port */ '$get_value'(spy_sl,L2),/* make sure we are not ... */ L2 \= L, /* ... skiping to this level */ !, /* if not prepare to exit spy */ @@ -320,7 +312,7 @@ debugging :- '$cont_creep', fail ), /* and exit */ '$get_value'(spy_cl,Cla), /* save no. of clause to try */ ( var(Res), /* check not redoing */ - '$trace'(exit,G,L), /* output message at exit */ + '$trace'(exit,G,Module,L), /* output message at exit */ '$get_value'(spy_sp,0), /* check not skipping */ '$set_creep'(SC), /* restore creep value */ '$set_value'(spy_cl,CL), /* restore clause no. */ @@ -328,11 +320,11 @@ debugging :- '$cont_creep'; /* exit */ /* we get here when we want to redo a goal */ '$set_value'(spy_cl,Cla),/* restore clause no. to try */ - '$current_module'(_,Module), - '$trace'(redo,G,L), /* inform user_error */ + '$trace'(redo,G,Module,L), /* inform user_error */ fail /* to backtrack to spycalls */ ). -'$do_spy'(G) :- '$execute0'(G). /* this clause applies when we do not want +'$do_spy'(G,Mod) :- + '$execute0'(G,Mod). /* this clause applies when we do not want to spy the goal */ '$cont_creep' :- '$get_value'('$trace',1), '$set_yap_flags'(10,1), fail. @@ -343,79 +335,79 @@ debugging :- '$set_creep'(_). %'$spycalls'(G,_) :- write(user_error,'$spycalls'(G)), nl(user_error), fail. -'$spycalls'([_|_],_) :- !, fail. -'$spycalls'('!'(CP),_) :- - '$call'(!, CP, !). -'$spycalls'(Mod:G,Res) :- +'$spycalls'([_|_],_,_) :- !, fail. +'$spycalls'('!'(CP),Mod,_) :- + '$call'(!, CP, !,Mod). +'$spycalls'(Mod:G,_,Res) :- !, - '$mod_switch'(Mod,'$spycalls'(G,Res)). -'$spycalls'(repeat,_) :- + '$spycalls'(G,Mod,Res). +'$spycalls'(repeat,_,_) :- !, repeat. -'$spycalls'(fail,_) :- +'$spycalls'(fail,_,_) :- !, fail. -'$spycalls'(false,_) :- +'$spycalls'(false,_,_) :- !, false. -'$spycalls'(true,_) :- +'$spycalls'(true,_,_) :- !. -'$spycalls'(otherwise,_) :- +'$spycalls'(otherwise,_,_) :- !. -'$spycalls'(\+ G,Res) :- +'$spycalls'(\+ G,Mod,Res) :- !, CP is '$last_choice_pt', - '$spycalls'('$call'((\+ G), CP, (\+ G)),Res). -'$spycalls'(not(G),Res) :- + '$spycalls'('$call'((\+ G), CP, (\+ G),Mod),Mod,Res). +'$spycalls'(not(G),Mod,Res) :- !, CP is '$last_choice_pt', - '$spycalls'('$call'(not(G), CP, not(G)),Res). -'$spycalls'(G,Res) :- % undefined predicate - '$undefined'(G), !, - functor(G,F,N), '$current_module'(M), + '$spycalls'('$call'(not(G), CP, not(G),Mod),Mod,Res). +'$spycalls'(G,M,Res) :- % undefined predicate + '$undefined'(G, M), !, + functor(G,F,N), ( '$recorded'('$import','$import'(S,M,F,N),_) -> - '$spycalls'(S:G,Res) ; + '$spycalls'(G,S,Res) ; '$undefp'([M|G]) ). -'$spycalls'(G,_) :- - '$flags'(G,F,_), F /\ 8'50000 =\= 0, % Standard and C pred +'$spycalls'(G,M,_) :- + '$flags'(G,M,F,_), F /\ 8'50000 =\= 0, % Standard and C pred !, - '$catch_spycall_stdpred'(G), + '$catch_spycall_stdpred'(G,M), (true; '$get_value'(spy_sp,P), P \= 0, !, fail), ( true; '$get_value'(spy_sp,P1), P1 \= 0, !, fail) . -'$spycalls'(G,Res) :- % asserts and retracts can complicate live +'$spycalls'(G,M,Res) :- % asserts and retracts can complicate live ( '$get_value'(spy_sp,0) -> true ; !, fail ), - '$flags'(G,F,F), + '$flags'(G,M,F,F), F /\ 16'2000 =\= 0, !, % dynamic procedure, immediate semantics repeat, - '$db_last_age'(G,Max), + '$db_last_age'(M:G,Max), '$get_value'(spy_cl,Cl), '$get_value'(spy_gn,L), Maxx is Max+1, '$set_value'(spy_cl,Maxx), ( Cl > Max -> !, fail ; true ), - ( '$spycall_dynamic'(G,Cl) ; + ( '$spycall_dynamic'(G,M,Cl) ; ('$get_value'(spy_gn,L) -> '$leave_creep', fail ; Res = redo ) ), ( true ; '$get_value'(spy_sp,P), P \= 0, !, fail ) . -'$spycalls'(G,Res) :- +'$spycalls'(G,M,Res) :- ( '$get_value'(spy_sp,0) -> true ; !, fail ), - '$flags'(G,F,F), + '$flags'(G,M,F,F), F /\ 16'8 =\= 0, !, % dynamic procedure, logical update semantics - '$hold_index'(G, Index, Max), % hold an index on the procedure state when we called this goal + '$hold_index'(M:G, Index, Max), % hold an index on the procedure state when we called this goal repeat, '$get_value'(spy_cl,Cl), '$get_value'(spy_gn,L), Maxx is Max+1, '$set_value'(spy_cl,Maxx), ( Cl > Max -> !, fail ; true), - ( '$log_upd_spycall'(G,Cl,Index) ; + ( '$log_upd_spycall'(G,M,Cl,Index) ; ('$get_value'(spy_gn,L) -> '$leave_creep', fail ; % to backtrack to repeat Res = redo ) @@ -424,16 +416,16 @@ debugging :- '$get_value'(spy_sp,P), P \= 0, !, fail ) . -'$spycalls'(G,Res) :- +'$spycalls'(G,M,Res) :- ( '$get_value'(spy_sp,0) -> true ; !, fail ), repeat, - '$number_of_clauses'(G,Max), + '$number_of_clauses'(G,M,Max), '$get_value'(spy_cl,Cl), '$get_value'(spy_gn,L), Maxx is Max+1, '$set_value'(spy_cl,Maxx), ( Cl > Max -> !, fail ; true), - ( '$spycall'(G,Cl) ; + ( '$spycall'(G,M,Cl) ; ('$get_value'(spy_gn,L) -> '$leave_creep', fail ; % to backtrack to repeat Res = redo ) @@ -442,149 +434,149 @@ debugging :- '$get_value'(spy_sp,P), P \= 0, !, fail ) . -'$spycall'(G,Cl) :- +'$spycall'(G,M,Cl) :- '$access_yap_flags'(10,0), !, '$setflop'(0), - '$call_clause'(G,Cl). -'$spycall'(G,Cl) :- + '$call_clause'(G,M,Cl). +'$spycall'(G,M,Cl) :- '$setflop'(0), - '$creepcallclause'(G,Cl). + '$creepcallclause'(G,M,Cl). -'$log_upd_spycall'(G,Cl,Index) :- +'$log_upd_spycall'(G,M,Cl,Index) :- '$access_yap_flags'(10,0), !, '$setflop'(0), - '$call_log_updclause'(G,Cl,Index). -'$log_upd_spycall'(G,Cl,Index) :- + '$call_log_updclause'(G,M,Cl,Index). +'$log_upd_spycall'(G,M,Cl,Index) :- '$setflop'(0), - '$creepcall_log_upd_clause'(G,Cl,Index). + '$creepcall_log_upd_clause'(G,M,Cl,Index). % this is to be used only for dynamic predicates -'$spycall_dynamic'(G,Cl) :- +'$spycall_dynamic'(G,M,Cl) :- '$access_yap_flags'(10,0), !, '$setflop'(0), - '$call_dynamic_clause'(G,Cl). -'$spycall_dynamic'(G,Cl) :- + '$call_dynamic_clause'(G,M,Cl). +'$spycall_dynamic'(G,M,Cl) :- '$setflop'(0), - '$creepcall_dynamic_clause'(G,Cl). + '$creepcall_dynamic_clause'(G,M,Cl). -'$catch_spycall_stdpred'(G) :- - '$system_catch'('$spycall_stdpred'(G), Error, user:'$DebugError'(Error)). +'$catch_spycall_stdpred'(G,M) :- + '$system_catch'('$spycall_stdpred'(G,M), Error, user:'$DebugError'(Error)). -'$spycall_stdpred'(G) :- +'$spycall_stdpred'(G,M) :- functor(G,F,N), ( - '$recorded'('$meta_predicate','$meta_predicate'(_,F,N,_),_) -> + user:'$meta_predicate'(F,M,N,_) -> '$setflop'(1), '$creep', - '$execute0'(G) + '$execute0'(G,M) ; '$setflop'(1), - '$execute0'(G) + '$execute0'(G,M) ), '$setflop'(0). -'$call_clause'(G,Cl) :- - '$system_catch'('$do_execute_clause'(G,Cl),Error,user:'$DebugError'(Error)). +'$call_clause'(G,M,Cl) :- + '$system_catch'('$do_execute_clause'(G,M,Cl),Error,user:'$DebugError'(Error)). -'$do_execute_clause'(G,Cl) :- - '$some_recordedp'(G), !, +'$do_execute_clause'(G,M,Cl) :- + '$some_recordedp'(M:G), !, '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), CP is '$last_choice_pt', ( - '$fetch_clause'(G,Cl,Clause), - (Clause = true -> true ; '$debug_catch_call'(Clause,CP) ) + '$fetch_clause'(G,M,Cl,Clause), + (Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail ). -'$do_execute_clause'(G,Cl) :- - '$execute'(G,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail. +'$do_execute_clause'(G,M,Cl) :- + '$execute'(G,M,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail. -'$call_log_updclause'(G,Cl,Index) :- - '$system_catch'('$do_execute_log_upd_clause'(G,Cl,Index),Error,user:'$DebugError'(Error)). +'$call_log_updclause'(G,M,Cl,Index) :- + '$system_catch'('$do_execute_log_upd_clause'(G,M,Cl,Index),Error,user:'$DebugError'(Error)). -'$do_execute_log_upd_clause'(G,Cl,Index) :- +'$do_execute_log_upd_clause'(G,M,Cl,Index) :- '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), CP is '$last_choice_pt', ( (Index = [] -> /* We have a single clause */ Cl = 1, - clause(G, Clause) + '$clause'(G, M, Clause) ; Cl1 is Cl-1, '$fetch_reference_from_index'(Index, Cl1, Ref), instance(Ref, (G :- Clause)) ), - (Clause = true -> true ; '$debug_catch_call'(Clause,CP) ) + (Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail ). '$check_depth_for_interpreter'(10000000) :- - '$undefined'(get_depth_limit(_)), !. + '$undefined'(get_depth_limit(_), prolog), !. '$check_depth_for_interpreter'(D1) :- get_depth_limit(D0), D0 =\= 0, D1 is D0-1. -'$debug_catch_call'(Clause,CP) :- - '$system_catch'('$call'(Clause,CP,Clause),Error,user:'$DebugError'(Error)). +'$debug_catch_call'(Clause,M,CP) :- + '$system_catch'('$call'(Clause,CP,Clause,M),Error,user:'$DebugError'(Error)). -'$call_dynamic_clause'(G,Cl) :- - '$system_catch'('$do_execute_dynamic_clause'(G,Cl),Error,user:'$DebugError'(Error)). +'$call_dynamic_clause'(G,M,Cl) :- + '$system_catch'('$do_execute_dynamic_clause'(G,M,Cl),Error,user:'$DebugError'(Error)). -'$do_execute_dynamic_clause'(G,Cl) :- +'$do_execute_dynamic_clause'(G,M,Cl) :- '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), CP is '$last_choice_pt', ( - '$db_nb_to_ref'(Cl,G,Ref), + '$db_nb_to_ref'(Cl,M:G,Mod,Ref), instance(Ref, (G :- Clause)), - (Clause = true -> true ; '$debug_catch_call'(Clause,CP) ) + (Clause = true -> true ; '$debug_catch_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail ). -'$creepcallclause'(G,Cl) :- - '$system_catch'('$do_creep_execute'(G,Cl),Error,user:'$DebugError'(Error)). +'$creepcallclause'(G,M,Cl) :- + '$system_catch'('$do_creep_execute'(G,M,Cl),Error,user:'$DebugError'(Error)). -'$do_creep_execute'(G,Cl) :- +'$do_creep_execute'(G,M,Cl) :- % fast skip should ignore source mode '$get_value'(spy_fs,0), - '$some_recordedp'(G), + '$some_recordedp'(M:G), !, '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), CP is '$last_choice_pt', ( - '$fetch_clause'(G,Cl,Clause), + '$fetch_clause'(G,M,Cl,Clause), (Clause = true -> true ; - '$catch_creep_call'(Clause,CP) + '$catch_creep_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail ). -'$do_creep_execute'(G,Cl) :- - '$creep_execute'(G,Cl) ; +'$do_creep_execute'(G,M,Cl) :- + '$creep_execute'(G,M,Cl) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail. -'$creepcall_log_upd_clause'(G,Cl,Index) :- - '$system_catch'('$do_creep_log_upd_execute'(G,Cl,Index),Error,user:'$DebugError'(Error)). +'$creepcall_log_upd_clause'(G,M,Cl,Index) :- + '$system_catch'('$do_creep_log_upd_execute'(G,M,Cl,Index),Error,user:'$DebugError'(Error)). -'$do_creep_log_upd_execute'(G,Cl,Index) :- +'$do_creep_log_upd_execute'(G,M,Cl,Index) :- '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), ( CP is '$last_choice_pt', (Index = [] -> /* We have a single clause */ Cl = 1, - clause(G, Clause) + '$clause'(G, M, Clause) ; Cl1 is Cl-1, '$fetch_reference_from_index'(Index, Cl1, Ref), @@ -592,30 +584,30 @@ debugging :- ), (Clause = true -> true ; % otherwise fast skip may try to interpret assembly builtins. - '$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,CP) ; - '$catch_creep_call'(Clause,CP) + '$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,M,CP) ; + '$catch_creep_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail ). -'$catch_creep_call'(Clause,CP) :- - '$system_catch'('$creep_call'(Clause,CP),Error,user:'$DebugError'(Error)). +'$catch_creep_call'(Clause,M,CP) :- + '$system_catch'('$creep_call'(Clause,M,CP),Error,user:'$DebugError'(Error)). -'$creepcall_dynamic_clause'(G,Cl) :- - '$system_catch'('$do_creep_execute_dynamic'(G,Cl),Error,user:'$DebugError'(Error)). +'$creepcall_dynamic_clause'(G,M,Cl) :- + '$system_catch'('$do_creep_execute_dynamic'(G,M,Cl),Error,user:'$DebugError'(Error)). -'$do_creep_execute_dynamic'(G,Cl) :- +'$do_creep_execute_dynamic'(G,M,Cl) :- '$check_depth_for_interpreter'(D), - ('$undefined'('$set_depth_limit'(_)) -> true ; '$set_depth_limit'(D)), + ('$undefined'('$set_depth_limit'(_),prolog) -> true ; '$set_depth_limit'(D)), CP is '$last_choice_pt', ( - '$db_nb_to_ref'(Cl,G,Ref), + '$db_nb_to_ref'(Cl,M:G,Ref), instance(Ref, (G :- Clause)), (Clause = true -> true ; % otherwise fast skip may try to interpret assembly builtins. - '$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,CP) ; - '$catch_creep_call'(Clause,CP) + '$get_value'(spy_fs,1) -> '$debug_catch_call'(Clause,M,CP) ; + '$catch_creep_call'(Clause,M,CP) ) ; Next is Cl+1, '$set_value'(spy_cl,Next), fail @@ -623,14 +615,14 @@ debugging :- '$leave_creep'. -'$creep_execute'(G,Cl) :- +'$creep_execute'(G,M,Cl) :- '$creep', - '$execute'(G,Cl). + '$execute'(G,M,Cl). -'$fetch_clause'(G,ClNum,Body) :- +'$fetch_clause'(G,M,ClNum,Body) :- % I'd like an easier way to keep a counter '$set_value'('$fetching_clauses',1), - '$recordedp'(G,Clause,_), + '$recordedp'(M:G,Clause,_), '$get_value'('$fetching_clauses',Num), ( Num = ClNum -> !, @@ -643,140 +635,106 @@ debugging :- %'$creep_call'(G,_) :- write(user_error,'$creepcall'(G)), nl(user_error), fail. -'$creep_call'(V,_) :- var(V), !, - throw(error(instantiation_error,meta_call(V))). -'$creep_call'(A,_) :- number(A), !, - throw(error(type_error(callable,A),meta_call(A))). -'$creep_call'(R,_) :- db_reference(R), !, - throw(error(type_error(callable,R),meta_call(R))). -'$creep_call'(M:G,CP) :- !, - '$mod_switch'(M, '$creep_call'(G,CP)), - '$current_module'(Module), +'$creep_call'(V,M,_) :- var(V), !, + throw(error(instantiation_error,meta_call(M:V))). +'$creep_call'(A,M,_) :- number(A), !, + throw(error(type_error(callable,A),meta_call(M:A))). +'$creep_call'(R,M,_) :- db_reference(R), !, + throw(error(type_error(callable,R),meta_call(M:R))). +'$creep_call'(M:G,_,CP) :- !, + '$creep_call'(G,M,CP). +'$creep_call'(fail,Module,_) :- !, '$direct_spy'([Module|fail]). -'$creep_call'(fail,_) :- !, - '$current_module'(Module), - '$direct_spy'([Module|fail]). -'$creep_call'(false,_) :- !, - '$current_module'(Module), +'$creep_call'(false,Module,_) :- !, '$direct_spy'([Module|false]). -'$creep_call'(true,_) :- !, - '$current_module'(Module), +'$creep_call'(true,Module,_) :- !, '$direct_spy'([Module|true]). -'$creep_call'(otherwise,_) :- !, - '$current_module'(Module), +'$creep_call'(otherwise,Module,_) :- !, '$direct_spy'([Module|otherwise]). -'$creep_call'((A,B),CP) :- !, - '$creep_call'(A,CP), '$creep_call'(B,CP). -'$creep_call'((X->Y; Z),CP) :- !, - ( '$creep_call'(X,CP), !, '$creep_call'(Y,CP); '$creep_call'(Z,CP)). -'$creep_call'((A;B),CP) :- !, - ('$creep_call'(A,CP) ; '$creep_call'(B,CP)). -'$creep_call'((A|B),CP) :- !, - ('$creep_call'(A,CP) ; '$creep_call'(B,CP)). -'$creep_call'(atom(A),_) :- !, - '$current_module'(Module), +'$creep_call'((A,B),Module,CP) :- !, + '$creep_call'(A,Module,CP), '$creep_call'(B,Module,CP). +'$creep_call'((X->Y; Z),Module,CP) :- !, + ( '$creep_call'(X,Module,CP), !, '$creep_call'(Y,Module,CP); '$creep_call'(Z,Module,CP)). +'$creep_call'((A;B),Module,CP) :- !, + ('$creep_call'(A,Module,CP) ; '$creep_call'(B,Module,CP)). +'$creep_call'((A|B),Module,CP) :- !, + ('$creep_call'(A,Module,CP) ; '$creep_call'(B,Module,CP)). +'$creep_call'(atom(A),Module,_) :- !, '$direct_spy'([Module|atom(A)]). -'$creep_call'(atomic(A),_) :- !, - '$current_module'(Module), +'$creep_call'(atomic(A),Module,_) :- !, '$direct_spy'([Module|atomic(A)]). -'$creep_call'(integer(A),_) :- !, - '$current_module'(Module), +'$creep_call'(integer(A),Module,_) :- !, '$direct_spy'([Module|integer(A)]). -'$creep_call'(nonvar(A),_) :- !, - '$current_module'(Module), +'$creep_call'(nonvar(A),Module,_) :- !, '$direct_spy'([Module|nonvar(A)]). -'$creep_call'(var(A),_) :- !, - '$current_module'(Module), +'$creep_call'(var(A),Module,_) :- !, '$direct_spy'([Module|var(A)]). -'$creep_call'(number(A),_) :- !, - '$current_module'(Module), +'$creep_call'(number(A),Module,_) :- !, '$direct_spy'([Module|number(A)]). -'$creep_call'(prismitive(A),_) :- !, - '$current_module'(Module), +'$creep_call'(prismitive(A),Module,_) :- !, '$direct_spy'([Module|primitive(A)]). -'$creep_call'(compound(A),_) :- !, - '$current_module'(Module), +'$creep_call'(compound(A),Module,_) :- !, '$direct_spy'([Module|compound(A)]). -'$creep_call'(float(A),_) :- !, - '$current_module'(Module), +'$creep_call'(float(A),Module,_) :- !, '$direct_spy'([Module|float(A)]). -'$creep_call'(db_reference(A),_) :- !, - '$current_module'(Module), +'$creep_call'(db_reference(A),Module,_) :- !, '$direct_spy'([Module|db_reference(A)]). -'$creep_call'(\+ X,_) :- !, - '$current_module'(Module), +'$creep_call'(\+ X,Module,_) :- !, '$direct_spy'([Module|(\+ X)]). -'$creep_call'(not X,_) :- !, - '$current_module'(Module), +'$creep_call'(not X,Module,_) :- !, '$direct_spy'([Module|not(X)]). -'$creep_call'(X=Y,_) :- !, - '$current_module'(Module), +'$creep_call'(X=Y,Module,_) :- !, '$direct_spy'([Module|X=Y]). -'$creep_call'(X\=Y,_) :- !, - '$current_module'(Module), +'$creep_call'(X\=Y,Module,_) :- !, '$direct_spy'([Module|X\=Y]). -'$creep_call'(X==Y,_) :- !, - '$current_module'(Module), +'$creep_call'(X==Y,Module,_) :- !, '$direct_spy'([Module|X==Y]). -'$creep_call'(X>Y,_) :- !, - '$current_module'(Module), +'$creep_call'(X>Y,Module,_) :- !, '$direct_spy'([Module|X>Y]). -'$creep_call'(X>=Y,_) :- !, - '$current_module'(Module), +'$creep_call'(X>=Y,Module,_) :- !, '$direct_spy'([Module|X>=Y]). -'$creep_call'(XY),CP) :- !, +'$creep_call'((X->Y),Module,CP) :- !, CP1 is '$last_choice_pt', - '$creep_call'(X,CP), + '$creep_call'(X,Module,CP), '$$cut_by'(CP1), - '$creep_call'(Y,CP). -'$creep_call'(!,CP) :- !, - '$current_module'(M), - '$direct_spy'([M|'!'(CP)]), + '$creep_call'(Y,Module,CP). +'$creep_call'(!,Module,CP) :- !, + '$direct_spy'([Module|'!'(CP)]), % clean up any garbage left here by the debugger. '$$cut_by'(CP). -'$creep_call'('$cut_by'(X),_) :- !, +'$creep_call'('$cut_by'(X),Module,_) :- !, '$$cut_by'(X). -'$creep_call'(repeat,_) :- !, - '$current_module'(Module), +'$creep_call'(repeat,Module,_) :- !, '$direct_spy'([Module|repeat]). -'$creep_call'([A|B],_) :- !, - '$current_module'(Module), +'$creep_call'([A|B],Module,_) :- !, '$direct_spy'([Module|[A|B]]). -'$creep_call'(A,CP) :- - '$undefined'(A), !, - '$creep_call_undefined'(A,CP). -'$creep_call'(A,_) :- - '$current_module'(Module), +'$creep_call'(A,Module,CP) :- + '$undefined'(A,Module), !, + '$creep_call_undefined'(A,Module,CP). +'$creep_call'(A,Module,_) :- '$direct_spy'([Module|A]). -'$creep_call_undefined'(A,CP) :- +'$creep_call_undefined'(A,M,CP) :- functor(A,F,N), - '$current_module'(M), '$recorded'('$import','$import'(S,M,F,N),_), !, '$creep_call'(S:A,CP). -'$creep_call_undefined'(G, _) :- - ( \+ '$undefined'(user:unknown_predicate_handler(_,_,_)), - user:unknown_predicate_handler(G,M,NG) -> - '$creep_call'(M:NG) ; - '$is_dynamic'(G) -> fail ; +'$creep_call_undefined'(G, M, _) :- + ( \+ '$undefined'(unknown_predicate_handler(_,_,_), user), + user:unknown_predicate_handler(G,NM,NG) -> + '$creep_call'(NM:NG) ; + '$is_dynamic'(G, M) -> fail ; '$recorded'('$unknown','$unknown'(M:G,US),_), '$creep_call'(user:US,_) ). @@ -796,35 +754,31 @@ debugging :- '$get_value'('$throw', true), !, '$set_value'('$throw', false), abort. -'$creep'([Module|'$trace'(P,G,L)]) :- !, - ( Module=prolog -> '$trace'(P,G,L); - '$mod_switch'(Module, '$trace'(P,G,L)) - ). -'$creep'([Module|'$creep_call'(G,CP)]) :- !, - ( Module=prolog -> '$creep_call'(G,CP); - '$mod_switch'(Module, '$creep_call'(G,CP) ) - ). +'$creep'([_|'$trace'(P,G,Module,L)]) :- !, + '$trace'(P,G,Module,L). +'$creep'([_|'$creep_call'(G,Mod,CP)]) :- !, + '$creep_call'(G,Mod,CP). '$creep'([_|'$leave_creep']) :- !. '$creep'(G) :- '$direct_spy'(G). -'$trace'(P,'!'(_),L) :- !, - '$trace'(P,!,L). -'$trace'(P,G,L) :- - '$chk'(P,L,G,SL), - '$msg'(P,G,L,SL). -'$trace'(_,_,_). +'$trace'(P,'!'(_),Mod,L) :- !, + '$trace'(P,!,Mod,L). +'$trace'(P,G,Mod,L) :- + '$chk'(P,L,G,Mod,SL), + '$msg'(P,G,Mod,L,SL). +'$trace'(_,_,_,_). -'$msg'(P,G,L,SL):- +'$msg'(P,G,Module,L,SL):- flush_output(user_output), flush_output(user_error), '$get_value'(debug,1), repeat, - ('$pred_being_spied'(G) -> write(user_error,'*') ; write(user_error,' ')), + ('$pred_being_spied'(G,Module) -> write(user_error,'*') ; write(user_error,' ')), ( SL = L -> write(user_error,'>') ; write(user_error,' ')), write(user_error,' ('), write(user_error,L), write(user_error,') '), write(user_error,P), write(user_error,': '), - ( '$current_module'(Module), Module\=prolog, - Module\=user -> write(user_error,Module),write(user_error,':'); + ( Module\=prolog, + Module\=user -> write(user_error,Module),write(user_error,':'); true ), '$debugger_write'(user_error,G), @@ -868,16 +822,16 @@ debugging :- write(user_error,[chk,L,P,Leap,SP,SC,SL,FS,CL,G]), nl(user_error), fail. */ -'$chk'(_,_,[_|_],_) :- !, fail. -'$chk'(P,L,G,SL) :- +'$chk'(_,_,[_|_],_,_) :- !, fail. +'$chk'(P,L,G,Mod,SL) :- '$get_value'(spy_leap,Leap), (Leap = 0 -> true; % not leaping - ('$pred_being_spied'(G) ; Leap = L), % leaping or quasileaping + ('$pred_being_spied'(G,Mod) ; Leap = L), % leaping or quasileaping '$set_value'(spy_leap,0) ), '$get_value'(spy_sp,SP), (SP = 0; SP = P), % the current skipport or no skipport '$access_yap_flags'(10,SC), - (SC = 1; '$pred_being_spied'(G)), + (SC = 1; '$pred_being_spied'(G,Mod)), '$get_value'(spy_sl,SL), (SL = 0; SL = L, '$set_value'(spy_sl,0), '$set_value'(spy_fs,0)), '$set_value'(spy_sp,0), !. @@ -1029,13 +983,13 @@ debugging :- '$DebugError'(T) :- !, throw(T). -'$init_spy_cl'(G) :- +'$init_spy_cl'(G,M) :- % dynamic, immediate update procedure. - '$flags'(G,F,F), F /\ 16'2000 =\= 0, !, - ( '$db_first_age'(G,A) -> + '$flags'(G,M,F,F), F /\ 16'2000 =\= 0, !, + ( '$db_first_age'(M:G,A) -> '$set_value'(spy_cl, A) ; % no clauses for pred. '$set_value'(spy_cl, 1) ). -'$init_spy_cl'(_) :- +'$init_spy_cl'(_,_) :- '$set_value'(spy_cl, 1). diff --git a/pl/depth_bound.yap b/pl/depth_bound.yap index a9a69c53b..d1bdf43f2 100644 --- a/pl/depth_bound.yap +++ b/pl/depth_bound.yap @@ -20,186 +20,3 @@ depth_bound_call(A,D) :- '$execute_under_depth_limit'(A,D). -'$old_depth_bound_call'(A,D) :- - '$check_callable'(A,A), - '$user_call_depth_limited'(A, D). - -'$user_call_depth_limited'(V,_) :- var(V), !, - throw(error(instantiation_error,V)). -'$user_call_depth_limited'(A,_) :- number(A), !, - throw(error(type_error(callable,A),A)). -'$user_call_depth_limited'(R,_) :- db_reference(R), !, - throw(error(type_error(callable,R),R)). -'$user_call_depth_limited'(A,D) :- - '$access_yap_flags'(10,V), - V \= 0, !, - '$save_current_choice_point'(CP), - '$spied_call_depth_limited'(A,CP,D). -'$user_call_depth_limited'(A,D) :- - '$save_current_choice_point'(CP), - '$call_depth_limited'(A,CP,D). - -'$call_depth_limited'(M:G,CP,D) :- !, - ( '$current_module'(M) -> - '$check_callable'(G,M:G), - '$call_depth_limited'(G,CP,D) - ; - '$check_callable'(G,M:G), - '$mod_switch'(M,'$call_depth_limited'(G,CP,D) ) - ). -'$call_depth_limited'(fail,_,_) :- !, fail. -'$call_depth_limited'(false,_,_) :- !, false. -'$call_depth_limited'(true,_,_) :- !. -'$call_depth_limited'(otherwise,_,_) :- !. -'$call_depth_limited'((A,B),CP,D) :- !, - '$check_callable'(A,(A,B)), - D1 is D+1, - '$call_depth_limited'(A,CP,D1), - '$check_callable'(B,(A,B)), - '$call_depth_limited'(B,CP,D1). -'$call_depth_limited'((X->Y),CP,D) :- !, - '$check_callable'(X,(X->Y)), - CP1 is local_sp, - D1 is D+1, - '$call_depth_limited'(X,CP,D1), - '$$cut_by'(CP1), - '$check_callable'(Y,(X->Y)), - '$call_depth_limited'(Y,CP,D1). -'$call_depth_limited'((X->Y; Z),CP,D) :- !, - '$check_callable'(X,(X->Y;Z)), - D1 is D+1, - ( - '$call_depth_limited'(X,CP,D1), !, - '$check_callable'(Y,(X->Y;Z)), - '$call_depth_limited'(Y,CP,D1) - ; - '$check_callable'(Z,(X->Y;Z)), - '$call_depth_limited'(Z,CP,D1) - ). -'$call_depth_limited'((A;B),CP,D) :- !, - '$check_callable'(A,(A;B)), - D1 is D+1, - ( - '$call_depth_limited'(A,CP,D1) - ; - '$check_callable'(B,(A;B)), - '$call_depth_limited'(B,CP,D1) - ). -'$call_depth_limited'((A|B),CP,D) :- !, - '$check_callable'(A,(A|B)), - D1 is D+1, - ( - '$call_depth_limited'(A,CP,D1) - ; - '$check_callable'(B,(A|B)), - '$call_depth_limited'(B,CP,D1) - ). -'$call_depth_limited'(\+ X,CP,D) :- !, - '$check_callable'(X, \+ X), - \+ '$call_depth_limited'(X,CP,D). -'$call_depth_limited'(not X,CP,D) :- !, - '$check_callable'(X, not X), - \+ '$call_depth_limited'(X,CP,D). -'$call_depth_limited'(!,CP,_) :- '$$cut_by'(CP). -'$call_depth_limited'(repeat,_,_) :- !, '$repeat'. -'$call_depth_limited'([A|B],_,_) :- !, '$csult'([A|B]). -'$call_depth_limited'(A,CP,D) :- - ( '$undefined'(A) -> - functor(A,F,N), '$current_module'(M), - ( '$recorded'('$import','$import'(S,M,F,N),_) -> - '$call_depth_limited'(S:A,CP,D) ; - get_depth_limit(D0), - '$set_depth_limit'(D), - '$undefp'([M|A]), - '$set_depth_limit'(D0), - '$ensure_env_for_call_depth_limited' - ) - ; - get_depth_limit(D0), - '$set_depth_limit'(D), - '$execute0'(A), - '$set_depth_limit'(D0), - '$ensure_env_for_call_depth_limited' - ). - - -'$spied_call_depth_limited'(M:G,CP,D) :- !, - '$check_callable'(G,M:G), - '$mod_switch'(M,'$spied_call_depth_limited'(G,CP,D)). -'$spied_call_depth_limited'(fail,_,_) :- !, fail. -'$spied_call_depth_limited'(false,_,_) :- !, false. -'$spied_call_depth_limited'(true,_,_) :- !. -'$spied_call_depth_limited'(otherwise,_,_) :- !. -'$spied_call_depth_limited'((A,B),CP,D) :- !, - '$check_callable'(A,(A,B)), - D1 is D+1, - '$spied_call_depth_limited'(A,CP,D1), - '$check_callable'(B,(A,B)), - '$spied_call_depth_limited'(B,CP,D1). -'$spied_call_depth_limited'((X->Y),CP,D) :- !, - '$check_callable'(X,(X->Y)), - CP1 is local_sp, - D1 is D+1, - '$spied_call_depth_limited'(X,CP,D1), - '$$cut_by'(CP1), - '$check_callable'(Y,(X->Y)), - '$spied_call_depth_limited'(Y,CP,D1). -'$spied_call_depth_limited'((X->Y; Z),CP, D) :- !, - '$check_callable'(X,(X->Y;Z)), - D1 is D+1, - ( - '$spied_call_depth_limited'(X,CP,D1), !, - '$check_callable'(Y,(X->Y;Z)), - '$spied_call_depth_limited'(Y,CP,D1) - ; - '$check_callable'(Z,(X->Y;Z)), - '$spied_call_depth_limited'(Z,CP,D1) - ). -'$spied_call_depth_limited'((A;B),CP,D) :- !, - '$check_callable'(A,(A;B)), - D1 is D+1, - ( - '$spied_call_depth_limited'(A,CP,D1) - ; - '$check_callable'(B,(A;B)), - '$spied_call_depth_limited'(B,CP,D1) - ). -'$spied_call_depth_limited'((A|B),CP,D) :- !, - '$check_callable'(A,(A|B)), - D1 is D+1, - ( - '$spied_call_depth_limited'(A,CP,D1) - ; - '$check_callable'(B,(A|B)), - '$spied_call_depth_limited'(B,CP,D1) - ). -'$spied_call_depth_limited'(\+ X,CP,D) :- !, - '$check_callable'(X, \+ X), - \+ '$spied_call_depth_limited'(X,CP,D). -'$spied_call_depth_limited'(not X,CP,D) :- !, - '$check_callable'(X, not X), - \+ '$spied_call_depth_limited'(X,CP,D). -'$spied_call_depth_limited'(!,CP,_) :- '$$cut_by'(CP). -'$spied_call_depth_limited'(repeat,_,_) :- !, '$repeat'. -'$spied_call_depth_limited'([A|B],_,_) :- !, '$csult'([A|B]). -'$spied_call_depth_limited'(A,CP,D) :- - ( '$undefined'(A) -> - functor(A,F,N), '$current_module'(M), - ( '$recorded'('$import','$import'(S,M,F,N),_) -> - '$spied_call_depth_limited'(S:A,CP,D) ; - get_depth_limit(D0), - '$set_depth_limit'(D), - '$spy'(A), - '$set_depth_limit'(D0), - '$ensure_env_for_call_depth_limited' - ) - ; - get_depth_limit(D0), - '$set_depth_limit'(D), - '$spy'(A), - '$set_depth_limit'(D0), - '$ensure_env_for_call_depth_limited' - ). - -'$ensure_env_for_call_depth_limited'. - diff --git a/pl/directives.yap b/pl/directives.yap index 5e8a49584..1ac2d218e 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -37,58 +37,60 @@ '$directive'(block(_)). '$directive'(wait(_)). -'$exec_directive'(multifile(D), _) :- - '$system_catch'('$multifile'(D), +'$exec_directive'(multifile(D), _, M) :- + '$system_catch'('$multifile'(D, M), Error, user:'$LoopError'(Error)). -'$exec_directive'(discontiguous(D), _) :- - '$discontiguous'(D). -'$exec_directive'(op(D), _) :- - '$discontiguous'(D). -'$exec_directive'(initialization(D), _) :- - '$initialization'(D). -'$exec_directive'(parallel, _) :- +'$exec_directive'(discontiguous(D), _, M) :- + '$discontiguous'(D,M). +'$exec_directive'(initialization(D), _, M) :- + '$initialization'(M:D). +'$exec_directive'(parallel, _, _) :- '$parallel'. -'$exec_directive'(sequential, _) :- +'$exec_directive'(sequential, _, _) :- '$sequential'. -'$exec_directive'(sequential(G), _) :- - '$sequential_directive'(G). -'$exec_directive'(include(F), Status) :- +'$exec_directive'(sequential(G), _, M) :- + '$sequential_directive'(G, M). +'$exec_directive'(parallel(G), _, M) :- + '$parallel_directive'(G, M). +'$exec_directive'(include(F), Status, _) :- '$include'(F, Status). -'$exec_directive'(module(N,P), Status) :- +'$exec_directive'(module(N,P), Status, _) :- '$module'(Status,N,P). -'$exec_directive'(module(N,P,Op), Status) :- +'$exec_directive'(module(N,P,Op), Status, _) :- '$module'(Status,N,P,Op). -'$exec_directive'(meta_predicate(P), _) :- - '$meta_predicate'(P). -'$exec_directive'(dynamic(P), _) :- - '$dynamic'(P). -'$exec_directive'(op(P,OPSEC,OP), _) :- +'$exec_directive'(meta_predicate(P), _, M) :- + '$meta_predicate'(P, M). +'$exec_directive'(dynamic(P), _, M) :- + '$dynamic'(P, M). +'$exec_directive'(op(P,OPSEC,OP), _, _) :- op(P,OPSEC,OP). -'$exec_directive'(set_prolog_flag(F,V), _) :- +'$exec_directive'(set_prolog_flag(F,V), _, _) :- set_prolog_flag(F,V). -'$exec_directive'(ensure_loaded(F), _) :- +'$exec_directive'(ensure_loaded(F), _, _) :- '$ensure_loaded'(F). -'$exec_directive'(char_conversion(IN,OUT), _) :- +'$exec_directive'(char_conversion(IN,OUT), _, _) :- char_conversion(IN,OUT). -'$exec_directive'(public(P), _) :- - '$public'(P). -'$exec_directive'(compile(F), _) :- +'$exec_directive'(public(P), _, M) :- + '$public'(P, M). +'$exec_directive'(compile(F), _, _) :- '$compile'(F). -'$exec_directive'(reconsult(Fs), _) :- +'$exec_directive'(reconsult(Fs), _, _) :- '$reconsult'(Fs). -'$exec_directive'(consult(Fs), _) :- +'$exec_directive'(consult(Fs), _, _) :- '$consult'(Fs). -'$exec_directive'(block(BlockSpec), _) :- +'$exec_directive'(block(BlockSpec), _, _) :- '$block'(BlockSpec). -'$exec_directive'(wait(BlockSpec), _) :- +'$exec_directive'(wait(BlockSpec), _, _) :- '$wait'(BlockSpec). +'$exec_directive'(table(PredSpec), _, M) :- + '$table'(PredSpec, M). -'$exec_directives'((G1,G2), Mode) :- !, - '$exec_directives'(G1, Mode), - '$exec_directives'(G2, Mode). -'$exec_directives'(G, Mode) :- - '$exec_directive'(G, Mode). +'$exec_directives'((G1,G2), Mode, M) :- !, + '$exec_directives'(G1, Mode, M), + '$exec_directives'(G2, Mode, M). +'$exec_directives'(G, Mode, M) :- + '$exec_directive'(G, Mode, M). @@ -397,7 +399,7 @@ yap_flag(toplevel_hook,G) :- !, yap_flag(typein_module,X) :- var(X), !, - current_module(X). + '$current_module'(X). yap_flag(typein_module,X) :- module(X). diff --git a/pl/errors.yap b/pl/errors.yap index f590e2acd..09939a678 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -59,8 +59,8 @@ print_message(force(_Severity), Msg) :- !, print(user_error,Msg). print_message(Severity, Msg) :- - \+ '$undefined'(user: portray_message(Severity, Msg)), - user: portray_message(Severity, Msg), !. + \+ '$undefined'(portray_message(Severity, Msg), user), + user:portray_message(Severity, Msg), !. print_message(error,error(Msg,Where)) :- '$output_error_message'(Msg, Where), !. print_message(error,Throw) :- diff --git a/pl/grammar.yap b/pl/grammar.yap index b6fe9ddd6..bb2b580fd 100644 --- a/pl/grammar.yap +++ b/pl/grammar.yap @@ -64,10 +64,9 @@ '$t_body'((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !, '$t_body'(T, ToFill, not_last, S, SR1, Tt), '$t_body'(R, ToFill, Last, SR1, SR, Rt). -'$t_body'((T;R), ToFill, _Last, S, SR, (Tt;Rt)) :- !, - copy_term(ToFill,OtherToFill), - '$t_body'(T, OtherToFill, last, S, SR, Tt), - '$t_body'(R, ToFill, last, S, SR, Rt). +'$t_body'((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !, + '$t_body'(T, _, last, S, SR, Tt), + '$t_body'(R, _, last, S, SR, Rt). '$t_body'(M:G, ToFill, Last, S, SR, M:NG) :- !, '$t_body'(G, ToFill, Last, S, SR, NG). '$t_body'(T, filled_in, _, S, SR, Tt) :- diff --git a/pl/init.yap b/pl/init.yap index f897803d0..b782b7419 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -110,15 +110,17 @@ system_mode(verbose,off) :- '$set_value'('$verbose',off). :- module(user). +:- multifile library_directory/1. + :- dynamic_predicate(library_directory/1, logical). :- multifile goal_expansion/3. :- dynamic_predicate(goal_expansion/3, logical). -:- multifile term_expansion/3. +:- multifile term_expansion/2. -:- dynamic_predicate(term_expansion/3, logical). +:- dynamic_predicate(term_expansion/2, logical). :- get_value(system_library_directory,D), assert(library_directory(D)). diff --git a/pl/listing.yap b/pl/listing.yap index e299f3742..471c2cd2c 100644 --- a/pl/listing.yap +++ b/pl/listing.yap @@ -20,39 +20,41 @@ */ listing :- - '$current_predicate_no_modules'(_,Pred), - '$list_clauses'(Pred). + '$current_module'(Mod), + '$current_predicate_no_modules'(Mod,_,Pred), + '$list_clauses'(Mod,Pred). listing. -listing(V) :- var(V), !. % ignore variables -listing(M:V) :- !, - '$mod_switch'(M,'$listing'(V)). -listing([]) :- !. -listing([X|Rest]) :- - !, - listing(X), - listing(Rest). -listing(X) :- - '$listing'(X). +listing(V) :- + '$current_module'(M), + '$listing'(V,M). -'$listing'(X) :- +'$listing'(V,_) :- var(V), !. % ignore variables +'$listing'(M:V,_) :- !, + '$listing'(V,M). +'$listing'([],_) :- !. +'$listing'([X|Rest], M) :- + !, + '$listing'(X, M), + '$listing'(Rest, M). +'$listing'(X, M) :- '$funcspec'(X,Name,Arity), - '$current_predicate_no_modules'(Name,Pred), + '$current_predicate_no_modules'(M,Name,Pred), functor(Pred,Name,Arity), - '$list_clauses'(Pred). -'$listing'(_). + '$list_clauses'(M,Pred). +'$listing'(_,_). '$funcspec'(Name/Arity,Name,Arity) :- !, atom(Name). '$funcspec'(Name,Name,_) :- atom(Name), !. '$funcspec'(Name,_,_) :- write('! Invalid procedure specification : '), write(Name), nl. -'$list_clauses'(Pred) :- - ( '$recordedp'(Pred,_,_) -> nl ), +'$list_clauses'(M,Pred) :- + ( '$recordedp'(M:Pred,_,_) -> nl ), fail. -'$list_clauses'(Pred) :- - '$recordedp'(Pred,(Pred:-Body),_), +'$list_clauses'(M,Pred) :- + '$recordedp'(M:Pred,(Pred:-Body),_), '$beautify_vars'((Pred:-Body)), '$write_clause'(Pred,Body), fail. diff --git a/pl/modules.yap b/pl/modules.yap index 69cbd1ae8..4983b5788 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -202,9 +202,9 @@ module(N) :- '$import'([N/K|L],M,T) :- integer(K), atom(N), !, ( '$check_import'(M,T,N,K) -> -% format(user_error,'[Importing ~w to ~w]~n',[M:N/K,T]), +% format(user_error,'[vsc1: Importing ~w to ~w]~n',[M:N/K,T]), ( T = user -> - recordz('$import','$import'(M,_,N,K),_) + recordz('$import','$import'(M,user,N,K),_) ; recorda('$import','$import'(M,T,N,K),_) ) @@ -241,8 +241,9 @@ module(N) :- ( '$check_import'(M,Mod,N,K) -> % format(user_error,'[ Importing ~w to ~w]~n',[M:N/K,Mod]), % '$trace_module'(importing(M:N/K,Mod)), +% format(user_error,'[vsc2: Importing ~w to ~w]~n',[M:N/K,T]), (Mod = user -> - recordz('$import','$import'(M,_,N,K),_) + recordz('$import','$import'(M,user,N,K),_) ; recorda('$import','$import'(M,Mod,N,K),_) ) @@ -250,7 +251,6 @@ module(N) :- true ). - '$abolish_module_data'(M) :- '$current_module'(T), ( '$recorded'('$import','$import'(M,T0,_,_),R), T0 == T, erase(R), fail; true), @@ -261,16 +261,14 @@ module(N) :- % expand module names in a clause -'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO)) :- !, - '$current_module'(M), +'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !, '$prepare_body_with_correct_modules'(B, M, B0), - '$module_u_vars'(H,UVars), % collect head variables in + '$module_u_vars'(H,UVars,M), % collect head variables in % expanded positions '$module_expansion'(B0,B1,BO,M,M,M,UVars). % expand body -'$module_expansion'((H:-B),(H:-B1),(H:-BO)) :- - '$module_u_vars'(H,UVars), % collect head variables in +'$module_expansion'((H:-B),(H:-B1),(H:-BO),M) :- + '$module_u_vars'(H,UVars,M), % collect head variables in % expanded positions - '$current_module'(M), '$module_expansion'(B,B1,BO,M,M,M,UVars). % expand body % $trace_module((H:-B),(H:-B1)). @@ -317,16 +315,16 @@ module(N) :- % '$exec_with_expansion'(G0, GoalMod, CurMod) :- '$meta_expansion'(GoalMod, CurMod, G0, GF, []), !, - '$mod_switch'(GoalMod,'$exec_with_expansion2'(GF,GoalMod)). + '$exec_with_expansion2'(GF,GoalMod). '$exec_with_expansion'(G, GoalMod, _) :- - '$mod_switch'(GoalMod,'$exec_with_expansion2'(G,GoalMod)). + '$exec_with_expansion2'(G,GoalMod). '$exec_with_expansion2'(G, M) :- '$pred_goal_expansion_on', user:goal_expansion(G,M,GF), !, '$execute'(M:GF). -'$exec_with_expansion2'(G, _) :- !, - '$execute0'(G). +'$exec_with_expansion2'(G, M) :- !, + '$execute0'(G, M). % expand module names in a body @@ -385,7 +383,7 @@ module(N) :- '$imported_pred'(G, ImportingMod, ExportingMod) :- - '$undefined'(ImportingMod:G), + '$undefined'(G, ImportingMod), functor(G,F,N), '$recorded'('$import','$import'(ExportingMod,ImportingMod,F,N),_), ExportingMod \= ImportingMod. @@ -412,30 +410,31 @@ module(N) :- % directive now meta_predicate Ps :- $meta_predicate(Ps). -'$meta_predicate'((P,Ps)) :- !, - '$meta_predicate'(P), - '$meta_predicate'(Ps). -'$meta_predicate'(P) :- +:- dynamic user:'$meta_predicate'/4. + +'$meta_predicate'((P,Ps), M) :- !, + '$meta_predicate'(P, M), + '$meta_predicate'(Ps, M). +'$meta_predicate'(M:D, _) :- !, + '$meta_predicate'(D, M). +'$meta_predicate'(P, M1) :- functor(P,F,N), - '$current_module'(M1), ( M1 = prolog -> M = _ ; M1 = M), - ( retractall('$meta_predicate'(F,M,N,_)), fail ; true), - asserta('$meta_predicate'(F,M,N,P)), - '$flags'(P, Fl, Fl), + ( retractall(user:'$meta_predicate'(F,M,N,_)), fail ; true), + asserta(user:'$meta_predicate'(F,M,N,P)), + '$flags'(P, M1, Fl, Fl), NFlags is Fl \/ 0x200000, - '$flags'(P, Fl, NFlags). + '$flags'(P, M1, Fl, NFlags). % return list of vars in expanded positions on the head of a clause. % % these variables should not be expanded by meta-calls in the body of the goal. % -'$module_u_vars'(H,UVars) :- +'$module_u_vars'(H,UVars,M) :- functor(H,F,N), - '$current_module'(M), -% '$recorded'('$meta_predicate','$meta_predicate'(M,F,N,D),_), !, - '$meta_predicate'(F,M,N,D), !, + user:'$meta_predicate'(F,M,N,D), !, '$module_u_vars'(N,D,H,UVars). -'$module_u_vars'(_,[]). +'$module_u_vars'(_,[],_). '$module_u_vars'(0,_,_,[]) :- !. '$module_u_vars'(I,D,H,[Y|L]) :- @@ -452,8 +451,7 @@ module(N) :- '$meta_expansion'(Mod,MP,G,G1,HVars) :- functor(G,F,N), -% '$recorded'('$meta_predicate','$meta_predicate'(Mod,F,N,D),_), !, - '$meta_predicate'(F,Mod,N,D), !, + user:'$meta_predicate'(F,Mod,N,D), !, functor(G1,F,N), % format(user_error,'[expanding ~w:~w in ~w',[Mod,G,MP]), '$meta_expansion_loop'(N,D,G,G1,HVars,MP). @@ -493,10 +491,6 @@ source_module(Mod) :- '$member'(X,[X|_]) :- !. '$member'(X,[_|L]) :- '$member'(X,L). -% -% this declaration should only be here, as meta_predicates should belong -% to the user module, not to the prolog module - :- meta_predicate % [:,:], abolish(:), @@ -560,7 +554,7 @@ source_module(Mod) :- % a:assert(g :- user:b)) % '$preprocess_clause_before_mod_change'((H:-B),M,M1,(H:-B1)) :- - '$mod_switch'(M1,'$module_u_vars'(H,UVars)), + '$module_u_vars'(H,UVars,M1), '$preprocess_body_before_mod_change'(B,M,UVars,B1). '$preprocess_body_before_mod_change'(V,M,_,call(M:V)) :- var(V), !. @@ -583,6 +577,5 @@ source_module(Mod) :- '$system_predicate'(G), !. '$preprocess_body_before_mod_change'(G,M,_,M:G). - :- '$switch_log_upd'(0). diff --git a/pl/preds.yap b/pl/preds.yap index b825ef4ac..e2c145e53 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -20,69 +20,75 @@ asserta(V) :- var(V), !, throw(error(instantiation_error,asserta(V))). -asserta(C) :- '$assert'(C,first,_,asserta(C)). +asserta(C) :- + '$current_module'(Mod), + '$assert'(C,Mod,first,_,asserta(C)). assertz(V) :- var(V), !, throw(error(instantiation_error,assertz(V))). -assertz(C) :- '$assert'(C,last,_,assertz(C)). +assertz(C) :- + '$current_module'(Mod), + '$assert'(C,Mod,last,_,assertz(C)). assert(V) :- var(V), !, throw(error(instantiation_error,assert(V))). -assert(C) :- '$assert'(C,last,_,assert(C)). +assert(C) :- + '$current_module'(Mod), + '$assert'(C,Mod,last,_,assert(C)). -'$assert'(V,_,_,_) :- var(V), !, - throw(error(instantiation_error,assert(V))). -'$assert'(M:C,Where,R,P) :- !, - '$mod_switch'(M,'$assert'(C,Where,R,P)). -'$assert'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, - '$current_module'(M1), +'$assert'(V,Mod,_,_,_) :- var(V), !, + throw(error(instantiation_error,assert(Mod:V))). +'$assert'(M:C,_,Where,R,P) :- !, + '$assert'(C,M,Where,R,P). +'$assert'((H:-G),M1,Where,R,P) :- + (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, ( M1 = M -> - '$assert'((C:-G),Where,R,P) + '$assert'((C:-G),M1,Where,R,P) ; '$preprocess_clause_before_mod_change'((C:-G),M1,M,C1), - '$mod_switch'(M,'$assert'(C1,Where,R,P)) + '$assert'(C1,M,Where,R,P) ). -'$assert'(CI,Where,R,P) :- - '$expand_clause'(CI,C0,C), +'$assert'(CI,Mod,Where,R,P) :- + '$expand_clause'(CI,C0,C,Mod), '$check_head_and_body'(C,H,B,P), - ( '$is_dynamic'(H) -> - '$assertat_d'(Where,H,B,C0,R) + ( '$is_dynamic'(H, Mod) -> + '$assertat_d'(Where, H, B, C0, Mod, R) ; - '$undefined'(H) -> + '$undefined'(H,Mod) -> functor(H, Na, Ar), '$dynamic'(Na/Ar), - '$assertat_d'(Where,H,B,C0,R) + '$assertat_d'(Where,H,B,C0,Mod,R) ; '$access_yap_flags'(14, 1) -> % I can assert over static facts in YAP mode - '$assert1'(Where,C,C0,H) + '$assert1'(Where,C,C0,Mod,H) ; functor(H, Na, Ar), throw(error(permission_error(modify,static_procedure,Na/Ar),P)) ). -'$assert_dynamic'(V,_,_,_) :- var(V), !, - throw(error(instantiation_error,assert(V))). -'$assert_dynamic'(M:C,Where,R,P) :- !, - '$mod_switch'(M,'$assert_dynamic'(C,Where,R,P)). -'$assert_dynamic'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, - '$current_module'(M1), +'$assert_dynamic'(V,Mod,_,_,_) :- var(V), !, + throw(error(instantiation_error,assert(Mod:V))). +'$assert_dynamic'(M:C,_,Where,R,P) :- !, + '$assert_dynamic'(C,Mod,Where,R,P). +'$assert_dynamic'((H:-G),M1,Where,R,P) :- + (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, ( M1 = M -> - '$assert_dynamic'((C:-G),Where,R,P) + '$assert_dynamic'((C:-G),M1,Where,R,P) ; '$preprocess_clause_before_mod_change'((C:-G),M1,M,C1), - '$mod_switch'(M,'$assert_dynamic'(C1,Where,R,P)) + '$assert_dynamic'(C1,M,Where,R,P) ). -'$assert_dynamic'(CI,Where,R,P) :- - '$expand_clause'(CI,C0,C), +'$assert_dynamic'(CI,Mod,Where,R,P) :- + '$expand_clause'(CI,C0,C,Mod), '$check_head_and_body'(C,H,B,P), - ( '$is_dynamic'(H) -> - '$assertat_d'(Where,H,B,C0,R) + ( '$is_dynamic'(H, Mod) -> + '$assertat_d'(Where,H,B,C0,Mod,R) ; - '$undefined'(H) -> + '$undefined'(H, Mod) -> functor(H, Na, Ar), '$dynamic'(Na/Ar), - '$assertat_d'(Where,H,B,C0,R) + '$assertat_d'(Where,H,B,C0,Mod,R) ; functor(H,Na,Ar), throw(error(permission_error(modify,static_procedure,Na/Ar),P)) @@ -90,197 +96,223 @@ assert(C) :- '$assert'(C,last,_,assert(C)). assert_static(V) :- var(V), !, throw(error(instantiation_error,assert_static(V))). -assert_static(C) :- '$assert_static'(C,last,_,assert_static(C)). +assert_static(C) :- + '$current_module'(Mod), + '$assert_static'(C,Mod,last,_,assert_static(C)). asserta_static(V) :- var(V), !, throw(error(instantiation_error,asserta_static(V))). -asserta_static(C) :- '$assert_static'(C,first,_,asserta_static(C)). +asserta_static(C) :- + '$current_module'(Mod), + '$assert_static'(C,Mod,first,_,asserta_static(C)). assertz_static(V) :- var(V), !, throw(error(instantiation_error,assertz_static(V))). assertz_static(C) :- - '$assert_static'(C,last,_,assertz_static(C)). + '$current_module'(Mod), + '$assert_static'(C,Mod,last,_,assertz_static(C)). -'$assert_static'(V,_,_,_) :- var(V), !, - throw(error(instantiation_error,assert(V))). -'$assert_static'(M:C,Where,R,P) :- !, - '$mod_switch'(M,'$assert_static'(C,Where,R,P)). -'$assert_static'((H:-G),Where,R,P) :- (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, - '$current_module'(M1), +'$assert_static'(V,M,_,_,_) :- var(V), !, + throw(error(instantiation_error,assert(M:V))). +'$assert_static'(M:C,_,Where,R,P) :- !, + '$assert_static'(C,M,Where,R,P). +'$assert_static'((H:-G),M1,Where,R,P) :- + (var(H) -> throw(error(instantiation_error,P)) ; H=M:C), !, ( M1 = M -> - '$assert_static'((C:-G),Where,R,P) + '$assert_static'((C:-G),M1,Where,R,P) ; '$preprocess_clause_before_mod_change'((C:-G),M1,M,C1), - '$mod_switch'(M,'$assert_static'(C1,Where,R,P)) + '$assert_static'(C1,M,Where,R,P) ). -'$assert_static'(CI,Where,R,P) :- - '$expand_clause'(CI,C0,C), +'$assert_static'(CI,Mod,Where,R,P) :- + '$expand_clause'(CI,C0,C,Mod), '$check_head_and_body'(C,H,B,P), - ( '$is_dynamic'(H) -> + ( '$is_dynamic'(H, Mod) -> throw(error(permission_error(modify,dynamic_procedure,Na/Ar),P)) ; - '$undefined'(H), '$get_value'('$full_iso',true) -> - functor(H,Na,Ar), '$dynamic'(Na/Ar), '$assertat_d'(Where,H,B,C0,R) + '$undefined'(H,Mod), '$get_value'('$full_iso',true) -> + functor(H,Na,Ar), '$dynamic'(Na/Ar), '$assertat_d'(Where,H,B,C0,Mod,R) ; - '$assert1'(Where,C,C0,H) + '$assert1'(Where,C,C0,Mod,H) ). -'$assertat_d'(first,Head,Body,C0,R) :- !, - '$compile_dynamic'((Head:-Body),2,CR), +'$assertat_d'(first,Head,Body,C0,Mod,R) :- !, + '$compile_dynamic'((Head:-Body), 2, Mod, CR), ( '$get_value'('$abol',true) -> - '$flags'(H,Fl,Fl), - ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ), - ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true ) + '$flags'(H,Mod,Fl,Fl), + ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ), + ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true ) ; true ), '$head_and_body'(C0, H0, B0), - '$recordap'(Head,(H0 :- B0),R,CR), - functor(Head,Na,Ar), - ( '$is_multifile'(Na,Ar) -> + '$recordap'(Mod:Head,(H0 :- B0),R,CR), + ( '$is_multifile'(Head, Mod) -> '$get_value'('$consulting_file',F), - '$current_module'(M), - '$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), _) + functor(H0, Na, Ar), + '$recorda'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _) ; true ). -'$assertat_d'(last,Head,Body,C0,R) :- - '$compile_dynamic'((Head:-Body),0,CR), +'$assertat_d'(last,Head,Body,C0,Mod,R) :- + '$compile_dynamic'((Head:-Body), 0, Mod, CR), ( '$get_value'('$abol',true) -> - '$flags'(H,Fl,Fl), - ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H) ; true ), - ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Fl) ; true ) + '$flags'(H,Mod,Fl,Fl), + ( Fl /\ 16'400000 =\= 0 -> '$erase_source'(H,Mod) ; true ), + ( Fl /\ 16'040000 =\= 0 -> '$check_multifile_pred'(H,Mod,Fl) ; true ) ; true ), '$head_and_body'(C0, H0, B0), - '$recordzp'(Head,(H0 :- B0),R,CR), - functor(H0,Na,Ar), - ( '$is_multifile'(Na,Ar) -> + '$recordzp'(Mod:Head,(H0 :- B0),R,CR), + ( '$is_multifile'(H0, Mod) -> '$get_value'('$consulting_file',F), - '$current_module'(M), - '$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,M,F,R), _) + functor(H0, Na, Ar), + '$recordz'('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _) ; true ). -'$assert1'(last,C,C0,H) :- '$$compile_stat'(C,C0,0,H). -'$assert1'(first,C,C0,H) :- '$$compile_stat'(C,C0,2,H). +'$assert1'(last,C,C0,Mod,H) :- '$$compile_stat'(C,C0,0,H,Mod). +'$assert1'(first,C,C0,Mod,H) :- '$$compile_stat'(C,C0,2,H,Mod). -'$assertz_dynamic'(X,C,C0) :- (X/\4)=:=0, !, +'$assertz_dynamic'(X, C, C0, Mod) :- (X/\4)=:=0, !, '$head_and_body'(C,H,B), - '$assertat_d'(last,H,B,C0,_). -'$assertz_dynamic'(X,C,C0) :- + '$assertat_d'(last,H,B,C0,Mod,_). +'$assertz_dynamic'(X,C,C0,Mod) :- '$head_and_body'(C,H,B), functor(H,N,A), ('$check_if_reconsulted'(N,A) -> true ; (X/\8)=:=0 -> '$inform_as_reconsulted'(N,A), - '$remove_all_d_clauses'(H) + '$remove_all_d_clauses'(H,Mod) ; true ), - '$assertat_d'(last,H,B,C0,_). + '$assertat_d'(last,H,B,C0,Mod,_). -'$remove_all_d_clauses'(H) :- +'$remove_all_d_clauses'(H,M) :- + '$is_multifile'(H, M), !, functor(H, Na, A), - '$is_multifile'(Na,A), !, - '$erase_all_mf_dynamic'(Na,A). -'$remove_all_d_clauses'(H) :- - '$recordedp'(H,_,R), erase(R), fail. -'$remove_all_d_clauses'(_). + '$erase_all_mf_dynamic'(Na,A,M). +'$remove_all_d_clauses'(H,M) :- + '$recordedp'(M:H,_,R), erase(R), fail. +'$remove_all_d_clauses'(_,_). -'$erase_all_mf_dynamic'(Na,A) :- +'$erase_all_mf_dynamic'(Na,A,M) :- '$get_value'('$consulting_file',F), - '$current_module'(M), '$recorded'('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1), erase(R1), erase(R), fail. -'$erase_all_mf_dynamic'(_,_). +'$erase_all_mf_dynamic'(_,_,_). asserta(V,R) :- var(V), !, throw(error(instantiation_error,asserta(V,R))). -asserta(C,R) :- '$assert_dynamic'(C,first,R,asserta(C,R)). +asserta(C,R) :- + '$current_module'(M), + '$assert_dynamic'(C,M,first,R,asserta(C,R)). assertz(V,R) :- var(V), !, throw(error(instantiation_error,assertz(V,R))). -assertz(C,R) :- '$assert_dynamic'(C,last,R,assertz(C,R)). +assertz(C,R) :- + '$current_module'(M), + '$assert_dynamic'(C,M,last,R,assertz(C,R)). assert(V,R) :- var(V), !, throw(error(instantiation_error,assert(V,R))). -assert(C,R) :- '$assert_dynamic'(C,last,R,assert(C,R)). +assert(C,R) :- + '$current_module'(M), + '$assert_dynamic'(C,M,last,R,assert(C,R)). -clause(V,Q) :- var(V), !, - throw(error(instantiation_error,clause(V,Q))). -clause(C,Q) :- number(C), !, - throw(error(type_error(callable,C),clause(C,Q))). -clause(R,Q) :- db_reference(R), !, - throw(error(type_error(callable,R),clause(R,Q))). -clause(M:P,Q) :- !, - '$mod_switch'(M,clause(P,Q)). -clause(P,Q) :- '$is_dynamic'(P), !, - '$recordedp'(P,(P:-Q),_). -clause(P,Q) :- - '$some_recordedp'(P), !, - '$recordedp'(P,(P:-Q),_). -clause(P,Q) :- +clause(V,Q) :- + '$current_module'(M), + '$clause'(V,M,Q). + +'$clause'(V,M,Q) :- var(V), !, + throw(error(instantiation_error,M:clause(V,Q))). +'$clause'(C,M,Q) :- number(C), !, + throw(error(type_error(callable,C),M:clause(C,Q))). +'$clause'(R,Q) :- db_reference(R), !, + throw(error(type_error(callable,R),M:clause(R,Q))). +'$clause'(M:P,_,Q) :- !, + '$clause'(P,M,Q). +'$clause'(P,Mod,Q) :- '$is_dynamic'(P, Mod), !, + '$recordedp'(Mod:P,(P:-Q),_). +'$clause'(P,M,Q) :- + '$some_recordedp'(M:P), !, + '$recordedp'(M:P,(P:-Q),_). +'$clause'(P,M,Q) :- ( '$system_predicate'(P) -> true ; - '$number_of_clauses'(P,N), N > 0 ), + '$number_of_clauses'(P,M,N), N > 0 ), functor(P,Name,Arity), - throw(error(permission_error(access,private_procedure,Name/Arity), - clause(P,Q))). + throw(error(permission_error(access,private_procedure,M:Name/Arity), + M:clause(P,Q))). -clause(V,Q,R) :- var(V), !, - throw(error(instantiation_error,clause(V,Q,R))). -clause(C,Q,R) :- number(C), !, - throw(error(type_error(callable,C),clause(C,Q,R))). -clause(R,Q,R1) :- db_reference(R), !, +clause(V,Q,R) :- + '$current_module'(V,M,Q,R), + '$clause'(V,M,Q,R). + +'$clause'(V,M,Q,R) :- var(V), !, + throw(error(instantiation_error,M:clause(V,Q,R))). +'$clause'(C,M,Q,R) :- number(C), !, + throw(error(type_error(callable,C),clause(C,M:Q,R))). +'$clause'(R,M,Q,R1) :- db_reference(R), !, throw(error(type_error(callable,R),clause(R,Q,R1))). -clause(M:P,Q,R) :- !, - '$mod_switch'(M,clause(P,Q,R)). -clause(P,Q,R) :- - ( '$is_dynamic'(P) -> - '$recordedp'(P,(P:-Q),R) +'$clause'(M:P,_,Q,R) :- !, + '$clause'(P,M,Q,R). +'$clause'(P,Mod,Q,R) :- + ( '$is_dynamic'(P, Mod) -> + '$recordedp'(Mod:P,(P:-Q),R) ; functor(P,N,A), - throw(error(permission_error(access,private_procedure,N/A), + throw(error(permission_error(access,private_procedure,Mod:N/A), clause(P,Q,R))) ). -retract(V) :- var(V), !, - throw(error(instantiation_error,retract(V))). -retract(M:C) :- !, - '$mod_switch'(M,retract(C)). -retract(C) :- - '$check_head_and_body'(C,H,B,retract(C)), - '$is_dynamic'(H), !, - '$recordedp'(H,(H:-B),R), erase(R). retract(C) :- + '$current_module'(M), + '$retract'(C,M). + + +'$retract'(V,_) :- var(V), !, + throw(error(instantiation_error,retract(V))). +'$retract'(M:C,_) :- !, + '$retract'(C,M). +'$retract'(C,M) :- + '$check_head_and_body'(C,H,B,retract(C)), + '$is_dynamic'(H, M), !, + '$recordedp'(M:H,(H:-B),R), erase(R). +'$retract'(C,M) :- '$fetch_predicate_indicator_from_clause'(C, PI), - throw(error(permission_error(modify,static_procedure,PI),retract(C))). + throw(error(permission_error(modify,static_procedure,PI),retract(M:C))). -retract(V,R) :- var(V), !, - throw(error(instantiation_error,retract(V,R))). -retract(M:C,R) :- !, - '$mod_switch'(M,retract(C,R)). -retract(C,R) :- +retract(C,R) :- !, + '$current_module'(M), + '$retract'(C,M,R). + + +'$retract'(V,M,R) :- var(V), !, + throw(error(instantiation_error,retract(M:V,R))). +'$retract'(M:C,_,R) :- !, + '$retract'(C,M,R). +'$retract'(C, M, R) :- '$check_head_and_body'(C,H,B,retract(C,R)), - db_reference(R), '$is_dynamic'(H), !, + db_reference(R), '$is_dynamic'(H,M), !, instance(R,(H:-B)), erase(R). -retract(C,R) :- +'$retract'(C,M,R) :- '$head_and_body'(C,H,B,retract(C,R)), - '$is_dynamic'(H), !, + '$is_dynamic'(H,M), !, var(R), - '$recordedp'(H,(H:-B),R), + '$recordedp'(M:H,(H:-B),R), erase(R). -retract(C,_) :- +'$retract'(C,M,_) :- '$fetch_predicate_indicator_from_clause'(C, PI), - throw(error(permission_error(modify,static_procedure,PI),retract(C))). + throw(error(permission_error(modify,static_procedure,PI),retract(M:C))). '$fetch_predicate_indicator_from_clause'((C :- _), Na/Ar) :- !, functor(C, Na, Ar). @@ -288,66 +320,75 @@ retract(C,_) :- functor(C, Na, Ar). -retractall(V) :- var(V), !, - throw(error(instantiation_error,retract(V))). -retractall(M:V) :- !, - '$mod_switch'(M,retractall(V)). -retractall(T) :- '$undefined'(T), - functor(T, Na, Ar), - '$dynamic'(Na/Ar), +retractall(V) :- !, + '$current_module'(M), + '$retractall'(V,M). + +'$retractall'(V,M) :- var(V), !, + throw(error(instantiation_error,retract(M:V))). +'$retractall'(M:V,_) :- !, + '$retractall'(V,M). +'$retractall'(T,M) :- + '$undefined'(T,M), + functor(T,Na,Ar), + '$dynamic'(Na/Ar,M), !, fail. -retractall(T) :- \+ '$is_dynamic'(T), !, +'$retractall'(T,M) :- + \+ '$is_dynamic'(T,M), !, functor(T,Na,Ar), throw(error(permission_error(modify,static_procedure,Na/Ar),retractall(T))). -retractall(T) :- - '$erase_all_clauses_for_dynamic'(T). +'$retractall'(T,M) :- + '$erase_all_clauses_for_dynamic'(T, M). -'$erase_all_clauses_for_dynamic'(T) :- - '$recordedp'(T,(T :- _),R), erase(R), fail. -'$erase_all_clauses_for_dynamic'(T) :- - '$recordedp'(T,_,_), fail. -'$erase_all_clauses_for_dynamic'(_). +'$erase_all_clauses_for_dynamic'(T, M) :- + '$recordedp'(M:T,(T :- _),R), erase(R), fail. +'$erase_all_clauses_for_dynamic'(T,M) :- + '$recordedp'(M:T,_,_), fail. +'$erase_all_clauses_for_dynamic'(_,_). -abolish(N,A) :- var(N), !, - throw(error(instantiation_error,abolish(N,A))). -abolish(N,A) :- var(A), !, - throw(error(instantiation_error,abolish(N,A))). -abolish(M:N,A) :- !, - '$mod_switch'(M,abolish(N,A)). -abolish(N,A) :- +abolish(N,A) :- + '$current_module'(Mod), + '$abolish'(N,A,Mod). + +'$abolish'(N,A,M) :- var(N), !, + throw(error(instantiation_error,abolish(M:N,A))). +'$abolish'(N,A,M) :- var(A), !, + throw(error(instantiation_error,abolish(M:N,A))). + throw(error(instantiation_error,abolish(M:N,A))). +'$abolish'(N,A,M) :- ( '$recorded'('$predicate_defs','$predicate_defs'(N,A,_),R) -> erase(R) ), fail. -abolish(N,A) :- functor(T,N,A), - ( '$is_dynamic'(T) -> '$abolishd'(T) ; - /* else */ '$abolishs'(T) ). +'$abolish'(N,A,M) :- functor(T,N,A), + ( '$is_dynamic'(T) -> '$abolishd'(T,M) ; + /* else */ '$abolishs'(T,M) ). abolish(X) :- '$access_yap_flags'(8, 2), !, - '$new_abolish'(X). -abolish(X) :- - '$old_abolish'(X). - -'$new_abolish'(V) :- var(V), !, - '$abolish_all'. -'$new_abolish'(M:PS) :- !, - '$mod_switch'(M,'$new_abolish'(PS)). -'$new_abolish'(Na/Ar) :- - functor(H, Na, Ar), - '$is_dynamic'(H), !, - '$abolishd'(H). -'$new_abolish'(Na/Ar) :- % succeed for undefined procedures. - functor(T, Na, Ar), - '$undefined'(T), !. -'$new_abolish'(Na/Ar) :- '$current_module'(M), + '$new_abolish'(X,M). +abolish(X,M) :- + '$old_abolish'(X,M). + +'$new_abolish'(V,M) :- var(V,N), !, + '$abolish_all'(M). +'$new_abolish'(M:PS,_) :- !, + '$new_abolish'(PS,M). +'$new_abolish'(Na/Ar, M) :- + functor(H, Na, Ar), + '$is_dynamic'(H, M), !, + '$abolishd'(H, M). +'$new_abolish'(Na/Ar, M) :- % succeed for undefined procedures. + functor(T, Na, Ar), + '$undefined'(T, M), !. +'$new_abolish'(Na/Ar, M) :- throw(error(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar))). -'$abolish_all' :- - current_predicate(_,P), +'$abolish_all'(M) :- + '$current_predicate'(M,_,P), functor(P, Na, Ar), - '$new_abolish'(Na/Ar), + '$new_abolish'(Na/Ar, M), fail. -'$abolish_all'. +'$abolish_all'(_). '$check_error_in_predicate_indicator'(V, Msg) :- var(V), !, @@ -385,92 +426,93 @@ abolish(X) :- \+ atom(M), !, throw(error(type_error(atom,M), Msg)). -'$old_abolish'(V) :- var(V), !, - '$abolish_all_old'. -'$old_abolish'(M:N) :- !, - '$mod_switch'(M,'$old_abolish'(N)). -'$old_abolish'([]) :- !. -'$old_abolish'([H|T]) :- !, abolish(H), abolish(T). -'$old_abolish'(N/A) :- abolish(N,A). +'$old_abolish'(V,M) :- var(V), !, + '$abolish_all_old'(M). +'$old_abolish'(M:N,_) :- !, + '$old_abolish'(N,M). +'$old_abolish'([], _) :- !. +'$old_abolish'([H|T], M) :- !, '$old_abolish'(H, M), '$old_abolish'(T, M). +'$old_abolish'(N/A, M) :- + '$abolish'(N, A, M). -'$abolish_all_old' :- - current_predicate(_,P), +'$abolish_all_old'(M) :- + '$current_predicate'(Mod,_,P), functor(P, Na, Ar), - '$abolish_old'(Na/Ar), + '$old_abolish'(Na/Ar, Mod), fail. '$abolish_all_old'. -'$abolishd'(T) :- '$recordedp'(T,_,R), erase(R), fail. -'$abolishd'(T) :- '$kill_dynamic'(T), fail. -'$abolishd'(_). +'$abolishd'(T, M) :- '$recordedp'(M:T,_,R), erase(R), fail. +'$abolishd'(T, M) :- '$kill_dynamic'(T,M), fail. +'$abolishd'(_, _). -'$abolishs'(G) :- '$in_use'(G), !, +'$abolishs'(G, M) :- '$in_use'(G, M), !, functor(G,Name,Arity), - throw(error(permission_error(modify,static_procedure_in_use,Name/Arity),abolish(G))). -'$abolishs'(G) :- '$system_predicate'(G), !, + throw(error(permission_error(modify,static_procedure_in_use,M:Name/Arity),abolish(G))). +'$abolishs'(G, _) :- '$system_predicate'(G), !, functor(G,Name,Arity), - throw(error(permission_error(modify,static_procedure,Name/Arity),abolish(G))). -'$abolishs'(G) :- + throw(error(permission_error(modify,static_procedure,M:Name/Arity),abolish(G))). +'$abolishs'(G, Module) :- '$access_yap_flags'(8, 2), % only do this in sicstus mode - '$undefined'(G), + '$undefined'(G, Module), functor(G,Name,Arity), - '$current_module'(Module), format(user_error,'[ Warning: abolishing undefined predicate (~w:~w/~w) ]~n',[Module,Name,Arity]), fail. % I cannot allow modifying static procedures in YAPOR % this code has to be here because of abolish/2 -'$abolishs'(G) :- +'$abolishs'(G, Module) :- '$has_yap_or', !, functor(G,A,N), - throw(error(permission_error(modify,static_procedure,A/N),abolish(G))). -'$abolishs'(G) :- - '$purge_clauses'(G), - '$recordedp'(G,_,R), erase(R), fail. -'$abolishs'(_). + throw(error(permission_error(modify,static_procedure,Module:A/N),abolish(G))). +'$abolishs'(G, M) :- + '$purge_clauses'(G, M), + '$recordedp'(M:G,_,R), erase(R), fail. +'$abolishs'(_, _). % % can only do as goal in YAP mode. % dynamic(X) :- '$access_yap_flags'(8, 0), !, - '$dynamic'(X). + '$current_module'(M), + '$dynamic'(X, M). dynamic(X) :- throw(error(context_error(dynamic(X),declaration),query)). -'$dynamic'(X) :- var(X), !, - throw(error(instantiation_error,dynamic(X))). -'$dynamic'(Mod:Spec) :- !, - '$mod_switch'(Mod,'$dynamic'(Spec)). -'$dynamic'((A,B)) :- !, '$dynamic'(A), '$dynamic'(B). -'$dynamic'([]) :- !. -'$dynamic'([H|L]) :- !, '$dynamic'(H), '$dynamic'(L). -'$dynamic'(A) :- - '$dynamic2'(A). +'$dynamic'(X,_) :- var(X), !, + throw(error(instantiation_error,dynamic(M:X))). +'$dynamic'(Mod:Spec,_) :- !, + '$dynamic'(Spec,Mod). +'$dynamic'([], _) :- !. +'$dynamic'([H|L], M) :- !, '$dynamic'(H, M), '$dynamic'(L, M). +'$dynamic'((A,B),M) :- !, '$dynamic'(A,M), '$dynamic'(B,M). +'$dynamic'(X,M) :- !, + '$dynamic2'(X,M). -'$dynamic2'(X) :- '$log_upd'(Stat), Stat\=0, !, - '$logical_updatable'(X). -'$dynamic2'(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), - ( F/\16'9bc88 =:= 0 -> NF is F \/ 16'2000, '$flags'(T, F, NF); - '$is_dynamic'(T) -> true; - F /\ 16'400 =:= 16'400, '$undefined'(T) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,F,NF); +'$dynamic2'(X, Mod) :- '$log_upd'(Stat), Stat\=0, !, + '$logical_updatable'(X, Mod). +'$dynamic2'(A/N, Mod) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,Mod,F,F), + ( F/\16'9bc88 =:= 0 -> NF is F \/ 16'2000, '$flags'(T, Mod, F, NF); + '$is_dynamic'(T,Mod) -> true; + F /\ 16'400 =:= 16'400, '$undefined'(T,Mod) -> F1 is F /\ \(0x600), NF is F1 \/ 16'2000, '$flags'(T,Mod,F,NF); F/\16'8 =:= 16'8 -> true ; - throw(error(permission_error(modify,static_procedure,A/N),dynamic(A/N))) - ), '$flags'(T,F1,F1). -'$dynamic2'(X) :- - throw(error(type_error(callable,X),dynamic(X))). + throw(error(permission_error(modify,static_procedure,Mod:A/N),dynamic(A/N))) + ). +'$dynamic2'(X,Mod) :- + throw(error(type_error(callable,X),dynamic(Mod:X))). -'$logical_updatable'(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), - ( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,F,NF); - '$is_dynamic'(T) -> true; - F /\ 16'400 =:= 16'400 , '$undefined'(T) -> NF is F \/ 0x8, '$flags'(T,F,NF); +'$logical_updatable'(A/N,Mod) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,Mod,F,F), + ( F/\16'9bc88 =:= 0 -> NF is F \/ 16'408, '$flags'(T,Mod,F,NF); + '$is_dynamic'(T,Mod) -> true; + F /\ 16'400 =:= 16'400 , '$undefined'(T,Mod) -> NF is F \/ 0x8, '$flags'(T,Mod,F,NF); F /\ 16'8=:= 16'8 -> true ; throw(error(permission_error(modify,static_procedure,A/N),dynamic(A/N))) ). -'$logical_updatable'(X) :- - throw(error(type_error(callable,X),dynamic(X))). +'$logical_updatable'(X,Mod) :- + throw(error(type_error(callable,X),dynamic(Mod:X))). dynamic_predicate(P,Sem) :- @@ -478,7 +520,8 @@ dynamic_predicate(P,Sem) :- dynamic_predicate(P,Sem) :- '$log_upd'(OldSem), ( Sem = logical -> '$switch_log_upd'(1) ; '$switch_log_upd'(0) ), - '$dynamic'(P), + '$current_module'(M), + '$dynamic'(P, M), '$switch_log_upd'(OldSem). '$bad_if_is_semantics'(Sem, Goal) :- @@ -489,37 +532,36 @@ dynamic_predicate(P,Sem) :- throw(error(domain_error(semantics_indicator,Sem),Goal)). -'$expand_clause'(C0,C1,C2) :- - '$expand_term_modules'(C0, C1, C2), +'$expand_clause'(C0,C1,C2,Mod) :- + '$expand_term_modules'(C0, C1, C2, Mod), ( '$get_value'('$strict_iso',on) -> '$check_iso_strict_clause'(C1) ; true ). -'$public'(X) :- var(X), !, +'$public'(X, _) :- var(X), !, throw(error(instantiation_error,public(X))). -'$public'(Mod:Spec) :- !, - '$mod_switch'(Mod,'$public'(Spec)). -'$public'((A,B)) :- !, '$public'(A), '$public'(B). -'$public'([]) :- !. -'$public'([H|L]) :- !, '$public'(H), '$public'(L). -'$public'(A/N) :- integer(N), atom(A), !, - functor(T,A,N), - '$do_make_public'(T). -'$public'(X) :- - throw(error(type_error(callable,X),dynamic(X))). +'$public'(Mod:Spec, _) :- !, + '$public'(Spec,Mod). +'$public'((A,B), M) :- !, '$public'(A,M), '$public'(B,M). +'$public'([],_) :- !. +'$public'([H|L], M) :- !, '$public'(H, M), '$public'(L, M). +'$public'(A/N, Mod) :- integer(N), atom(A), !, + '$do_make_public'(T, Mod). +'$public'(X, Mod) :- + throw(error(type_error(callable,X),dynamic(Mod:X))). -'$do_make_public'(T) :- - '$is_dynamic'(T), !. % all dynamic predicates are public. -'$do_make_public'(T) :- - '$flags'(T,F,F), +'$do_make_public'(T, Mod) :- + '$is_dynamic'(T, Mod), !. % all dynamic predicates are public. +'$do_make_public'(T, Mod) :- + '$flags'(T,Mod,F,F), NF is F\/16'400000, - '$flags'(T,F,NF). + '$flags'(T,Mod,F,NF). -'$is_public'(T) :- - '$is_dynamic'(T), !. % all dynamic predicates are public. -'$is_public'(T) :- - '$flags'(T,F,F), +'$is_public'(T, Mod) :- + '$is_dynamic'(T, Mod), !. % all dynamic predicates are public. +'$is_public'(T, Mod) :- + '$flags'(T,Mod,F,F), F\/16'400000 \== 0. diff --git a/pl/tabling.yap b/pl/tabling.yap index 039fabacc..d14d7eaf8 100644 --- a/pl/tabling.yap +++ b/pl/tabling.yap @@ -15,73 +15,88 @@ * * *************************************************************************/ -table(X) :- var(X), !, +table(X) :- + current_module(M), + '$table'(X, M). + +'$table'(X, _) :- var(X), !, write(user_error, '[ Error: argument to table/1 should be a predicate ]'), nl(user_error), fail. -table((A,B)) :- !, table(A), table(B). -table(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), +'$table'(M:A, _) :- !, '$table'(A, M). +'$table'((A,B), M) :- !, '$table'(A, M), '$table'(B, M). +'$table'(A/N, M) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,M,F,F), ( X is F /\ 8'000100, X =\= 0, !, write(user_error, '[ Warning: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' is already declared as table ]'), nl(user_error) ; X is F /\ 8'170000, X =:= 0, !, '$table'(T) ; write(user_error, '[ Error: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' cannot be declared as table ]'), nl(user_error), fail ). -table(X) :- write(user_error, '[ Error: '), +'$table'(X, _) :- write(user_error, '[ Error: '), write(user_error, X), write(user_error, ' is an invalid argument to table/1 ]'), nl(user_error), fail. +show_trie(X) :- + '$current_module'(M), + '$show_trie'(X, M). -show_trie(X) :- var(X), !, +'$show_trie'(X, M) :- var(X), !, write(user_error, '[ Error: argument to trie/1 should be a predicate ]'), nl(user_error), fail. -show_trie(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), +'$show_trie'((A,B), _) :- !, '$show_trie'(A, M), '$show_trie'(B, M). +'$show_trie'(M:A, _) :- !, '$show_trie'(A, M). +'$show_trie'(A/N, M) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,M,F,F), ( - X is F /\ 8'000100, X =\= 0, !, '$show_trie'(T,_) + X is F /\ 8'000100, X =\= 0, !, '$show_trie'(T,M,_) ; write(user_error, '[ Error: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' is not declared as table ]'), nl(user_error), fail ). -show_trie(X) :- write(user_error, '[ Error: '), +'$show_trie'(X, M) :- write(user_error, '[ Error: '), write(user_error, X), write(user_error, ' is an invalid argument to trie/1 ]'), nl(user_error), fail. +abolish_trie(X) :- + '$current_module'(M), + '$abolish_trie'(X, M). -abolish_trie(X) :- var(X), !, +'$abolish_trie'(X, M) :- var(X), !, write(user_error, '[ Error: argument to abolish_trie/1 should be a predicate ]'), nl(user_error), fail. -abolish_trie(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), +'$abolish_trie'((A,B), _) :- !, '$abolish_trie'(A, M), '$abolish_trie'(B, M). +'$abolish_trie'(M:A, _) :- !, '$abolish_trie'(A, M). +'$abolish_trie'(A/N, M) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,M,F,F), ( - X is F /\ 8'000100, X =\= 0, !, '$abolish_trie'(T) + X is F /\ 8'000100, X =\= 0, !, '$do_abolish_trie'(T,M) ; write(user_error, '[ Error: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' is not declared as table ]'), nl(user_error), fail ). -abolish_trie(X) :- write(user_error, '[ Error: '), +'$abolish_trie'(X,M) :- write(user_error, '[ Error: '), write(user_error, X), write(user_error, ' is an invalid argument to abolish_trie/1 ]'), nl(user_error), diff --git a/pl/utils.yap b/pl/utils.yap index f5cbeef63..217a2a8b6 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -29,15 +29,10 @@ if(_X,_Y,Z) :- call_with_args(V) :- var(V), !, throw(error(instantiation_error,call_with_args(V))). call_with_args(M:A) :- !, - ( '$current_module'(M) -> - call_with_args(A) - ; - '$current_module'(Old,M), - ( call_with_args(A); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,M). call_with_args(A) :- atom(A), !, - '$call_with_args'(A). + '$current_module'(M), + '$call_with_args'(A,M). call_with_args(A) :- throw(error(type_error(atom,A),call_with_args(A))). @@ -45,135 +40,90 @@ call_with_args(A) :- call_with_args(V,A1) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1))). call_with_args(M:A,A1) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,M). call_with_args(A,A1) :- atom(A), !, - '$call_with_args'(A,A1). + '$current_module'(M), + '$call_with_args'(A,A1,M). call_with_args(A,A1) :- throw(error(type_error(atom,A),call_with_args(A,A1))). call_with_args(V,A1,A2) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2))). call_with_args(M:A,A1,A2) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,M). call_with_args(A,A1,A2) :- atom(A), !, - '$call_with_args'(A,A1,A2). + '$current_module'(M), + '$call_with_args'(A,A1,A2,M). call_with_args(A,A1,A2) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2))). call_with_args(V,A1,A2,A3) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3))). call_with_args(M:A,A1,A2,A3) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,M). call_with_args(A,A1,A2,A3) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,M). call_with_args(A,A1,A2,A3) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3))). call_with_args(V,A1,A2,A3,A4) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4))). call_with_args(M:A,A1,A2,A3,A4) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,M). call_with_args(A,A1,A2,A3,A4) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,M). call_with_args(A,A1,A2,A3,A4) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4))). call_with_args(V,A1,A2,A3,A4,A5) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5))). call_with_args(M:A,A1,A2,A3,A4,A5) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,A5,M). call_with_args(A,A1,A2,A3,A4,A5) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,M). call_with_args(A,A1,A2,A3,A4,A5) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5))). call_with_args(V,A1,A2,A3,A4,A5,A6) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6))). call_with_args(M:A,A1,A2,A3,A4,A5,A6) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5,A6) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5,A6); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,M). call_with_args(A,A1,A2,A3,A4,A5,A6) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5,A6). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,M). call_with_args(A,A1,A2,A3,A4,A5,A6) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6))). call_with_args(V,A1,A2,A3,A4,A5,A6,A7) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7))). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5,A6,A7) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5,A6,A7); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7))). call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8))). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8))). call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9))). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9). + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9))). @@ -181,15 +131,10 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- var(V), !, throw(error(instantiation_error,call_with_args(V,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))). call_with_args(M:A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- !, - ( '$current_module'(M) -> - call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) - ; - '$current_module'(Old,M), - ( call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10); '$current_module'(_,Old), fail ), - ( '$current_module'(_,Old); '$current_module'(_,M), fail) - ). + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- atom(A), !, - '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10). + '$current_module'(M), + '$call_with_args'(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,M). call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- throw(error(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10))). @@ -342,46 +287,56 @@ current_atom(A) :- % generate '$current_atom'(A). current_predicate(A,T) :- var(T), !, % only for the predicate - '$current_predicate_no_modules'(A,T). + '$current_module'(M), + '$current_predicate_no_modules'(M,A,T). current_predicate(A,M:T) :- % module specified var(M), !, current_module(M), M \= prolog, - '$mod_switch'(M,'$current_predicate_no_modules'(A,T)). + '$current_predicate_no_modules'(M,A,T). +current_predicate(A,M:T) :- % module specified + nonvar(T), + !, + '$pred_exists'(T,M). current_predicate(A,M:T) :- % module specified !, - '$mod_switch'(M,'$current_predicate_no_modules'(A,T)). + '$current_predicate_no_modules'(M,A,T). current_predicate(A,T) :- % only for the predicate - '$current_predicate_no_modules'(A,T). + '$current_module'(M), + '$current_predicate_no_modules'(M,A,T). current_predicate(F) :- var(F), !, % only for the predicate - '$current_predicate3'(F). + '$current_module'(M), + '$current_predicate3'(M,F). current_predicate(M:F) :- % module specified var(M), !, - current_module(M), + '$current_module'(M), M \= prolog, - '$mod_switch'(M,'$current_predicate3'(F)). + '$current_predicate3'(M,F). current_predicate(M:F) :- % module specified !, - '$mod_switch'(M,'$current_predicate3'(F)). + '$current_predicate3'(M,F). current_predicate(F) :- % only for the predicate - '$current_predicate3'(F). + '$current_module'(M), + '$current_predicate3'(M,F). system_predicate(A,P) :- - '$mod_switch'(prolog,'$current_predicate_no_modules'(A,P)), + '$current_predicate_no_modules'(prolog,A,P), \+ '$hidden'(A). system_predicate(P) :- '$system_predicate'(P). -'$current_predicate_no_modules'(A,T) :- - '$current_predicate'(A,Arity), +'$current_predicate_no_modules'(M,A,T) :- + '$current_predicate'(M,A,Arity), + \+ '$hidden'(A), functor(T,A,Arity), - '$pred_exists'(T). + '$pred_exists'(T,M). -'$current_predicate3'(A/Arity) :- - '$current_predicate'(A,Arity), +'$current_predicate3'(M,A/Arity) :- + '$current_predicate'(M,A,Arity), + \+ '$hidden'(A), functor(T,A,Arity), - '$pred_exists'(T). + '$pred_exists'(T,M). %%% User interface for statistics @@ -472,44 +427,43 @@ statistics(stack_shifts,[NOfHO,NOfSO,NOfTO]) :- % informs about what the user wants to be done when % there are no clauses for a certain predicate */ +unknown(V0,V) :- + '$current_module'(M), + '$unknown'(V0,V,M). % query mode -unknown(V0,V) :- var(V), !, +'$unknown'(V0,V,_) :- var(V), !, '$ask_unknown_flag'(V), V = V0. % handle modules. -unknown(V0,Mod:Handler) :- - ( '$current_module'(Mod) -> - unknown(V0,Handler) - ; - '$mod_switch'(Mod,unknown(V0,Handler)) - ). +'$unknown'(V0,Mod:Handler,_) :- + '$unknown'(V0,Handler,Mod). % check if we have one we like. -unknown(_,New) :- - '$valid_unknown_handler'(New), fail. +'$unknown'(_,New,Mod) :- + '$valid_unknown_handler'(New,Mod), fail. % clean up previous unknown predicate handlers -unknown(Old,New) :- +'$unknown'(Old,New,Mod) :- '$recorded'('$unknown','$unknown'(_,MyOld),Ref), !, erase(Ref), '$cleanup_unknown_handler'(MyOld,Old), - '$new_unknown'(New). + '$new_unknown'(New, Mod). % store the new one. -unknown(fail,New) :- - '$new_unknown'(New). +'$unknown'(fail,New,Mod) :- + '$new_unknown'(New, Mod). -'$valid_unknown_handler'(V) :- +'$valid_unknown_handler'(V,_) :- var(V), !, throw(error(instantiation_error,yap_flag(unknown,V))). -'$valid_unknown_handler'(fail) :- !. -'$valid_unknown_handler'(error) :- !. -'$valid_unknown_handler'(warning) :- !. -'$valid_unknown_handler'(S) :- +'$valid_unknown_handler'(fail,_) :- !. +'$valid_unknown_handler'(error,_) :- !. +'$valid_unknown_handler'(warning,_) :- !. +'$valid_unknown_handler'(S,M) :- functor(S,_,1), arg(1,S,A), var(A), - \+ '$undefined'(S), + \+ '$undefined'(S,M), !. -'$valid_unknown_handler'(S) :- +'$valid_unknown_handler'(S,_) :- throw(error(domain_error(flag_value,unknown+S),yap_flag(unknown,S))). '$ask_unknown_flag'(Old) :- @@ -521,14 +475,13 @@ unknown(fail,New) :- '$cleanup_unknown_handler'('$unknown_warning'(_),warning) :- !. '$cleanup_unknown_handler'(Handler, Handler). -'$new_unknown'(fail) :- !. -'$new_unknown'(error) :- !, +'$new_unknown'(fail,_) :- !. +'$new_unknown'(error,_) :- !, '$recorda'('$unknown','$unknown'(P,'$unknown_error'(P)),_). -'$new_unknown'(warning) :- !, +'$new_unknown'(warning,_) :- !, '$recorda'('$unknown','$unknown'(P,'$unknown_warning'(P)),_). -'$new_unknown'(X) :- +'$new_unknown'(X,M) :- arg(1,X,A), - '$current_module'(M), '$recorda'('$unknown','$unknown'(A,M:X),_). '$unknown_error'(P) :- @@ -542,44 +495,40 @@ unknown(fail,New) :- fail. predicate_property(Mod:Pred,Prop) :- !, - ( '$current_module'(Mod) -> - '$predicate_property2'(Pred,Prop) - ; - '$mod_switch'(Mod,'$predicate_property2'(Pred,Prop)) - ). + '$predicate_property2'(Pred,Prop,Mod). predicate_property(Pred,Prop) :- - '$predicate_property2'(Pred,Prop). + '$current_module'(Mod), + '$predicate_property2'(Pred,Prop,Mod). -'$predicate_property2'(Pred,Prop) :- var(Pred), !, - '$current_predicate'(_,Pred), - '$pred_exists'(Pred), - '$predicate_property'(Pred,Prop). -'$predicate_property2'(Pred,Prop) :- - '$predicate_property'(Pred,Prop), - '$pred_exists'(Pred). +'$predicate_property2'(Pred,Prop,M) :- var(Pred), !, + '$current_predicate'(M,_,Pred), + '$pred_exists'(Pred,M), + '$predicate_property'(Pred,M,Prop). +'$predicate_property2'(M:Pred,Prop,_) :- + '$predicate_property'(Pred,Prop,M). +'$predicate_property2'(Pred,Prop,Mod) :- + '$predicate_property'(Pred,Mod,Prop), + '$pred_exists'(Pred,Mod). -'$predicate_property'(P,built_in) :- +'$predicate_property'(P,M,built_in) :- '$system_predicate'(P), !. -'$predicate_property'(P,dynamic) :- - '$is_dynamic'(P). -'$predicate_property'(P,static) :- - \+ '$is_dynamic'(P). -'$predicate_property'(P,meta_predicate(P)) :- - '$current_module'(M), +'$predicate_property'(P,M,dynamic) :- + '$is_dynamic'(P,M). +'$predicate_property'(P,M,static) :- + \+ '$is_dynamic'(P,M). +'$predicate_property'(P,M,meta_predicate(P)) :- functor(P,Na,Ar), - recorded('$meta_predicate','$meta_predicate'(M,Na,Ar,P),_). -'$predicate_property'(P,multifile) :- - functor(P,N,A), - '$is_multifile'(N,A). -'$predicate_property'(P,imported_from(Mod)) :- + user:'$meta_predicate'(M,Na,Ar,P). +'$predicate_property'(P,M,multifile) :- + '$is_multifile'(P,M). +'$predicate_property'(P,_,imported_from(Mod)) :- functor(P,N,A), '$recorded'('$module','$module'(_TFN,Mod,Publics),_), '$member'(N/A,Publics). /* defined in modules.yap */ -'$predicate_property'(P,public) :- - '$is_public'(P). -'$predicate_property'(P,exported) :- +'$predicate_property'(P,M,public) :- + '$is_public'(P,M). +'$predicate_property'(P,M,exported) :- functor(P,N,A), - '$current_module'(M), '$recorded'('$module','$module'(_TFN,M,Publics),_), '$member'(N/A,Publics). /* defined in modules.yap */ @@ -589,8 +538,8 @@ predicate_property(Pred,Prop) :- % this predicate shows the code produced by the compiler '$show_code' :- '$debug'(0'f). -'$pred_exists'(Pred) :- '$is_dynamic'(Pred), !. -'$pred_exists'(Pred) :- \+ '$undefined'(Pred). +'$pred_exists'(Pred,M) :- '$is_dynamic'(Pred,M), !. +'$pred_exists'(Pred,M) :- \+ '$undefined'(Pred,M). grow_heap(X) :- '$grow_heap'(X). @@ -611,22 +560,27 @@ nogc :- '$force_environment_for_gc'. profile_data(P, Parm, Data) :- var(P), !, - '$profile_data_for_var'(P, Parm, Data). -profile_data(M:P, Parm, Data) :- var(M), !, - throw(error(instantiation_error,profile_data(M:P, Parm, Data))). -profile_data(M:P, Parm, Data) :- var(M), !, - '$mod_switch'(M,'$profile_data'(P, Parm, Data)). -profile_data(P, Parm, Data) :- - '$profile_data'(P, Parm, Data). + '$current_module'(M), + '$profile_data'(P, Parm, Data, M). -'$profile_data'(Na/Ar,Parm,Data) :- - '$profile_info'(Na, Ar, Stats), +'$profile_data'(P, Parm, Data,M) :- var(P), !, + '$profile_data_for_var'(P, Parm, Data,M). +'$profile_data'(M:P, Parm, Data, _) :- var(M), !, + throw(error(instantiation_error,profile_data(M:P, Parm, Data))). +'$profile_data'(M:P, Parm, Data, _) :- + '$profile_data'(P, Parm, Data, M). +'$profile_data'(P, Parm, Data, M) :- + '$profile_data2'(P, Parm, Data, M). + +'$profile_data2'(Na/Ar,Parm,Data, M) :- + functor(P, Na, Ar), + '$profile_info'(M, P, Stats), '$profile_say'(Stats, Parm, Data). -'$profile_data_for_var'(Name/Arity, Parm, Data) :- - '$current_predicate'(_,P), +'$profile_data_for_var'(Name/Arity, Parm, Data, M) :- + '$current_predicate'(M,_,P), functor(P, Name, Arity), - '$profile_info'(Name, Arity, Stats), + '$profile_info'(M, P, Stats), '$profile_say'(Stats, Parm, Data). @@ -635,9 +589,9 @@ profile_data(P, Parm, Data) :- '$profile_say'('$profile'(_, _, Backtracks), retries, Backtracks). profile_reset :- - current_predicate(_,P0), - functor(P0, Name, Arity), - '$profile_reset'(Name, Arity), + current_module(M), + '$current_predicate'(M,_,P0), + '$profile_reset'(M, P0), fail. profile_reset. @@ -798,8 +752,10 @@ user_defined_directive(Dir,_) :- user_defined_directive(Dir,Action) :- functor(Dir,Na,Ar), functor(NDir,Na,Ar), + '$current_module'(M, prolog), assert_static('$directive'(NDir)), - assert_static(('$exec_directive'(Dir, _) :- Action)). + assert_static(('$exec_directive'(Dir, _, _) :- Action)), + '$current_module'(_, M). '$set_toplevel_hook'(_) :- '$recorded'('$toplevel_hooks',_,R), diff --git a/pl/yapor.yap b/pl/yapor.yap index 8a62c00ac..91be974b7 100644 --- a/pl/yapor.yap +++ b/pl/yapor.yap @@ -37,58 +37,65 @@ default_sequential(_). '$initialization'('$default_sequential'(X)), '$default_sequential'(off). -'$sequential_directive'(X) :- var(X), !, +'$sequential_directive'(X,_) :- var(X), !, write(user_error, '[ Error: argument to sequential/1 should be a predicate ]'), nl(user_error), fail. -'$sequential_directive'((A,B)) :- !, sequential(A), sequential(B). -'$sequential_directive'(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), +'$sequential_directive'((A,B),M) :- !, + '$sequential_directive'(A,M), '$sequential_directive'(B,M). +'$sequential_directive'(M:A,_) :- !, + '$sequential_directive'(A,M). +'$sequential_directive'(A/N,M) :- integer(N), atom(A), !, + functor(T,A,N), + '$flags'(T,M,F,F), ( X is F /\ 8'000040, X =\= 0, !, write(user_error, '[ Warning: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' is already declared as sequential ]'), nl(user_error) ; - X is F /\ 8'170000, X =:= 0, !, '$sequential'(T) + X is F /\ 8'170000, X =:= 0, !, '$sequential'(T,M) ; write(user_error, '[ Error: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' cannot be declared as sequential ]'), nl(user_error), fail ). -'$sequential_directive'(X) :- write(user_error, '[ Error: '), +'$sequential_directive'(X,_) :- write(user_error, '[ Error: '), write(user_error, X), write(user_error, ' is an invalid argument to sequential/1 ]'), nl(user_error), fail. -parallel(X) :- var(X), !, +'$parallel_directive'(X,M) :- var(X), !, write(user_error, '[ Error: argument to parallel/1 should be a predicate ]'), nl(user_error), fail. -parallel((A,B)) :- !, parallel(A), parallel(B). - -parallel(A/N) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,F,F), +'$parallel_directive'((A,B),M) :- !, + '$parallel_directive'(A,M), + 'parallel_directive'(B,M). +'$parallel_directive'(M:A,_) :- !, + '$parallel_directive'(A,M). +'$parallel_directive'(A/N,M) :- integer(N), atom(A), !, + functor(T,A,N), '$flags'(T,M,F,F), ( NF is F /\ \(8'000040), '$flags'(T,F,NF) ; write(user_error, '[ Warning: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' is already declared as sequential ]'), nl(user_error) ; X is F /\ 8'170000, X =:= 0, !, '$sequential'(T) ; write(user_error, '[ Error: '), - write(user_error, A/N), + write(user_error, M:A/N), write(user_error, ' cannot be declared as parallel ]'), nl(user_error), fail ). -sequential(X) :- write(user_error, '[ Error: '), +'$parallel_directive'(X,_) :- write(user_error, '[ Error: '), write(user_error, X), write(user_error, ' is an invalid argument to parallel/1 ]'), nl(user_error), diff --git a/pl/yio.yap b/pl/yio.yap index 18a459cdf..125e7c109 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -500,8 +500,8 @@ format(Stream, S, A) :- '$format'(Stream, S, A). /* interface to user portray */ '$portray'(T) :- - \+ '$undefined'(portray(_)), - portray(T), !, + \+ '$undefined'(portray(_),user), + user:portray(T), !, '$set_value'('$portray',true), fail. '$portray'(_) :- '$set_value'('$portray',false), fail.