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

fix current and system predicate

Browse Source
This commit is contained in:
Vítor Santos Costa 2014-11-25 12:03:48 +00:00
parent cfafc26b68
commit bb8ea9a27d
27 changed files with 1335 additions and 1254 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
C/absmi.c
View File

@ -951,7 +951,7 @@ interrupt_execute( USES_REGS1 )
} }
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0; PP = P->y_u.pp.p0;
if ((PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) { if ((PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2; return 2;
} }
SET_ASP(YENV, E_CB*sizeof(CELL)); SET_ASP(YENV, E_CB*sizeof(CELL));
@ -979,7 +979,7 @@ interrupt_call( USES_REGS1 )
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.Osbpp.p0; PP = P->y_u.Osbpp.p0;
if (Yap_only_has_signal(YAP_CREEP_SIGNAL) && if (Yap_only_has_signal(YAP_CREEP_SIGNAL) &&
(PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) ) { (PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) ) {
return 2; return 2;
} }
SET_ASP(YENV, P->y_u.Osbpp.s); SET_ASP(YENV, P->y_u.Osbpp.s);
@ -1238,7 +1238,7 @@ interrupt_dexecute( USES_REGS1 )
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0; PP = P->y_u.pp.p0;
pe = P->y_u.pp.p; pe = P->y_u.pp.p;
if ((PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) { if ((PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2; return 2;
} }
/* set S for next instructions */ /* set S for next instructions */
@ -7826,8 +7826,7 @@ Yap_absmi(int inp)
BOp(call_cpred, Osbpp); BOp(call_cpred, Osbpp);
check_trail(TR); check_trail(TR);
if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag)) && if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag|NoTracePredFlag|HiddenPredFlag))) {
!(PREG->y_u.Osbpp.p0->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag))) {
CACHE_Y_AS_ENV(YREG); CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCCall, HR); check_stack(NoStackCCall, HR);
ENDCACHE_Y_AS_ENV(); ENDCACHE_Y_AS_ENV();

6
C/adtdefs.c
View File

@ -848,7 +848,7 @@ Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
} }
} }
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= NoTracePredFlag; p->PredFlags |= NoTracePredFlag;
} }
p->FunctorOfPred = fe; p->FunctorOfPred = fe;
if (fe->PropsOfFE) { if (fe->PropsOfFE) {
@ -937,7 +937,7 @@ Yap_NewThreadPred(PredEntry *ap USES_REGS)
p->FunctorOfPred = ap->FunctorOfPred; p->FunctorOfPred = ap->FunctorOfPred;
Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred)+1, p, GPROF_NEW_PRED_THREAD); Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred)+1, p, GPROF_NEW_PRED_THREAD);
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= (NoSpyPredFlag|NoTracePredFlag); p->PredFlags |= (NoSpyPredFlag|NoTracePredFlag);
} }
if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) { if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) {
Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode), &(p->cs.p_code.ExpandCode)+1, p, GPROF_NEW_PRED_THREAD); Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode), &(p->cs.p_code.ExpandCode)+1, p, GPROF_NEW_PRED_THREAD);
@ -1008,7 +1008,7 @@ Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
p0 = AbsPredProp(p); p0 = AbsPredProp(p);
p->FunctorOfPred = (Functor)AbsAtom(ae); p->FunctorOfPred = (Functor)AbsAtom(ae);
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= (NoTracePredFlag|NoSpyPredFlag); p->PredFlags |= (NoTracePredFlag|NoSpyPredFlag);
} }
WRITE_UNLOCK(ae->ARWLock); WRITE_UNLOCK(ae->ARWLock);
{ {

2
C/c_interface.c
View File

@ -3096,7 +3096,7 @@ YAP_Init(YAP_init_args *yap_init)
/* slaves, waiting for work */ /* slaves, waiting for work */
CurrentModule = USER_MODULE; CurrentModule = USER_MODULE;
P = GETWORK_FIRST_TIME; P = GETWORK_FIRST_TIME;
Yap_exec_absmi(FALSE); Yap_exec_absmi(FALSE, YAP_EXEC_ABSMI);
Yap_Error(INTERNAL_ERROR, TermNil, "abstract machine unexpected exit (YAP_Init)"); Yap_Error(INTERNAL_ERROR, TermNil, "abstract machine unexpected exit (YAP_Init)");
} }
#endif /* YAPOR */ #endif /* YAPOR */

16
C/cdmgr.c
View File

@ -2136,7 +2136,7 @@ Yap_discontiguous( PredEntry *ap USES_REGS )
{ {
register consult_obj *fp; register consult_obj *fp;
if (ap->ExtraPredFlags & (DiscontiguousPredFlag|MultiFileFlag)) if (ap->PredFlags & (DiscontiguousPredFlag|MultiFileFlag))
return FALSE; return FALSE;
if (!LOCAL_ConsultSp) { if (!LOCAL_ConsultSp) {
return FALSE; return FALSE;
@ -2339,7 +2339,7 @@ addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref)
PELOCK(20,p); PELOCK(20,p);
pflags = p->PredFlags; pflags = p->PredFlags;
/* we are redefining a prolog module predicate */ /* we are redefining a prolog module predicate */
if (((p->ExtraPredFlags & SysExportPredFlag) == (UInt)0) && if (((p->PredFlags & SysExportPredFlag) == (UInt)0) &&
( (
(pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) || (pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) ||
(p->ModuleOfPred == PROLOG_MODULE && (p->ModuleOfPred == PROLOG_MODULE &&
@ -2847,7 +2847,7 @@ p_sys_export( USES_REGS1 )
return (FALSE); return (FALSE);
} }
PELOCK(100,pred); PELOCK(100,pred);
pred->ExtraPredFlags |= SysExportPredFlag; pred->PredFlags |= SysExportPredFlag;
UNLOCKPE(100,pred); UNLOCKPE(100,pred);
return TRUE; return TRUE;
} }
@ -2868,7 +2868,7 @@ p_is_no_trace( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return TRUE; return TRUE;
PELOCK(36,pe); PELOCK(36,pe);
if (pe->ExtraPredFlags & NoTracePredFlag) { if (pe->PredFlags & NoTracePredFlag) {
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -2886,7 +2886,7 @@ p_set_no_trace( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(36,pe); PELOCK(36,pe);
pe->ExtraPredFlags |= NoTracePredFlag; pe->PredFlags |= NoTracePredFlag;
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -2904,7 +2904,7 @@ Yap_SetNoTrace(char *name, UInt arity, Term tmod)
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(36,pe); PELOCK(36,pe);
pe->ExtraPredFlags |= NoTracePredFlag; pe->PredFlags |= NoTracePredFlag;
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -3164,7 +3164,7 @@ p_new_discontiguous( USES_REGS1 )
else else
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod)); pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod));
PELOCK(26,pe); PELOCK(26,pe);
pe->ExtraPredFlags |= DiscontiguousPredFlag; pe->PredFlags |= DiscontiguousPredFlag;
/* mutifile-predicates are weird, they do not seat really on the default module */ /* mutifile-predicates are weird, they do not seat really on the default module */
if (pe->ModuleOfPred == PROLOG_MODULE) if (pe->ModuleOfPred == PROLOG_MODULE)
pe->ModuleOfPred = TermProlog; pe->ModuleOfPred = TermProlog;
@ -3183,7 +3183,7 @@ p_is_discontiguous( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(27,pe); PELOCK(27,pe);
out = (pe->ExtraPredFlags & DiscontiguousPredFlag); out = (pe->PredFlags & DiscontiguousPredFlag);
UNLOCKPE(44,pe); UNLOCKPE(44,pe);
return(out); return(out);
} }

4
C/exec.c
View File

@ -1991,8 +1991,8 @@ Yap_InitExecFs(void)
#ifdef DEPTH_LIMIT #ifdef DEPTH_LIMIT
Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0); Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0);
#endif #endif
Yap_InitCPred("$execute0", 2, p_execute0, 0); Yap_InitCPred("$execute0", 2, p_execute0, NoTracePredFlag);
Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop, 0); Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop,NoTracePredFlag );
Yap_InitCPred("$execute_clause", 4, p_execute_clause, 0); Yap_InitCPred("$execute_clause", 4, p_execute_clause, 0);
Yap_InitCPred("$current_choice_point", 1, p_save_cp, 0); Yap_InitCPred("$current_choice_point", 1, p_save_cp, 0);
Yap_InitCPred("$current_choicepoint", 1, p_save_cp, 0); Yap_InitCPred("$current_choicepoint", 1, p_save_cp, 0);

260
C/modules.c
View File

@ -15,7 +15,7 @@
* * * *
*************************************************************************/ *************************************************************************/
#ifdef SCCS #ifdef SCCS
static char SccsId[] = "%W% %G%"; static char SccsId[] = "%W% %G%";
#endif #endif
#include "Yap.h" #include "Yap.h"
@ -23,12 +23,12 @@ static char SccsId[] = "%W% %G%";
#include "YapHeap.h" #include "YapHeap.h"
#include "pl-shared.h" #include "pl-shared.h"
static Int p_current_module( USES_REGS1 ); static Int p_current_module(USES_REGS1);
static Int p_current_module1( USES_REGS1 ); static Int p_current_module1(USES_REGS1);
static ModEntry *LookupModule(Term a); static ModEntry *LookupModule(Term a);
static Term Yap_YapStripModule(Term t, Term *modp);
inline static ModEntry * inline static ModEntry *FetchModuleEntry(Atom at)
FetchModuleEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;
@ -38,8 +38,7 @@ FetchModuleEntry(Atom at)
p0 = ae->PropsOfAE; p0 = ae->PropsOfAE;
while (p0) { while (p0) {
ModEntry *me = RepModProp(p0); ModEntry *me = RepModProp(p0);
if ( me->KindOfPE == ModProperty if (me->KindOfPE == ModProperty) {
) {
READ_UNLOCK(ae->ARWLock); READ_UNLOCK(ae->ARWLock);
return me; return me;
} }
@ -49,27 +48,24 @@ FetchModuleEntry(Atom at)
return NULL; return NULL;
} }
inline static ModEntry * inline static ModEntry *GetModuleEntry(Atom at)
GetModuleEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;
AtomEntry *ae = RepAtom(at); AtomEntry *ae = RepAtom(at);
ModEntry *new; ModEntry *new;
p0 = ae->PropsOfAE; p0 = ae->PropsOfAE;
while (p0) { while (p0) {
ModEntry *me = RepModProp(p0); ModEntry *me = RepModProp(p0);
if ( me->KindOfPE == ModProperty if (me->KindOfPE == ModProperty) {
) {
return me; return me;
} }
p0 = me->NextOfPE; p0 = me->NextOfPE;
} }
{ {
CACHE_REGS CACHE_REGS
new = (ModEntry *) Yap_AllocAtomSpace(sizeof(*new)); new = (ModEntry *)Yap_AllocAtomSpace(sizeof(*new));
INIT_RWLOCK(new->ModRWLock); INIT_RWLOCK(new->ModRWLock);
new->KindOfPE = ModProperty; new->KindOfPE = ModProperty;
new->PredForME = NULL; new->PredForME = NULL;
@ -77,7 +73,7 @@ GetModuleEntry(Atom at)
CurrentModules = new; CurrentModules = new;
new->AtomOfME = ae; new->AtomOfME = ae;
if (at == AtomProlog) if (at == AtomProlog)
new->flags = UNKNOWN_FAIL|M_SYSTEM|M_CHARESCAPE; new->flags = UNKNOWN_FAIL | M_SYSTEM | M_CHARESCAPE;
else else
new->flags = LookupModule(LOCAL_SourceModule)->flags; new->flags = LookupModule(LOCAL_SourceModule)->flags;
AddPropToAtom(ae, (PropEntry *)new); AddPropToAtom(ae, (PropEntry *)new);
@ -85,20 +81,16 @@ GetModuleEntry(Atom at)
return new; return new;
} }
unsigned int unsigned int getUnknownModule(ModEntry *m) {
getUnknownModule(ModEntry * m) { if (m && m->flags & UNKNOWN_MASK)
if (m && m->flags & UNKNOWN_MASK) return m->flags & UNKNOWN_MASK;
return m->flags & UNKNOWN_MASK; else {
else { return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK;
return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK; }
}
} }
#define ByteAdr(X) ((char *) &(X)) #define ByteAdr(X) ((char *)&(X))
Term Term Yap_Module_Name(PredEntry *ap) {
Yap_Module_Name(PredEntry *ap)
{
CACHE_REGS CACHE_REGS
Term mod; Term mod;
if (!ap->ModuleOfPred) if (!ap->ModuleOfPred)
@ -109,63 +101,53 @@ Yap_Module_Name(PredEntry *ap)
So I will return the current module in case the system So I will return the current module in case the system
predicate is a meta-call. Otherwise it will still work. predicate is a meta-call. Otherwise it will still work.
*/ */
mod = CurrentModule; mod = CurrentModule;
else { else {
mod = ap->ModuleOfPred; mod = ap->ModuleOfPred;
} }
if (mod) return mod; if (mod)
return mod;
return TermProlog; return TermProlog;
} }
static ModEntry * static ModEntry *LookupModule(Term a) {
LookupModule(Term a )
{
Atom at; Atom at;
ModEntry *me; ModEntry *me;
/* prolog module */ /* prolog module */
if (a == 0) { if (a == 0) {
return GetModuleEntry(AtomUser); return GetModuleEntry(AtomProlog);
} }
at = AtomOfTerm(a); at = AtomOfTerm(a);
me = GetModuleEntry(at); me = GetModuleEntry(at);
return me; return me;
} }
Term Term Yap_Module(Term tmod) {
Yap_Module(Term tmod)
{
LookupModule(tmod); LookupModule(tmod);
return tmod; return tmod;
} }
ModEntry * ModEntry *Yap_GetModuleEntry(Term mod) {
Yap_GetModuleEntry(Term mod)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
return NULL; return NULL;
return me; return me;
} }
Term Term Yap_GetModuleFromEntry(ModEntry *me) {
Yap_GetModuleFromEntry(ModEntry *me) return MkAtomTerm(me->AtomOfME);
{ ;
return MkAtomTerm(me->AtomOfME);;
} }
struct pred_entry * struct pred_entry *Yap_ModulePred(Term mod) {
Yap_ModulePred(Term mod)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
return NULL; return NULL;
return me->PredForME; return me->PredForME;
} }
void void Yap_NewModulePred(Term mod, struct pred_entry *ap) {
Yap_NewModulePred(Term mod, struct pred_entry *ap)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
@ -177,12 +159,11 @@ Yap_NewModulePred(Term mod, struct pred_entry *ap)
} }
static Int static Int
p_current_module( USES_REGS1 ) p_current_module(USES_REGS1) { /* $current_module(Old,New) */
{ /* $current_module(Old,New) */ Term t;
Term t;
if (CurrentModule) { if (CurrentModule) {
if(!Yap_unify_constant(ARG1, CurrentModule)) if (!Yap_unify_constant(ARG1, CurrentModule))
return FALSE; return FALSE;
} else { } else {
if (!Yap_unify_constant(ARG1, TermProlog)) if (!Yap_unify_constant(ARG1, TermProlog))
@ -201,17 +182,14 @@ p_current_module( USES_REGS1 )
return TRUE; return TRUE;
} }
static Int static Int p_current_module1(USES_REGS1) { /* $current_module(Old)
p_current_module1( USES_REGS1 ) */
{ /* $current_module(Old) */
if (CurrentModule) if (CurrentModule)
return Yap_unify_constant(ARG1, CurrentModule); return Yap_unify_constant(ARG1, CurrentModule);
return Yap_unify_constant(ARG1, TermProlog); return Yap_unify_constant(ARG1, TermProlog);
} }
static Int static Int p_change_module(USES_REGS1) { /* $change_module(New) */
p_change_module( USES_REGS1 )
{ /* $change_module(New) */
Term mod = Deref(ARG1); Term mod = Deref(ARG1);
LookupModule(mod); LookupModule(mod);
CurrentModule = mod; CurrentModule = mod;
@ -219,57 +197,94 @@ p_change_module( USES_REGS1 )
return TRUE; return TRUE;
} }
static Int static Int cont_current_module(USES_REGS1) {
cont_current_module( USES_REGS1 ) ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(1, 1)), *next;
{
ModEntry *imod = (ModEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(1,1)), *next;
Term t = MkAtomTerm(imod->AtomOfME); Term t = MkAtomTerm(imod->AtomOfME);
next = imod->NextME; next = imod->NextME;
/* ARG1 is unbound */ /* ARG1 is unbound */
Yap_unify(ARG1,t); Yap_unify(ARG1, t);
if (!next) if (!next)
cut_succeed(); cut_succeed();
EXTRA_CBACK_ARG(1,1) = MkIntegerTerm((Int)next); EXTRA_CBACK_ARG(1, 1) = MkAddressTerm(next);
return TRUE; return TRUE;
} }
static Int static Int init_current_module(
init_current_module( USES_REGS1 ) USES_REGS1) { /* current_module(?ModuleName) */
{ /* current_module(?ModuleName) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
if (!IsVarTerm(t)) { if (!IsVarTerm(t)) {
if (!IsAtomTerm(t)) { if (!IsAtomTerm(t)) {
Yap_Error(TYPE_ERROR_ATOM,t,"module name must be an atom"); Yap_Error(TYPE_ERROR_ATOM, t, "module name must be an atom");
return FALSE; return FALSE;
} }
if (FetchModuleEntry(AtomOfTerm(t)) != NULL) if (FetchModuleEntry(AtomOfTerm(t)) != NULL)
cut_succeed(); cut_succeed();
cut_fail(); cut_fail();
} }
EXTRA_CBACK_ARG(1,1) = MkIntegerTerm((Int)CurrentModules); EXTRA_CBACK_ARG(1, 1) = MkIntegerTerm((Int)CurrentModules);
return cont_current_module( PASS_REGS1 ); return cont_current_module(PASS_REGS1);
} }
static Int static Int cont_ground_module(USES_REGS1) {
p_strip_module( USES_REGS1 ) ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(3, 1)), *next;
{ Term t2 = MkAtomTerm(imod->AtomOfME);
next = imod->NextME;
/* ARG2 is unbound */
if (!next)
cut_succeed();
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(next);
return Yap_unify(ARG2, t2);
}
static Int init_ground_module(USES_REGS1) {
/* current_module(?ModuleName) */
Term t1 = Deref(ARG1), tmod = CurrentModule, t3;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
t3 = Yap_YapStripModule(t1, &tmod);
if (!t3) {
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE;
}
if (!IsVarTerm(tmod)) {
if (!IsAtomTerm(tmod)) {
Yap_Error(TYPE_ERROR_ATOM, tmod, "module name must be an atom");
cut_fail();
}
if (FetchModuleEntry(AtomOfTerm(tmod)) != NULL && Yap_unify(tmod, ARG2) &&
Yap_unify(t3, ARG3)) {
cut_succeed();
}
cut_fail();
}
if (!Yap_unify(ARG2, tmod) ||
!Yap_unify(ARG3, t3) ) {
cut_fail();
}
// make sure we keep the binding
B->cp_tr = TR;
B->cp_h = HR;
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(CurrentModules);
return cont_ground_module(PASS_REGS1);
}
static Int p_strip_module(USES_REGS1) {
Term t1 = Deref(ARG1), tmod = CurrentModule; Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) { if (tmod == PROLOG_MODULE) {
tmod = TermProlog; tmod = TermProlog;
} }
t1 = Yap_StripModule( t1, &tmod ); t1 = Yap_StripModule(t1, &tmod);
if (!t1) { if (!t1) {
Yap_Error(TYPE_ERROR_CALLABLE,t1,"trying to obtain module"); Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE; return FALSE;
} }
return Yap_unify(ARG3, t1) && return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
Yap_unify(ARG2, tmod);
} }
static Term static Term Yap_YapStripModule(Term t, Term *modp) {
Yap_YapStripModule(Term t, Term *modp)
{
CACHE_REGS CACHE_REGS
Term tmod; Term tmod;
@ -281,18 +296,18 @@ Yap_YapStripModule(Term t, Term *modp)
tmod = TermProlog; tmod = TermProlog;
} }
} }
restart: restart:
if (IsVarTerm(t) || !IsApplTerm(t)) { if (IsVarTerm(t) || !IsApplTerm(t)) {
if (modp) if (modp)
*modp = tmod; *modp = tmod;
return t; return t;
} else { } else {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
if (fun == FunctorModule) { if (fun == FunctorModule) {
Term t1 = ArgOfTerm(1, t); Term t1 = ArgOfTerm(1, t);
tmod = t1; tmod = t1;
if (!IsVarTerm(tmod) && !IsAtomTerm(tmod) ) { if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) {
return 0L; return 0L;
} }
t = ArgOfTerm(2, t); t = ArgOfTerm(2, t);
goto restart; goto restart;
@ -304,50 +319,38 @@ Yap_YapStripModule(Term t, Term *modp)
return 0L; return 0L;
} }
static Int p_yap_strip_module(USES_REGS1) {
static Int
p_yap_strip_module( USES_REGS1 )
{
Term t1 = Deref(ARG1), tmod = CurrentModule; Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) { if (tmod == PROLOG_MODULE) {
tmod = TermProlog; tmod = TermProlog;
} }
t1 = Yap_YapStripModule( t1, &tmod ); t1 = Yap_YapStripModule(t1, &tmod);
if (!t1) { if (!t1) {
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module"); Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE; return FALSE;
} }
return Yap_unify(ARG3, t1) && return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
Yap_unify(ARG2, tmod);
} }
static Int static Int p_context_module(USES_REGS1) {
p_context_module( USES_REGS1 )
{
yamop *parentcp = P; yamop *parentcp = P;
CELL *yenv; CELL *yenv;
PredEntry *ap = EnvPreg(parentcp); PredEntry *ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred); return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = CP; parentcp = CP;
yenv = ENV; yenv = ENV;
do { do {
ap = EnvPreg(parentcp); ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred); return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = (yamop *)yenv[E_CP]; parentcp = (yamop *)yenv[E_CP];
yenv = (CELL *)yenv[E_E]; yenv = (CELL *)yenv[E_E];
} while(yenv); } while (yenv);
return Yap_unify(ARG1, CurrentModule); return Yap_unify(ARG1, CurrentModule);
} }
Term Term Yap_StripModule(Term t, Term *modp) {
Yap_StripModule(Term t, Term *modp)
{
CACHE_REGS CACHE_REGS
Term tmod; Term tmod;
@ -359,22 +362,22 @@ Yap_StripModule(Term t, Term *modp)
tmod = TermProlog; tmod = TermProlog;
} }
} }
restart: restart:
if (IsVarTerm(t) || !IsApplTerm(t)) { if (IsVarTerm(t) || !IsApplTerm(t)) {
if (modp) if (modp)
*modp = tmod; *modp = tmod;
return t; return t;
} else { } else {
Functor fun = FunctorOfTerm(t); Functor fun = FunctorOfTerm(t);
if (fun == FunctorModule) { if (fun == FunctorModule) {
Term t1 = ArgOfTerm(1, t); Term t1 = ArgOfTerm(1, t);
if (IsVarTerm( t1 ) ) { if (IsVarTerm(t1)) {
*modp = tmod; *modp = tmod;
return t; return t;
} }
tmod = t1; tmod = t1;
if (!IsVarTerm(tmod) && !IsAtomTerm(tmod) ) { if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) {
return 0L; return 0L;
} }
t = ArgOfTerm(2, t); t = ArgOfTerm(2, t);
goto restart; goto restart;
@ -386,28 +389,29 @@ Yap_StripModule(Term t, Term *modp)
return 0L; return 0L;
} }
void Yap_InitModulesC(void) {
Yap_InitCPred("$current_module", 2, p_current_module,
void SafePredFlag | SyncPredFlag);
Yap_InitModulesC(void) Yap_InitCPred("$current_module", 1, p_current_module1,
{ SafePredFlag | SyncPredFlag);
Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag); Yap_InitCPred("$change_module", 1, p_change_module,
Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag); SafePredFlag | SyncPredFlag);
Yap_InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag); Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag | SyncPredFlag);
Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag|SyncPredFlag); Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module,
Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module, SafePredFlag|SyncPredFlag); SafePredFlag | SyncPredFlag);
Yap_InitCPred("context_module", 1, p_context_module, 0); Yap_InitCPred("context_module", 1, p_context_module, 0);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, cont_current_module, Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module,
SafePredFlag|SyncPredFlag); cont_current_module, SafePredFlag | SyncPredFlag);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module,
cont_current_module, SafePredFlag | SyncPredFlag);
Yap_InitCPredBack("$ground_module", 3, 1, init_ground_module,
cont_ground_module, SafePredFlag | SyncPredFlag);
} }
void Yap_InitModules(void) {
void
Yap_InitModules(void)
{
CACHE_REGS CACHE_REGS
LookupModule(MkAtomTerm(AtomProlog)); LookupModule(MkAtomTerm(AtomProlog));
LOCAL_SourceModule = MkAtomTerm(AtomProlog); LOCAL_SourceModule = MkAtomTerm(AtomProlog);
LookupModule(USER_MODULE); LookupModule(USER_MODULE);
LookupModule(IDB_MODULE); LookupModule(IDB_MODULE);
LookupModule(ATTRIBUTES_MODULE); LookupModule(ATTRIBUTES_MODULE);

1646
C/stdpreds.c
View File

File diff suppressed because it is too large Load Diff

9
C/sysbits.c
View File

@ -205,7 +205,7 @@ Yap_dir_separator (int ch)
return dir_separator (ch); return dir_separator (ch);
} }
#if _MSC_VER || defined(__MINGW32__) #if __WINDOWS__
#include <psapi.h> #include <psapi.h>
char *libdir = NULL; char *libdir = NULL;
@ -217,9 +217,8 @@ initSysPath(Term tlib, Term tcommons) {
int len; int len;
int dir_done = FALSE; int dir_done = FALSE;
int commons_done = FALSE; int commons_done = FALSE;
Int rcl, rcc;
#if _MSC_VER || defined(__MINGW32__) || defined(__MSYS__) #if __WINDOWS__
{ {
char *dir; char *dir;
if ((dir = Yap_RegistryGetString("library")) && if ((dir = Yap_RegistryGetString("library")) &&
@ -236,7 +235,7 @@ initSysPath(Term tlib, Term tcommons) {
} }
} }
if (dir_done && commons_done) if (dir_done && commons_done)
return rcl && rcc; return TRUE;
#endif #endif
strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX); strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX);
strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX); strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX);
@ -260,7 +259,7 @@ initSysPath(Term tlib, Term tcommons) {
} }
} }
if (dir_done && commons_done) if (dir_done && commons_done)
return rcl && rcc; return TRUE;
#if __WINDOWS__ #if __WINDOWS__
{ {

49
C/threads.c
View File

@ -356,6 +356,8 @@ kill_thread_engine (int wid, int always_die)
} }
if (REMOTE_ScratchPad(wid).ptr) if (REMOTE_ScratchPad(wid).ptr)
free(REMOTE_ScratchPad(wid).ptr); free(REMOTE_ScratchPad(wid).ptr);
// if (REMOTE_TmpPred(wid).ptr)
// free(REMOTE_TmpPred(wid).ptr);
REMOTE_PL_local_data_p(wid)->reg_cache = REMOTE_PL_local_data_p(wid)->reg_cache =
REMOTE_ThreadHandle(wid).current_yaam_regs = NULL; REMOTE_ThreadHandle(wid).current_yaam_regs = NULL;
if (REMOTE_ThreadHandle(wid).start_of_timesp) if (REMOTE_ThreadHandle(wid).start_of_timesp)
@ -882,6 +884,18 @@ typedef struct swi_mutex {
pthread_mutex_t m; pthread_mutex_t m;
} SWIMutex; } SWIMutex;
static SWIMutex *MutexOfTerm(Term t)
{
Term t1 = Deref(t);
SWIMutex *mut = NULL;
if (IsVarTerm(t1)) {
} else if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(t1);
}
return mut;
}
static Int static Int
p_new_mutex( USES_REGS1 ) p_new_mutex( USES_REGS1 )
{ {
@ -906,25 +920,30 @@ p_new_mutex( USES_REGS1 )
pthread_mutex_init(&mutp->m, &mat); pthread_mutex_init(&mutp->m, &mat);
mutp->owners = 0; mutp->owners = 0;
mutp->tid_own = 0; mutp->tid_own = 0;
return Yap_unify(ARG1, MkIntegerTerm((Int)mutp)); return Yap_unify(ARG1, MkAddressTerm(mutp));
} }
static Int static Int
p_destroy_mutex( USES_REGS1 ) p_destroy_mutex( USES_REGS1 )
{ {
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1)); Term t1 = Deref(ARG1);
SWIMutex *mut;
if (pthread_mutex_destroy(&mut->m) < 0) if (IsVarTerm(t1)) {
return FALSE; } else if (IsAtomTerm(t1)) {
Yap_FreeCodeSpace((void *)mut); } else {
mut = AddressOfTerm(Deref(ARG1));
if (pthread_mutex_destroy(&mut->m) < 0)
return FALSE;
Yap_FreeCodeSpace((void *)mut);
}
return TRUE; return TRUE;
} }
static Int static Int
p_lock_mutex( USES_REGS1 ) p_lock_mutex( USES_REGS1 )
{ {
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1)); SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS #if DEBUG_LOCKS
MUTEX_LOCK(&mut->m); MUTEX_LOCK(&mut->m);
@ -940,7 +959,7 @@ p_new_mutex( USES_REGS1 )
static Int static Int
p_trylock_mutex( USES_REGS1 ) p_trylock_mutex( USES_REGS1 )
{ {
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1)); SWIMutex *mut = MutexOfTerm( ARG1 );
if (MUTEX_TRYLOCK(&mut->m) == EBUSY) if (MUTEX_TRYLOCK(&mut->m) == EBUSY)
return FALSE; return FALSE;
@ -952,7 +971,7 @@ p_new_mutex( USES_REGS1 )
static Int static Int
p_unlock_mutex( USES_REGS1 ) p_unlock_mutex( USES_REGS1 )
{ {
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1)); SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS #if DEBUG_LOCKS
MUTEX_UNLOCK(&mut->m); MUTEX_UNLOCK(&mut->m);
@ -979,9 +998,13 @@ p_new_mutex( USES_REGS1 )
p_new_mutex( PASS_REGS1 ); p_new_mutex( PASS_REGS1 );
t1 = Deref(ARG1); t1 = Deref(ARG1);
} }
mut = (SWIMutex*)IntegerOfTerm(t1); if (IsAtomTerm(t1)) {
if (!p_lock_mutex( PASS_REGS1 )) {
} else {
mut = AddressOfTerm(Deref(ARG1));
if (FALSE && !p_lock_mutex( PASS_REGS1 )) {
return FALSE; return FALSE;
}
} }
tg = Yap_StripModule(tg, &tm); tg = Yap_StripModule(tg, &tm);
@ -1030,7 +1053,7 @@ p_new_mutex( USES_REGS1 )
end: end:
ARG1 = MkIntegerTerm((Int)mut); ARG1 = MkIntegerTerm((Int)mut);
excep = Yap_GetException(); excep = Yap_GetException();
p_unlock_mutex( PASS_REGS1 ); if (FALSE) p_unlock_mutex( PASS_REGS1 );
if (creeping) { if (creeping) {
Yap_signal( YAP_CREEP_SIGNAL ); Yap_signal( YAP_CREEP_SIGNAL );
} else if ( excep != 0) { } else if ( excep != 0) {
@ -1276,7 +1299,7 @@ p_new_mutex( USES_REGS1 )
if (pthread_cond_broadcast(condp) < 0) if (pthread_cond_broadcast(condp) < 0)
return FALSE; return FALSE;
v return TRUE; return TRUE;
} }
static Int static Int

28
H/YapTags.h
View File

@ -394,6 +394,34 @@ IntegerOfTerm (Term t)
return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t)); return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
} }
#define MkAddressTerm(i) __MkAddressTerm(i PASS_REGS)
INLINE_ONLY inline EXTERN Term __MkAddressTerm (void * USES_REGS);
INLINE_ONLY inline EXTERN Term
__MkAddressTerm (void * n USES_REGS)
{
return __MkIntegerTerm((Int)n PASS_REGS);
}
INLINE_ONLY inline EXTERN bool IsAddressTerm (Term);
INLINE_ONLY inline EXTERN bool
IsAddressTerm (Term t)
{
return (bool) IsIntegerTerm (t);
}
INLINE_ONLY inline EXTERN void * AddressOfTerm (Term);
INLINE_ONLY inline EXTERN void *
AddressOfTerm (Term t)
{
return (void *) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
}
#ifndef YAP_H #ifndef YAP_H
#endif #endif

90
H/Yatom.h
View File

@ -403,6 +403,7 @@ AbsModProp (ModEntry * p)
return (Prop) (p); return (Prop) (p);
} }
#define ModToTerm(m) (m == PROLOG_MODULE ? TermProlog : m )
#endif #endif
@ -651,55 +652,55 @@ IsValProperty (int flags)
C_Preds are things write, read, ... implemented in C. In this case C_Preds are things write, read, ... implemented in C. In this case
CodeOfPred holds the address of the correspondent C-function. CodeOfPred holds the address of the correspondent C-function.
don;t forget to also add in qly.h don't forget to also add in qly.h
*/ */
typedef enum typedef enum
{ {
DiscontiguousPredFlag = ((UInt)0x00000010 << EXTRA_FLAG_BASE), /* predicates whose clauses may be all-over the place.. */ DiscontiguousPredFlag = ((uint64_t)((uint64_t)0x1000000000)), /* predicates whose clauses may be all-over the place.. */
SysExportPredFlag = ((UInt)0x00000008 << EXTRA_FLAG_BASE), /* reuse export list to prolog module. */ SysExportPredFlag = ((uint64_t)0x800000000), /* reuse export list to prolog module. */
NoTracePredFlag = ((UInt)0x00000004 << EXTRA_FLAG_BASE), /* cannot trace this predicate */ NoTracePredFlag = ((uint64_t)0x400000000), /* cannot trace this predicate */
NoSpyPredFlag = ((UInt)0x00000002 << EXTRA_FLAG_BASE), /* cannot spy this predicate */ NoSpyPredFlag = ((uint64_t)0x200000000), /* cannot spy this predicate */
QuasiQuotationPredFlag = ((UInt)0x00000001 << EXTRA_FLAG_BASE), /* SWI-like quasi quotations */ QuasiQuotationPredFlag = ((uint64_t)0x100000000), /* SWI-like quasi quotations */
MegaClausePredFlag = (UInt)0x80000000, /* predicate is implemented as a mega-clause */ MegaClausePredFlag = (uint64_t)0x80000000, /* predicate is implemented as a mega-clause */
ThreadLocalPredFlag = (UInt)0x40000000, /* local to a thread */ ThreadLocalPredFlag = (uint64_t)0x40000000, /* local to a thread */
MultiFileFlag = (UInt)0x20000000, /* is multi-file */ MultiFileFlag = (uint64_t)0x20000000, /* is multi-file */
UserCPredFlag = (UInt)0x10000000, /* CPred defined by the user */ UserCPredFlag = (uint64_t)0x10000000, /* CPred defined by the user */
LogUpdatePredFlag = (UInt)0x08000000, /* dynamic predicate with log. upd. sem. */ LogUpdatePredFlag = (uint64_t)0x08000000, /* dynamic predicate with log. upd. sem. */
InUsePredFlag = (UInt)0x04000000, /* count calls to pred */ InUsePredFlag = (uint64_t)0x04000000, /* count calls to pred */
CountPredFlag = (UInt)0x02000000, /* count calls to pred */ CountPredFlag = (uint64_t)0x02000000, /* count calls to pred */
HiddenPredFlag = (UInt)0x01000000, /* invisible predicate */ HiddenPredFlag = (uint64_t)0x01000000, /* invisible predicate */
CArgsPredFlag = (UInt)0x00800000, /* SWI-like C-interface pred. */ CArgsPredFlag = (uint64_t)0x00800000, /* SWI-like C-interface pred. */
SourcePredFlag = (UInt)0x00400000, /* static predicate with source declaration */ SourcePredFlag = (uint64_t)0x00400000, /* static predicate with source declaration */
MetaPredFlag = (UInt)0x00200000, /* predicate subject to a meta declaration */ MetaPredFlag = (uint64_t)0x00200000, /* predicate subject to a meta declaration */
SyncPredFlag = (UInt)0x00100000, /* has to synch before it can execute */ SyncPredFlag = (uint64_t)0x00100000, /* has to synch before it can execute */
NumberDBPredFlag = (UInt)0x00080000, /* entry for a number key */ NumberDBPredFlag = (uint64_t)0x00080000, /* entry for a number key */
AtomDBPredFlag = (UInt)0x00040000, /* entry for an atom key */ AtomDBPredFlag = (uint64_t)0x00040000, /* entry for an atom key */
GoalExPredFlag = (UInt)0x00020000, /* predicate that is called by goal_expand */ GoalExPredFlag = (uint64_t)0x00020000, /* predicate that is called by goal_expand */
TestPredFlag = (UInt)0x00010000, /* is a test (optim. comit) */ TestPredFlag = (uint64_t)0x00010000, /* is a test (optim. comit) */
AsmPredFlag = (UInt)0x00008000, /* inline */ AsmPredFlag = (uint64_t)0x00008000, /* inline */
StandardPredFlag = (UInt)0x00004000, /* system predicate */ StandardPredFlag = (uint64_t)0x00004000, /* system predicate */
DynamicPredFlag = (UInt)0x00002000, /* dynamic predicate */ DynamicPredFlag = (uint64_t)0x00002000, /* dynamic predicate */
CPredFlag = (UInt)0x00001000, /* written in C */ CPredFlag = (uint64_t)0x00001000, /* written in C */
SafePredFlag = (UInt)0x00000800, /* does not alter arguments */ SafePredFlag = (uint64_t)0x00000800, /* does not alter arguments */
CompiledPredFlag = (UInt)0x00000400, /* is static */ CompiledPredFlag = (uint64_t)0x00000400, /* is static */
IndexedPredFlag = (UInt)0x00000200, /* has indexing code */ IndexedPredFlag = (uint64_t)0x00000200, /* has indexing code */
SpiedPredFlag = (UInt)0x00000100, /* is a spy point */ SpiedPredFlag = (uint64_t)0x00000100, /* is a spy point */
BinaryPredFlag = (UInt)0x00000080, /* test predicate */ BinaryPredFlag = (uint64_t)0x00000080, /* test predicate */
TabledPredFlag = (UInt)0x00000040, /* is tabled */ TabledPredFlag = (uint64_t)0x00000040, /* is tabled */
SequentialPredFlag = (UInt)0x00000020, /* may not create parallel choice points! */ SequentialPredFlag = (uint64_t)0x00000020, /* may not create parallel choice points! */
ProfiledPredFlag = (UInt)0x00000010, /* pred is being profiled */ ProfiledPredFlag = (uint64_t)0x00000010, /* pred is being profiled */
BackCPredFlag = (UInt)0x00000008, /* Myddas Imported pred */ BackCPredFlag = (uint64_t)0x00000008, /* Myddas Imported pred */
ModuleTransparentPredFlag = (UInt)0x00000004, /* ModuleTransparent pred */ ModuleTransparentPredFlag = (uint64_t)0x00000004, /* ModuleTransparent pred */
SWIEnvPredFlag = (UInt)0x00000002, /* new SWI interface */ SWIEnvPredFlag = (uint64_t)0x00000002, /* new SWI interface */
UDIPredFlag = (UInt)0x00000001 /* User Defined Indexing */ UDIPredFlag = (uint64_t)0x00000001 /* User Defined Indexing */
} pred_flag; } pred_flag;
/* profile data */ /* profile data */
typedef struct typedef struct
{ {
YAP_ULONG_LONG NOfEntries; /* nbr of times head unification succeeded */ uint64_t NOfEntries; /* nbr of times head unification succeeded */
YAP_ULONG_LONG NOfHeadSuccesses; /* nbr of times head unification succeeded */ uint64_t NOfHeadSuccesses; /* nbr of times head unification succeeded */
YAP_ULONG_LONG NOfRetries; /* nbr of times a clause for the pred uint64_t NOfRetries; /* nbr of times a clause for the pred
was retried */ was retried */
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
lockvar lock; /* a simple lock to protect this entry */ lockvar lock; /* a simple lock to protect this entry */
@ -721,12 +722,7 @@ typedef struct pred_entry
PropFlags KindOfPE; /* kind of property */ PropFlags KindOfPE; /* kind of property */
struct yami *CodeOfPred; struct yami *CodeOfPred;
OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */ OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */
#if SIZEOF_INT_P==4 uint64_t PredFlags;
CELL PredFlags, ExtraPredFlags;
#else
CELL PredFlags;
#define ExtraPredFlags PredFlags
#endif
UInt ArityOfPE; /* arity of property */ UInt ArityOfPE; /* arity of property */
union union
{ {

2
H/dlmalloc.h
View File

@ -179,8 +179,10 @@ extern "C" {
#if DEBUG_DLMALLOC #if DEBUG_DLMALLOC
#include <assert.h> #include <assert.h>
#else #else
#ifndef assert
#define assert(x) ((void)0) #define assert(x) ((void)0)
#endif #endif
#endif
/* /*
The unsigned integer type used for comparing any two chunk sizes. The unsigned integer type used for comparing any two chunk sizes.

2
JIT/HPP/EnvironmentInit.h
View File

@ -1,7 +1,7 @@
#if YAP_STAT_PREDS #if YAP_STAT_PREDS
#include <papi.h> #include <papi.h>
#endif #endif
#include "Yap.h"
extern Environment ExpEnv; extern Environment ExpEnv;
#if YAP_JIT #if YAP_JIT

68
library/lineutils.yap
View File

@ -4,6 +4,9 @@
search_for/3, search_for/3,
scan_natural/3, scan_natural/3,
scan_integer/3, scan_integer/3,
natural/3,
integer/3,
blank/3,
split/2, split/2,
split/3, split/3,
fields/2, fields/2,
@ -66,6 +69,19 @@ scan_integer(N) -->
scan_integer(N) --> scan_integer(N) -->
scan_natural(0, N). scan_natural(0, N).
/** @pred integer(? _Int_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for an integer _Nat_, either a
positive, zero, or negative integer, and unify _RestOfLine_ with
the remainder of the line.
*/
integer(N) -->
"-", !,
natural(0, N0),
N is -N0.
integer(N) -->
natural(0, N).
/** @pred scan_natural(? _Nat_,+ _Line_,+ _RestOfLine_) /** @pred scan_natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero Scan the list of codes _Line_ for a natural number _Nat_, zero
@ -82,6 +98,49 @@ scan_natural(N0,N) -->
get_natural(N1,N). get_natural(N1,N).
scan_natural(N,N) --> []. scan_natural(N,N) --> [].
/** @pred natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero
or a positive integer, and unify _RestOfLine_ with the remainder
of the line.
*/
natural(N) -->
natural(0, N).
natural(N0,N) -->
[C],
{C >= 0'0, C =< 0'9 }, !,
{ N1 is N0*10+(C-0'0) }, %'
get_natural(N1,N).
natural(N,N) --> [].
/** @pred skip_whitespace(+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for white space, namely for tabbing and space characters.
*/
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace( [] ) -->
!.
/** @pred blank(+ _Line_,+ _RestOfLine_)
The list of codes _Line_ is formed by white space, namely by tabbing and space characters.
*/
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank( [] ) -->
[].
/** @pred split(+ _Line_,- _Split_) /** @pred split(+ _Line_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by Unify _Words_ with a set of strings obtained from _Line_ by
@ -243,9 +302,12 @@ process(StreamInp, Command) :-
For every line _LineIn_ in file _FileIn_, execute For every line _LineIn_ in file _FileIn_, execute
`call(Goal,LineIn,LineOut)`, and output _LineOut_ to file `call(Goal,LineIn,LineOut)`, and output _LineOut_ to file
_FileOut_. _FileOut_.
The input stream is accessible through the alias `filter_input`, and the output
stream is accessible through `filter_output`.
*/ */
file_filter(Inp, Out, Command) :- file_filter(Inp, Out, Command) :-
open(Inp, read, StreamInp), open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut), open(Out, write, StreamOut),
filter(StreamInp, StreamOut, Command), filter(StreamInp, StreamOut, Command),
close(StreamInp), close(StreamInp),
@ -258,8 +320,8 @@ Same as file_filter/3, but before starting the filter execute
_Arguments_. _Arguments_.
*/ */
file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :- file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :-
open(Inp, read, StreamInp), open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut), open(Out, write, StreamOut, [alias(filter_output)]),
format(StreamOut, FormatString, Parameters), format(StreamOut, FormatString, Parameters),
filter(StreamInp, StreamOut, Command), filter(StreamInp, StreamOut, Command),
close(StreamInp), close(StreamInp),

2
misc/LOCALS
View File

@ -54,6 +54,8 @@ Int DepthArenas =0
int ArithError =FALSE int ArithError =FALSE
struct pred_entry* LastAssertedPred =NULL struct pred_entry* LastAssertedPred =NULL
struct pred_entry* TmpPred =NULL
struct pred_entry* LastAssertedPred =NULL
char* ScannerStack =NULL char* ScannerStack =NULL
struct scanner_extra_alloc* ScannerExtraBlocks =NULL struct scanner_extra_alloc* ScannerExtraBlocks =NULL
struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid) struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid)

10
packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c
View File

@ -192,6 +192,8 @@
#include <stdarg.h> #include <stdarg.h>
#define VERSION "2.0.0" #define VERSION "2.0.0"
int all_loaded_for_deterministic_variables(namedvars varmap, int disp);
typedef struct _parameters { typedef struct _parameters {
int loadfile; int loadfile;
int savedfile; int savedfile;
@ -721,14 +723,14 @@ void myexpand(extmanager MyManager, DdNode *Current) {
} }
} }
/* Angelicas Algorithm */ /* Angelika's Algorithm */
double CalcProbability(extmanager MyManager, DdNode *Current) { double CalcProbability(extmanager MyManager, DdNode *Current) {
DdNode *h, *l; DdNode *h, *l;
hisnode *Found; hisnode *Found;
char *curnode, *dynvalue; char *curnode;
double lvalue, hvalue, tvalue; double lvalue, hvalue, tvalue;
density_integral dynvalue_parsed;
if (params.debug) { if (params.debug) {
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current); curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
fprintf(stderr, "%s\n", curnode); fprintf(stderr, "%s\n", curnode);
@ -811,7 +813,7 @@ static
void PrintNodeQueue(Queue q , extmanager MyManager){ void PrintNodeQueue(Queue q , extmanager MyManager){
QueueIterator qiter = QueueIteratorNew(q, 1); QueueIterator qiter = QueueIteratorNew(q, 1);
fprintf(stderr,"Queue %p is [", *q); fprintf(stderr,"Queue %p is [", &*q);
while (qiter->currentItem != NULL) { while (qiter->currentItem != NULL) {
DdNode* val = (DdNode*) qiter->currentItem->element; DdNode* val = (DdNode*) qiter->currentItem->element;

1
packages/ProbLog/simplecudd_lfi/problogmath.h
View File

@ -161,6 +161,7 @@ typedef struct _density_integral {
double sigmoid(double x, double slope); double sigmoid(double x, double slope);
double normal(double x, double mu,double sigma);
double Phi(double x); double Phi(double x);
double cumulative_normal(double low, double high, double sigma, double mu); double cumulative_normal(double low, double high, double sigma, double mu);
double cumulative_normal_dmu(double low, double high,double mu,double sigma); double cumulative_normal_dmu(double low, double high,double mu,double sigma);

14
packages/ProbLog/simplecudd_lfi/simplecudd.c
View File

@ -188,6 +188,9 @@
#include <errno.h> #include <errno.h>
#include "simplecudd.h" #include "simplecudd.h"
int my_index_calc(int varstart, DdNode *node);
int all_loaded_for_deterministic_variables(namedvars varmap, int disp);
/* BDD manager initialization */ /* BDD manager initialization */
int _debug = 0; int _debug = 0;
@ -1717,8 +1720,7 @@ int GetParam(char *inputline, int iParam) {
void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd) { void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd) {
char buf, *inputline; char buf, *inputline;
int icur, maxlinesize, iline, index, iloop, ivalue, iQsize, i, inQ, iRoot; int icur, maxlinesize, iline, index, iloop, iQsize, i, inQ, iRoot;
double dvalue;
DdNode **Q, **Q2, *h_node, *l_node, *curnode; DdNode **Q, **Q2, *h_node, *l_node, *curnode;
hisqueue *his; hisqueue *his;
hisnode *hnode; hisnode *hnode;
@ -1756,10 +1758,10 @@ void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, Dd
inQ = 0; inQ = 0;
for(i = 0; (i < iQsize / 2) && (inQ < 3); i++) for(i = 0; (i < iQsize / 2) && (inQ < 3); i++)
inQ = (Q[i] == l_node) || (Q[iQsize - i] == l_node) + 2 * (Q[i] == h_node) || (Q[iQsize - i] == h_node); inQ = (Q[i] == l_node) || (Q[iQsize - i] == l_node) + 2 * (Q[i] == h_node) || (Q[iQsize - i] == h_node);
if (inQ & 1 == 0) inQ = inQ + (GetNode(his, varmap.varstart, l_node) != NULL); if ((inQ & 1) == 0) inQ = inQ + (GetNode(his, varmap.varstart, l_node) != NULL);
if (inQ & 2 == 0) inQ = inQ + 2 * (GetNode(his, varmap.varstart, h_node) != NULL); if ((inQ & 2) == 0) inQ = inQ + 2 * (GetNode(his, varmap.varstart, h_node) != NULL);
if (inQ & 1 == 1) inQ = inQ - (l_node == HIGH(manager) || l_node == LOW(manager)); if ((inQ & 1) == 1) inQ = inQ - (l_node == HIGH(manager) || l_node == LOW(manager));
if (inQ & 2 == 2) inQ = inQ - 2 * (h_node == HIGH(manager) || h_node == LOW(manager)); if ((inQ & 2) == 2) inQ = inQ - 2 * (h_node == HIGH(manager) || h_node == LOW(manager));
inQ = 0; inQ = 0;
switch(inQ) { switch(inQ) {
case 0: case 0:

17
pl/consult.yap
View File

@ -63,7 +63,7 @@
'$convert_for_export'/7, '$convert_for_export'/7,
'$extend_exports'/3]). '$extend_exports'/3]).
:- use_system_module( '$_preds', ['$current_predicate_no_modules'/3]). :- use_system_module( '$_preds', ['$current_predicate'/4]).
/** /**
@ -890,7 +890,7 @@ source_file(FileName) :-
source_file(Mod:Pred, FileName) :- source_file(Mod:Pred, FileName) :-
current_module(Mod), current_module(Mod),
Mod \= prolog, Mod \= prolog,
'$current_predicate_no_modules'(Mod,_,Pred), '$current_predicate'(_,Mod,Pred,_),
'$owned_by'(Pred, Mod, FileName). '$owned_by'(Pred, Mod, FileName).
'$owned_by'(T, Mod, FileName) :- '$owned_by'(T, Mod, FileName) :-
@ -1173,12 +1173,13 @@ unload_file( F0 ) :-
% eliminate multi-files; % eliminate multi-files;
% get rid of file-only predicataes. % get rid of file-only predicataes.
'$unload_file'( FileName, _F0 ) :- '$unload_file'( FileName, _F0 ) :-
'$current_predicate_var'(_A,Mod,P), current_module(Mod),
'$owner_file'(P,Mod,FileName), '$current_predicate'(_A,Mod,P,_),
\+ '$is_multifile'(P,Mod), '$owner_file'(P,Mod,FileName),
functor( P, Na, Ar), \+ '$is_multifile'(P,Mod),
abolish(Mod:Na/Ar), functor( P, Na, Ar),
fail. abolish(Mod:Na/Ar),
fail.
%next multi-file. %next multi-file.
'$unload_file'( FileName, _F0 ) :- '$unload_file'( FileName, _F0 ) :-
recorded('$lf_loaded','$lf_loaded'( FileName, _Age, _), R), recorded('$lf_loaded','$lf_loaded'( FileName, _Age, _), R),

11
pl/debug.yap
View File

@ -182,8 +182,8 @@ mode and the existing spy-points, when the debugger is on.
'$pred_being_spied'(G, M) :- '$pred_being_spied'(G, M) :-
recorded('$spy','$spy'(G,M),_), !. recorded('$spy','$spy'(G,M),_), !.
/** @pred spy( + _P_ ). /**
@pred spy( + _P_ ).
Sets spy-points on all the predicates represented by Sets spy-points on all the predicates represented by
_P_. _P_ can either be a single specification or a list of _P_. _P_ can either be a single specification or a list of
@ -877,10 +877,10 @@ be lost.
'$meta_expansion'(G,M,M,M,G1,[]), '$meta_expansion'(G,M,M,M,G1,[]),
'$creep'(G1, M) '$creep'(G1, M)
; ;
'$execute'(M:G) '$execute'(M:G)
). ).
'$spycall'(G, M, _, _) :- '$spycall'(G, M, _, _) :-
'$tabled_predicate'(G,M), '$tabled_predicate'(G,M),
!, !,
'$continue_debugging_goal'(no, '$execute_nonstop'(G,M)). '$continue_debugging_goal'(no, '$execute_nonstop'(G,M)).
'$spycall'(G, M, CalledFromDebugger, InRedo) :- '$spycall'(G, M, CalledFromDebugger, InRedo) :-
@ -1323,6 +1323,3 @@ be lost.
yap_hacks:choicepoint(CP,_,prolog,'$loop_spy2',5,(_;_),_), !, yap_hacks:choicepoint(CP,_,prolog,'$loop_spy2',5,(_;_),_), !,
'$debugger_skip_loop_spy2'(CPs,CPs1). '$debugger_skip_loop_spy2'(CPs,CPs1).
'$debugger_skip_loop_spy2'(CPs,CPs). '$debugger_skip_loop_spy2'(CPs,CPs).

7
pl/hacks.yap
View File

@ -222,11 +222,8 @@ beautify_hidden_goal('$call'(G,_CP,?,M),prolog) -->
[call(M:G)]. [call(M:G)].
beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) --> beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) -->
[call(M:G0)]. [call(M:G0)].
beautify_hidden_goal('$current_predicate'(M,Na,Ar),prolog) --> beautify_hidden_goal('$current_predicate'(Na,M,S,_),prolog) -->
[current_predicate(M,Na/Ar)]. [current_predicate(Na,M:S)].
beautify_hidden_goal('$current_predicate_for_atom'(Name,M,Ar),prolog) -->
{ functor(P, Name, Ar) },
[current_predicate(Name,M:P)].
beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) --> beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) -->
[listing(Stream,M:Pred)]. [listing(Stream,M:Pred)].

4
pl/listing.yap
View File

@ -23,7 +23,7 @@
:- use_system_module( '$_errors', ['$do_error'/2]). :- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_preds', ['$clause'/4, :- use_system_module( '$_preds', ['$clause'/4,
'$current_predicate_no_modules'/3]). '$current_predicate'/4]).
/* listing : Listing clauses in the database /* listing : Listing clauses in the database
@ -62,7 +62,7 @@ listing :-
Mod \= prolog, Mod \= prolog,
Mod \= system, Mod \= system,
\+ '$hidden'( Mod ), \+ '$hidden'( Mod ),
'$current_predicate_no_modules'(Mod,_,Pred), '$current_predicate'(_,Mod,Pred, _),
'$undefined'(Pred, prolog), % skip predicates exported from prolog. '$undefined'(Pred, prolog), % skip predicates exported from prolog.
functor(Pred,Name,Arity), functor(Pred,Name,Arity),
\+ atom_concat('$', _, Name), \+ atom_concat('$', _, Name),

13
pl/modules.yap
View File

@ -831,21 +831,25 @@ expand_goal(G, G).
'$exit_undefp', '$exit_undefp',
fail. fail.
% This predicate should be bidirectional: both
% a consumer and a generator.
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_), recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_),
'$continue_imported'(ExportingMod, ExportingModI, G0, G0I), !. '$continue_imported'(ExportingMod, ExportingModI, G0, G0I).
% SWI builtin % SWI builtin
'$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :-
recorded('$dialect',Dialect,_), recorded('$dialect',Dialect,_),
Dialect \= yap, Dialect \= yap,
functor(G, Name, Arity), functor(G, Name, Arity),
call(Dialect:index(Name,Arity,ExportingModI,_)), !, call(Dialect:index(Name,Arity,ExportingModI,_)), !,
'$continue_imported'(ExportingMod, ExportingModI, G0, G), !. '$continue_imported'(ExportingMod, ExportingModI, G0, G).
% autoload
'$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :-
yap_flag(autoload, V), yap_flag(autoload, V),
V = true, V = true,
'$autoloader_find_predicate'(G,ExportingModI), !, '$autoloader_find_predicate'(G,ExportingModI),
'$continue_imported'(ExportingMod, ExportingModI, G0, G). '$continue_imported'(ExportingMod, ExportingModI, G0, G).
% parent module mechanism
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
prolog:'$parent_module'(ImportingMod,ExportingModI), prolog:'$parent_module'(ImportingMod,ExportingModI),
'$continue_imported'(ExportingMod, ExportingModI, G0, G). '$continue_imported'(ExportingMod, ExportingModI, G0, G).
@ -1203,7 +1207,8 @@ abolish_module(Mod) :-
recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R), recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R),
fail. fail.
abolish_module(Mod) :- abolish_module(Mod) :-
'$current_predicate'(Mod,Na,Ar), '$current_predicate'(Na,Mod,S,_),
functor(S, Na, Ar),
abolish(Mod:Na/Ar), abolish(Mod:Na/Ar),
fail. fail.
abolish_module(_). abolish_module(_).

142
pl/preds.yap
View File

@ -71,7 +71,7 @@ and therefore he should try to avoid them whenever possible.
unknown/2], ['$assert_static'/5, unknown/2], ['$assert_static'/5,
'$assertz_dynamic'/4, '$assertz_dynamic'/4,
'$clause'/4, '$clause'/4,
'$current_predicate_no_modules'/3, '$current_predicate'/4,
'$init_preds'/0, '$init_preds'/0,
'$noprofile'/2, '$noprofile'/2,
'$public'/2, '$public'/2,
@ -788,13 +788,15 @@ abolish(X) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all'(M) :- '$abolish_all'(M) :-
'$current_predicate'(M,Na,Ar), '$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M), '$new_abolish'(Na/Ar, M),
fail. fail.
'$abolish_all'(_). '$abolish_all'(_).
'$abolish_all_atoms'(Na, M) :- '$abolish_all_atoms'(Na, M) :-
'$current_predicate_for_atom'(Na,M,Ar), '$current_predicate'(Na,M,S,_),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M), '$new_abolish'(Na/Ar, M),
fail. fail.
'$abolish_all_atoms'(_,_). '$abolish_all_atoms'(_,_).
@ -858,13 +860,15 @@ abolish(X) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all_old'(M) :- '$abolish_all_old'(M) :-
'$current_predicate'(M, Na, Ar), '$current_predicate'(Na, M, S, _),
functor( S, Na, Ar ),
'$abolish'(Na, Ar, M), '$abolish'(Na, Ar, M),
fail. fail.
'$abolish_all_old'(_). '$abolish_all_old'(_).
'$abolish_all_atoms_old'(Na, M) :- '$abolish_all_atoms_old'(Na, M) :-
'$current_predicate_for_atom'(Na, M, Ar), '$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$abolish'(Na, Ar, M), '$abolish'(Na, Ar, M),
fail. fail.
'$abolish_all_atoms_old'(_,_). '$abolish_all_atoms_old'(_,_).
@ -1071,7 +1075,8 @@ predicate_property(Pred,Prop) :-
). ).
'$generate_all_preds_from_mod'(Pred, M, M) :- '$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(M,Na,Ar), '$current_predicate'(Na,M,S,_),
functor(S,Na,Ar),
'$ifunctor'(Pred,Na,Ar). '$ifunctor'(Pred,Na,Ar).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :- '$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_), recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_),
@ -1165,59 +1170,37 @@ predicate_erased_statistics(P,NCls,Sz,ISz) :-
Defines the relation: _P_ is a currently defined predicate whose Defines the relation: _P_ is a currently defined predicate whose
name is the atom _A_. name is the atom _A_.
*/ */
current_predicate(A,T) :- current_predicate(A,T) :-
var(T), !, % only for the predicate '$ground_module'(T, M, T0),
'$current_module'(M), (
'$current_predicate_no_modules'(M,A,T). '$current_predicate'(A, M, T0, _)
current_predicate(A,M:T) :- % module unspecified ;
var(M), !, '$imported_predicate'(A, M, A/_Arity, T0, _)
'$current_predicate_var'(A,M,T). ).
current_predicate(A,M:T) :- % module specified
nonvar(T),
!,
functor(T,A,_),
'$pred_exists'(T,M).
current_predicate(A,M:T) :- % module specified
!,
'$current_predicate_no_modules'(M,A,T).
current_predicate(A,T) :- % only for the predicate
'$current_module'(M),
'$current_predicate_no_modules'(M,A,T).
'$current_predicate_var'(A,M,T) :-
var(T), !,
current_module(M),
M \= prolog,
'$current_predicate_no_modules'(M,A,T).
'$current_predicate_var'(A,M,T) :-
functor(T,A,_),
current_module(M),
M \= prolog,
'$pred_exists'(T,M).
/** @pred system_predicate( _A_, _P_) /** @pred system_predicate( _A_, _P_)
Defines the relation: _P_ is a built-in predicate whose name Defines the relation: _P_ is a built-in predicate whose name
is the atom _A_. is the atom _A_.
*/ */
system_predicate(A,P) :- system_predicate(A,T) :-
'$current_predicate_no_modules'(prolog,A,P), '$ground_module'(T, M, T0),
(
'$current_predicate'(A, M, T0, Flags)
;
'$current_predicate'(A, prolog, T0, Flags)
),
Flags /\ 0x00004000 =\= 0,
\+ '$hidden'(A). \+ '$hidden'(A).
system_predicate(P) :- /** @pred system_predicate( ?_P_ )
'$current_module'(M),
'$system_predicate'(P,M). Defines the relation: _P_ is a currently defined system predicate.
*/
system_predicate(P) :-
system_predicate(_, P).
'$current_predicate_no_modules'(M,A,T) :-
'$current_predicate'(M,A,Arity),
'$ifunctor'(T,A,Arity),
'$pred_exists'(T,M).
/** @pred current_predicate( _F_) is iso /** @pred current_predicate( _F_) is iso
@ -1225,65 +1208,32 @@ system_predicate(P) :-
_F_ is the predicate indicator for a currently defined user or _F_ is the predicate indicator for a currently defined user or
library predicate. _F_ is of the form _Na/Ar_, where the atom library predicate. _F_ is of the form _Na/Ar_, where the atom
_Na_ is the name of the predicate, and _Ar_ its arity. _Na_ is the name of the predicate, and _Ar_ its arity.
*/ */
current_predicate(F0) :- current_predicate(F0) :-
'$yap_strip_module'(F0, M, F), '$ground_module'(F0, M, F),
'$$current_predicate'(F, M).
'$$current_predicate'(F, M) :-
( var(M) -> % only for the predicate
'$all_current_modules'(M)
; true),
M \= prolog,
'$current_predicate3'(F,M).
'$current_predicate3'(A/Arity,M) :-
nonvar(A), nonvar(Arity), !,
( '$ifunctor'(T,A,Arity),
'$pred_exists'(T,M)
->
true
;
% '$current_predicate'(prolog,A,Arity)
% ->
% functor(T,A,Arity),
% '$pred_exists'(T,M)
% ;
recorded('$import','$import'(NM,M,G,T,A,Arity),_)
->
'$pred_exists'(G,NM)
).
'$current_predicate3'(A/Arity,M) :- !,
( (
'$current_predicate'(M,A,Arity), '$current_predicate'(N, M, S, _),
'$ifunctor'(T,A,Arity), functor( S, N, Ar),
'$pred_exists'(T,M) F = N/Ar
; ;
% '$current_predicate'(prolog,A,Arity), '$imported_predicate'(_Name, M, F, _S, _)
% functor(T,A,Arity),
% '$pred_exists'(T,M)
% ;
recorded('$import','$import'(NM,M,G,T,A,Arity),_),
functor(T,A,Arity),
'$pred_exists'(G,NM)
). ).
'$current_predicate3'(BadSpec,M) :- % only for the predicate
'$do_error'(type_error(predicate_indicator,BadSpec),current_predicate(M:BadSpec)). '$imported_predicate'(A, ImportingMod, A/Arity, G, Flags) :-
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod),
functor(G, A, Arity),
'$pred_exists'(G, ExportingMod),
'$flags'(G0, ExportingMod, Flags, Flags).
/** @pred current_key(? _A_,? _K_) /** @pred current_key(? _A_,? _K_)
Defines the relation: _K_ is a currently defined database key whose Defines the relation: _K_ is a currently defined database key whose
name is the atom _A_. It can be used to generate all the keys for name is the atom _A_. It can be used to generate all the keys for
the internal data-base. the internal data-base.
*/ */
current_key(A,K) :- current_key(A,K) :-
'$current_predicate'(idb,A,Arity), '$current_predicate'(A,idb,K,_).
'$ifunctor'(K,A,Arity).
% do nothing for now. % do nothing for now.
'$noprofile'(_, _). '$noprofile'(_, _).
@ -1307,10 +1257,6 @@ calls to assert/1 or retract/1 on the named predicates
raise a permission error. This predicate is designed to deal with parts raise a permission error. This predicate is designed to deal with parts
of the program that is generated at runtime but does not change during of the program that is generated at runtime but does not change during
the remainder of the program execution. the remainder of the program execution.
*/ */
compile_predicates(Ps) :- compile_predicates(Ps) :-
'$current_module'(Mod), '$current_module'(Mod),

5
pl/profile.yap
View File

@ -126,8 +126,8 @@ profile_data(P, Parm, Data) :-
'$profile_say'(Stats, Parm, Data). '$profile_say'(Stats, Parm, Data).
'$profile_data_for_var'(Name/Arity, Parm, Data, M) :- '$profile_data_for_var'(Name/Arity, Parm, Data, M) :-
'$current_predicate'(M,Name,Arity),
functor(P,Name,Arity), functor(P,Name,Arity),
'$current_predicate'(Name,M,P,_),
\+ '$hidden'(Name), % don't show hidden predicates. \+ '$hidden'(Name), % don't show hidden predicates.
'$profile_info'(M, P, Stats), '$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data). '$profile_say'(Stats, Parm, Data).
@ -137,8 +137,7 @@ profile_data(P, Parm, Data) :-
profile_reset :- profile_reset :-
current_module(M), current_module(M),
'$current_predicate'(M,Na,Ar), '$current_predicate'(_Na,M,P,_),
functor(P,Na,Ar),
'$profile_reset'(M, P), '$profile_reset'(M, P),
fail. fail.
profile_reset. profile_reset.

3
pl/protect.yap
View File

@ -30,8 +30,7 @@
'$protect'. '$protect'.
'$hide_predicates'(Name) :- '$hide_predicates'(Name) :-
'$current_predicate_for_atom'(Name, prolog, Ar), '$current_predicate'(Name, prolog, P, _),
functor(P, Name, Ar),
'$hide_predicate'(P,prolog), '$hide_predicate'(P,prolog),
fail. fail.
'$hide_predicates'(_). '$hide_predicates'(_).

3
pl/signals.yap
View File

@ -227,7 +227,8 @@ order of dispatch.
'$execute_nonstop'(G, M), '$execute_nonstop'(G, M),
'$$save_by'(CP2), '$$save_by'(CP2),
'$disable_debugging', '$disable_debugging',
(CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ) (CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ),
'$enable_debugging'
; ;
'$disable_debugging', '$disable_debugging',
fail fail