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

Merge branch 'master' of ssh://git.dcc.fc.up.pt/yap-6.3

Browse Source 
Conflicts:
	C/threads.c
	JIT/HPP/EnvironmentInit.h
	packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c
	pl/preds.yap
This commit is contained in:
Vitor Santos Costa 2014-11-25 16:53:35 +00:00
commit afc6c5d04e
29 changed files with 2005 additions and 1513 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 */
@ -7830,8 +7830,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);
{ {

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);

268
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)))
@ -176,13 +158,12 @@ Yap_NewModulePred(Term mod, struct pred_entry *ap)
WRITE_UNLOCK(me->ModRWLock); WRITE_UNLOCK(me->ModRWLock);
} }
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);

1696
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__
{ {

405
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)
@ -878,6 +880,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 )
{ {
@ -1111,7 +1125,245 @@ p_mbox_create( USES_REGS1 )
mboxp = mboxp->next; mboxp = mboxp->next;
if (mboxp) { if (mboxp) {
UNLOCK(GLOBAL_mboxq_lock); UNLOCK(GLOBAL_mboxq_lock);
return FALSE; =======
return Yap_unify(ARG1, MkAddressTerm(mutp));
}
static Int
p_destroy_mutex( USES_REGS1 )
{
Term t1 = Deref(ARG1);
SWIMutex *mut;
if (IsVarTerm(t1)) {
} else if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(Deref(ARG1));
if (pthread_mutex_destroy(&mut->m) < 0)
return FALSE;
Yap_FreeCodeSpace((void *)mut);
}
return TRUE;
}
static Int
p_lock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS
MUTEX_LOCK(&mut->m);
#else
if (MUTEX_LOCK(&mut->m) < 0)
return FALSE;
#endif
mut->owners++;
mut->tid_own = worker_id;
return TRUE;
}
static Int
p_trylock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
if (MUTEX_TRYLOCK(&mut->m) == EBUSY)
return FALSE;
mut->owners++;
mut->tid_own = worker_id;
return TRUE;
}
static Int
p_unlock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS
MUTEX_UNLOCK(&mut->m);
#else
if (MUTEX_UNLOCK(&mut->m) < 0)
return FALSE;
#endif
mut->owners--;
return TRUE;
}
static Int
p_with_mutex( USES_REGS1 )
{
SWIMutex *mut;
Term t1 = Deref(ARG1), excep;
Int rc = FALSE;
Int creeping = Yap_get_signal(YAP_CREEP_SIGNAL);
PredEntry *pe;
Term tm = CurrentModule;
Term tg = Deref(ARG2);
if (IsVarTerm(t1)) {
p_new_mutex( PASS_REGS1 );
t1 = Deref(ARG1);
}
if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(Deref(ARG1));
if (FALSE && !p_lock_mutex( PASS_REGS1 )) {
return FALSE;
}
}
tg = Yap_StripModule(tg, &tm);
if (IsVarTerm(tg)) {
Yap_Error(INSTANTIATION_ERROR, ARG2, "with_mutex/2");
goto end;
} else if (IsApplTerm(tg)) {
register Functor f = FunctorOfTerm(tg);
register CELL *pt;
size_t i, arity;
f = FunctorOfTerm(tg);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
arity = ArityOfFunctor(f);
if (arity > MaxTemps) {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
pe = RepPredProp(PredPropByFunc(f, tm));
pt = RepAppl(tg)+1;
for (i= 0; i < arity; i++ )
XREGS[i+1] = pt[i];
} else if (IsAtomTerm(tg)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(tg), tm));
} else if (IsPairTerm(tg)) {
register CELL *pt;
Functor f;
f = FunctorDot;
pe = RepPredProp(PredPropByFunc(f, tm));
pt = RepPair(tg);
XREGS[1] = pt[0];
XREGS[2] = pt[1];
} else {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
if (
pe->OpcodeOfPred != FAIL_OPCODE &&
Yap_execute_pred(pe, NULL PASS_REGS) ) {
rc = TRUE;
}
end:
ARG1 = MkIntegerTerm((Int)mut);
excep = Yap_GetException();
if (FALSE) p_unlock_mutex( PASS_REGS1 );
if (creeping) {
Yap_signal( YAP_CREEP_SIGNAL );
} else if ( excep != 0) {
return Yap_JumpToEnv(excep);
}
return rc;
}
static Int
p_with_with_mutex( USES_REGS1 )
{
if (GLOBAL_WithMutex == NULL) {
p_new_mutex( PASS_REGS1 );
GLOBAL_WithMutex = (SWIMutex*)IntegerOfTerm(Deref(ARG1));
} else {
ARG1 = MkIntegerTerm((Int)GLOBAL_WithMutex);
}
return p_lock_mutex( PASS_REGS1 );
}
static Int
p_unlock_with_mutex( USES_REGS1 )
{
ARG1 = MkIntegerTerm((Int)GLOBAL_WithMutex);
return p_unlock_mutex( PASS_REGS1 );
}
static Int
p_mutex_info( USES_REGS1 )
{
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1));
return Yap_unify(ARG2, MkIntegerTerm(mut->owners)) &&
Yap_unify(ARG3, MkIntegerTerm(mut->tid_own));
return TRUE;
}
static Int
p_cond_create( USES_REGS1 )
{
pthread_cond_t* condp;
condp = (pthread_cond_t *)Yap_AllocCodeSpace(sizeof(pthread_cond_t));
if (condp == NULL) {
return FALSE;
}
pthread_cond_init(condp, NULL);
return Yap_unify(ARG1, MkIntegerTerm((Int)condp));
}
typedef struct {
UInt indx;
mbox_t mbox;
} counted_mbox;
static Int
p_mbox_create( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = GLOBAL_named_mboxes;
if (IsVarTerm(namet)) {
AtomEntry *ae;
int new;
mbox_t mbox;
ae = Yap_lookupBlob(&mbox, sizeof(mbox), &PL_Message_Queue, &new);
namet = MkAtomTerm(RepAtom(ae));
mboxp = (mbox_t *)(ae->rep.blob[0].data);
Yap_unify(ARG1, namet);
LOCK(GLOBAL_mboxq_lock);
} else if (IsAtomTerm(namet)) {
LOCK(GLOBAL_mboxq_lock);
while( mboxp && mboxp->name != namet)
mboxp = mboxp->next;
if (mboxp) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t));
if (mboxp == NULL) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
// global mbox, for now we'll just insert in list
mboxp->next = GLOBAL_named_mboxes;
GLOBAL_named_mboxes = mboxp;
}
bool rc = mboxCreate( namet, mboxp PASS_REGS );
UNLOCK(GLOBAL_mboxq_lock);
return rc;
}
static Int
p_mbox_destroy( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = GLOBAL_named_mboxes, *prevp;
if (IsVarTerm(namet) )
return FALSE;
} }
mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t)); mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t));
if (mboxp == NULL) { if (mboxp == NULL) {
@ -1156,7 +1408,156 @@ p_mbox_destroy( USES_REGS1 )
UNLOCK(GLOBAL_mboxq_lock); UNLOCK(GLOBAL_mboxq_lock);
mboxDestroy(mboxp PASS_REGS); mboxDestroy(mboxp PASS_REGS);
Yap_FreeCodeSpace( (char *)mboxp ); Yap_FreeCodeSpace( (char *)mboxp );
return TRUE; =======
}
LOCK(GLOBAL_mboxq_lock);
prevp = NULL;
while( mboxp && mboxp->name != namet) {
prevp = mboxp;
mboxp = mboxp->next;
}
if (!mboxp) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
if (mboxp == GLOBAL_named_mboxes) {
GLOBAL_named_mboxes = mboxp->next;
} else {
prevp->next = mboxp->next;
}
UNLOCK(GLOBAL_mboxq_lock);
mboxDestroy(mboxp PASS_REGS);
Yap_FreeCodeSpace( (char *)mboxp );
return TRUE;
}
static mbox_t*
getMbox(Term t)
{
mbox_t* mboxp;
if (IsAtomTerm(t=Deref(t))) {
Atom at = AtomOfTerm(t);
LOCK(GLOBAL_mboxq_lock);
if (IsBlob(at)) {
mboxp = (mbox_t *)(RepAtom(at)->rep.blob[0].data);
} else {
mboxp = GLOBAL_named_mboxes;
while( mboxp && mboxp->name != t) {
mboxp = mboxp->next;
}
}
if (!mboxp->open)
mboxp = NULL;
if (mboxp) {
pthread_mutex_lock(& mboxp->mutex);
}
UNLOCK(GLOBAL_mboxq_lock);
} else if (IsIntTerm(t)) {
int wid = IntOfTerm(t);
if (REMOTE(wid) &&
(REMOTE_ThreadHandle(wid).in_use || REMOTE_ThreadHandle(wid).zombie))
{
return &REMOTE_ThreadHandle(wid).mbox_handle;
} else {
return NULL;
}
if (!mboxp->open)
mboxp = NULL;
if (mboxp) {
pthread_mutex_lock(& mboxp->mutex);
}
} else {
return NULL;
}
return mboxp;
}
static Int
p_mbox_send( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxSend(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_mbox_size( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return Yap_unify( ARG2, MkIntTerm(mboxp->nmsgs));
}
static Int
p_mbox_receive( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxReceive(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_mbox_peek( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxPeek(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_cond_destroy( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_destroy(condp) < 0)
return FALSE;
Yap_FreeCodeSpace((void *)condp);
return TRUE;
}
static Int
p_cond_signal( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_signal(condp) < 0)
return FALSE;
return TRUE;
}
static Int
p_cond_broadcast( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_broadcast(condp) < 0)
return FALSE;
return TRUE;
}
static Int
p_cond_wait( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG2));
pthread_cond_wait(condp, &mut->m);
return TRUE;
} }
static mbox_t* static mbox_t*

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

92
H/Yatom.h
View File

@ -403,7 +403,8 @@ AbsModProp (ModEntry * p)
return (Prop) (p); return (Prop) (p);
} }
#define ModToTerm(m) (m == PROLOG_MODULE ? TermProlog : m )
#endif #endif
#define ModProperty ((PropFlags)0xfffa) #define ModProperty ((PropFlags)0xfffa)
@ -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
{ {

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),

6
library/tries/base_dbtries.c
View File

@ -238,9 +238,11 @@ YAP_Term trie_depth_breadth(TrEntry trie, TrEntry db_trie, YAP_Int opt_level, YA
set_depth_breadth_reduction_current_data(NULL); set_depth_breadth_reduction_current_data(NULL);
/* We only need to simplify the trie once! */ /* We only need to simplify the trie once! */
/* This can be a 10% overhead for sld cases :-( */ /* This can be a 10% overhead for sld cases :-( */
// printf("simplification\n"); trie_print(trie);
if (TrNode_child(TrEntry_trie(trie))) if (TrNode_child(TrEntry_trie(trie)))
simplification_reduction(trie); simplification_reduction(trie);
while (TrNode_child(TrEntry_trie(trie))) { while (TrNode_child(TrEntry_trie(trie))) {
// printf("depth\n"); trie_print(trie);
nested_trie = depth_reduction(trie, depth_node, opt_level); nested_trie = depth_reduction(trie, depth_node, opt_level);
if (nested_trie) { if (nested_trie) {
set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie)); set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie));
@ -248,6 +250,7 @@ YAP_Term trie_depth_breadth(TrEntry trie, TrEntry db_trie, YAP_Int opt_level, YA
*end_counter = core_get_label_counter(); *end_counter = core_get_label_counter();
return YAP_MkApplTerm((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(nested_trie))), 1, &TrNode_entry(nested_trie)); return YAP_MkApplTerm((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(nested_trie))), 1, &TrNode_entry(nested_trie));
} }
// printf("breadth\n"); trie_print(trie);
nested_trie = breadth_reduction(trie, breadth_node, opt_level); nested_trie = breadth_reduction(trie, breadth_node, opt_level);
if (nested_trie) { if (nested_trie) {
set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie)); set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie));
@ -276,7 +279,8 @@ TrData trie_get_depth_breadth_reduction_current_data(void) {
void trie_replace_nested_trie(TrEntry trie, YAP_Int nested_trie_id, YAP_Term new_term) { void trie_replace_nested_trie(TrEntry trie, YAP_Int nested_trie_id, YAP_Term new_term) {
core_depth_breadth_trie_replace_nested_trie(TrNode_child(TrEntry_trie(trie)), nested_trie_id, new_term); CURRENT_TRIE = trie;
core_depth_breadth_trie_replace_nested_trie(TrNode_child(TrEntry_trie(trie)), nested_trie_id, new_term, &trie_data_construct, &trie_data_destruct);
return; return;
} }

35
library/tries/base_tries.c
View File

@ -74,8 +74,23 @@ void trie_data_destruct(TrNode node) {
data = (TrData) GET_DATA_FROM_LEAF_TRIE_NODE(node); data = (TrData) GET_DATA_FROM_LEAF_TRIE_NODE(node);
trie = TrData_trie(data); trie = TrData_trie(data);
if (data == TrEntry_traverse_data(trie)) if (data == TrEntry_traverse_data(trie)) {
TrEntry_traverse_data(trie) = TrData_previous(data); if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD) {
TrEntry_traverse_data(trie) = TrData_previous(data);
} else {
if (TrData_next(data)) {
TrEntry_traverse_data(trie) = TrData_next(data);
} else {
TrData special;
new_struct(special, TYPE_TR_DATA, SIZEOF_TR_DATA);
TrData_next(special) = NULL;
TrData_previous(special) = TrData_previous(data);
TrData_trie(special) = NULL;
TrData_leaf(special) = NULL;
TrEntry_traverse_data(trie) = special; /* This special data is necessery to allow proper backwards traverse when the last entry is removed this is freed only if the trie is kept traversing */
}
}
}
if (TrData_next(data)) { if (TrData_next(data)) {
TrData_previous(TrData_next(data)) = TrData_previous(data); TrData_previous(TrData_next(data)) = TrData_previous(data);
TrData_next(TrData_previous(data)) = TrData_next(data); TrData_next(TrData_previous(data)) = TrData_next(data);
@ -211,10 +226,19 @@ TrData trie_traverse_init(TrEntry trie, TrData init_data) {
TrData trie_traverse_cont(TrEntry trie) { TrData trie_traverse_cont(TrEntry trie) {
TrData data; TrData data, temp = NULL;
data = TrEntry_traverse_data(trie); data = TrEntry_traverse_data(trie);
if (data) { if (data) {
if (!TrData_trie(data)) {
if (TrEntry_first_data(trie)) {
temp = data;
} else {
free_trie_data(data);
data = NULL;
TrEntry_traverse_data(trie) = NULL;
return NULL;
}
}
if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD) if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD)
data = TrData_next(data); data = TrData_next(data);
else { else {
@ -223,6 +247,8 @@ TrData trie_traverse_cont(TrEntry trie) {
data = NULL; data = NULL;
} }
TrEntry_traverse_data(trie) = data; TrEntry_traverse_data(trie) = data;
if (temp)
free_trie_data(temp);
} }
return data; return data;
} }
@ -325,7 +351,6 @@ void trie_print(TrEntry trie) {
void trie_data_construct(TrNode node) { void trie_data_construct(TrNode node) {
TrData data; TrData data;
new_trie_data(data, CURRENT_TRIE, node); new_trie_data(data, CURRENT_TRIE, node);
PUT_DATA_IN_LEAF_TRIE_NODE(node, data); PUT_DATA_IN_LEAF_TRIE_NODE(node, data);
return; return;

110
library/tries/core_dbtries.c
View File

@ -210,9 +210,9 @@ int traverse_get_counter(TrNode node);
YAP_Term generate_label(YAP_Int Index); YAP_Term generate_label(YAP_Int Index);
YAP_Term update_depth_breadth_trie(TrEngine engine, TrNode root, YAP_Int opt_level, void (*construct_function)(TrNode), void (*destruct_function)(TrNode), void (*copy_function)(TrNode, TrNode), void (*correct_order_function)(void)); YAP_Term update_depth_breadth_trie(TrEngine engine, TrNode root, YAP_Int opt_level, void (*construct_function)(TrNode), void (*destruct_function)(TrNode), void (*copy_function)(TrNode, TrNode), void (*correct_order_function)(void));
YAP_Term get_return_node_term(TrNode node); YAP_Term get_return_node_term(TrNode node);
void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term); void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term); TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
void check_attach_childs(TrNode search_child, TrNode existing_child); void check_attach_childs(TrNode parent, TrNode search_child, TrNode existing_child, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
TrNode get_simplification_sibling(TrNode node); TrNode get_simplification_sibling(TrNode node);
TrNode check_parent_first(TrNode node); TrNode check_parent_first(TrNode node);
TrNode TrNode_myparent(TrNode node); TrNode TrNode_myparent(TrNode node);
@ -257,18 +257,18 @@ void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix) {
void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term) { void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
traverse_and_replace_nested_trie(node, nested_trie_id, new_term); traverse_and_replace_nested_trie(node, nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
inline inline
void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term) { void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode child, temp; TrNode child, temp;
if (TrNode_entry(node) == PairEndTag) { if (TrNode_entry(node) == PairEndTag) {
if (TrNode_next(node)) if (TrNode_next(node))
traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} else if (IS_HASH_NODE(node)) { } else if (IS_HASH_NODE(node)) {
printf("HASH NODE ERROR: db_tries do not support hash nodes.\n"); printf("HASH NODE ERROR: db_tries do not support hash nodes.\n");
@ -280,7 +280,7 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if ((node = *--bucket)) { if ((node = *--bucket)) {
do { do {
traverse_and_replace_nested_trie(node, nested_trie_id, new_term); traverse_and_replace_nested_trie(node, nested_trie_id, new_term, construct_function, destruct_function);
node = TrNode_next(node); node = TrNode_next(node);
} while(node); } while(node);
} }
@ -303,13 +303,13 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) {
temp = TrNode_previous(node); temp = TrNode_previous(node);
node = replace_nested_trie(node, child, new_term); node = replace_nested_trie(node, child, new_term, construct_function, destruct_function);
if (temp) { if (temp) {
temp = TrNode_next(node); temp = TrNode_next(node);
if (temp) if (temp)
node = temp; node = temp;
} else { } else {
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
} }
@ -322,10 +322,10 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) {
temp = TrNode_next(node); temp = TrNode_next(node);
node = replace_nested_trie(node, child, new_term); node = replace_nested_trie(node, child, new_term, construct_function, destruct_function);
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
if(temp) if(temp)
traverse_and_replace_nested_trie(temp, nested_trie_id, new_term); traverse_and_replace_nested_trie(temp, nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
child = TrNode_next(child); child = TrNode_next(child);
@ -333,17 +333,16 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
} }
} }
} }
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
if (TrNode_next(node)) if (TrNode_next(node))
traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term, construct_function, destruct_function);
} }
return; return;
} }
/* fixmeeee */ /* fixmeeee */
TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) { TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode newnode, temp, newnodef = NULL; TrNode newnode, temp, newnodef = NULL;
YAP_Term term_search = (YAP_Term) NULL;
if (YAP_IsApplTerm(new_term)) { if (YAP_IsApplTerm(new_term)) {
YAP_Term new_term_functor = ApplTag | ((YAP_Term) YAP_FunctorOfTerm(new_term)); YAP_Term new_term_functor = ApplTag | ((YAP_Term) YAP_FunctorOfTerm(new_term));
YAP_Int arity = YAP_ArityOfFunctor(YAP_FunctorOfTerm(new_term)); YAP_Int arity = YAP_ArityOfFunctor(YAP_FunctorOfTerm(new_term));
@ -369,27 +368,19 @@ TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) {
TrNode_previous(TrNode_child(newnodef)) = newnode; TrNode_previous(TrNode_child(newnodef)) = newnode;
TrNode_child(newnodef) = newnode; TrNode_child(newnodef) = newnode;
} else { } else {
// Rewind to first uncle node /* Check if one of the node siblings have new_term */
temp = TrNode_parent(node); temp = node;
if (IS_FUNCTOR_NODE(temp))
term_search = TrNode_entry(temp);
while (TrNode_previous(temp)) while (TrNode_previous(temp))
temp = TrNode_previous(temp); temp = TrNode_previous(temp);
// Handles cases like not(t(?)) but doesn't handle case like not(not(...)
if (term_search) {
while (temp && TrNode_entry(temp) != term_search)
temp = TrNode_next(temp);
if (temp)
temp = TrNode_child(temp);
}
while (temp && TrNode_entry(temp) != new_term) while (temp && TrNode_entry(temp) != new_term)
temp = TrNode_next(temp); temp = TrNode_next(temp);
if (temp) { // Found a node we can reuse if (temp) {
newnode = temp; newnode = temp;
// Check if the childs of node/child exist already otherwise attach them // Check if the childs of node/child exist already otherwise attach them
check_attach_childs(TrNode_child(child), TrNode_child(newnode)); check_attach_childs(newnode, TrNode_child(child), TrNode_child(newnode), construct_function, destruct_function);
//DATA_DESTRUCT_FUNCTION = destruct_function; DATA_DESTRUCT_FUNCTION = destruct_function;
remove_child_nodes(TrNode_child(child)); remove_child_nodes(TrNode_child(child));
TrNode_child(child) = NULL;
remove_entry(child); remove_entry(child);
return newnode; return newnode;
} else { // Make a new node } else { // Make a new node
@ -426,20 +417,56 @@ TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) {
} }
void check_attach_childs(TrNode search_child, TrNode existing_child) { void check_attach_childs(TrNode parent, TrNode search_child, TrNode existing_child, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode newnode;
// Check if the childs of node/child exist already otherwise attach them // Check if the childs of node/child exist already otherwise attach them
do { do {
while(existing_child && (TrNode_entry(existing_child) != TrNode_entry(search_child))) while(existing_child && (TrNode_entry(existing_child) != PairEndTag) && (TrNode_entry(existing_child) != TrNode_entry(search_child)))
existing_child = TrNode_next(existing_child); existing_child = TrNode_next(existing_child);
if (existing_child) { if (existing_child) {
if (TrNode_entry(existing_child) != PairEndTag) { if (TrNode_entry(existing_child) != PairEndTag)
check_attach_childs(TrNode_child(search_child), TrNode_child(existing_child)); check_attach_childs(existing_child, TrNode_child(search_child), TrNode_child(existing_child), construct_function, destruct_function);
} existing_child = TrNode_child(parent);
search_child = TrNode_next(search_child);
} else if (TrNode_entry(search_child) == PairEndTag) {
newnode = parent;
DATA_DESTRUCT_FUNCTION = destruct_function;
remove_child_nodes(TrNode_child(newnode));
TrNode_child(newnode) = NULL;
newnode = trie_node_check_insert(newnode, PairEndTag);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
(*construct_function)(newnode);
return;
} else { } else {
printf("Need to attach child!\n"); existing_child = search_child;
abort(); search_child = TrNode_next(search_child);
if(TrNode_child(TrNode_parent(existing_child)) == existing_child) {
if(TrNode_next(existing_child)) {
TrNode_child(TrNode_parent(existing_child)) = TrNode_next(existing_child);
} else {
newnode = TrNode_parent(existing_child);
// DATA_DESTRUCT_FUNCTION = destruct_function;
// remove_child_nodes(TrNode_child(newnode));
TrNode_child(newnode) = NULL;
newnode = trie_node_check_insert(newnode, PairEndTag);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
(*construct_function)(newnode);
}
}
if (TrNode_next(existing_child))
TrNode_previous(TrNode_next(existing_child)) = TrNode_previous(existing_child);
if (TrNode_previous(existing_child))
TrNode_next(TrNode_previous(existing_child)) = TrNode_next(existing_child);
TrNode_parent(existing_child) = parent;
TrNode_previous(existing_child) = NULL;
TrNode_next(existing_child) = TrNode_child(parent);
TrNode_previous(TrNode_child(parent)) = existing_child;
TrNode_child(parent) = existing_child;
existing_child = TrNode_child(parent);
} }
search_child = TrNode_next(search_child);
} while(search_child); } while(search_child);
} }
@ -624,7 +651,7 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node,
stack_args_base = stack_args = AUXILIARY_TERM_STACK; stack_args_base = stack_args = AUXILIARY_TERM_STACK;
stack_top = AUXILIARY_TERM_STACK + CURRENT_AUXILIARY_TERM_STACK_SIZE - 1; stack_top = AUXILIARY_TERM_STACK + CURRENT_AUXILIARY_TERM_STACK_SIZE - 1;
node = TrNode_parent(TrNode_parent(node)); node = TrNode_parent(TrNode_parent(node));
// printf("start node: "); displaynode(node); // printf("start node: "); displaynode(node);
if (IS_FUNCTOR_NODE(node)) { if (IS_FUNCTOR_NODE(node)) {
while(IS_FUNCTOR_NODE(node)) while(IS_FUNCTOR_NODE(node))
node = TrNode_parent(node); node = TrNode_parent(node);
@ -633,7 +660,7 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node,
child = TrNode_child(child); child = TrNode_child(child);
} else } else
child = TrNode_child(node); child = TrNode_child(node);
// printf("Chosen start node: "); displaynode(child); // printf("Chosen start node: "); displaynode(child);
if (IS_HASH_NODE(child)) { if (IS_HASH_NODE(child)) {
printf("HASH NODE ERROR: db_tries do not support hash nodes.\n"); printf("HASH NODE ERROR: db_tries do not support hash nodes.\n");
abort(); abort();
@ -729,7 +756,6 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node,
/* nested trie: stop procedure and return nested trie node */ /* nested trie: stop procedure and return nested trie node */
if (IS_FUNCTOR_NODE(TrNode_parent(child)) && (strcmp(YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(child))))), NESTED_TRIE_TERM) == 0)) if (IS_FUNCTOR_NODE(TrNode_parent(child)) && (strcmp(YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(child))))), NESTED_TRIE_TERM) == 0))
return child; return child;
PUSH_DOWN(stack_args, TrNode_entry(child), stack_top); PUSH_DOWN(stack_args, TrNode_entry(child), stack_top);
count++; count++;
if (IS_FUNCTOR_NODE(TrNode_parent(child))) { if (IS_FUNCTOR_NODE(TrNode_parent(child))) {

2
library/tries/core_dbtries.h
View File

@ -225,6 +225,6 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_no
YAP_Term core_get_trie_db_return_term(void); YAP_Term core_get_trie_db_return_term(void);
void core_set_trie_db_return_term(YAP_Term return_value); void core_set_trie_db_return_term(YAP_Term return_value);
YAP_Int core_db_trie_get_optimization_level_count(YAP_Int opt_level); YAP_Int core_db_trie_get_optimization_level_count(YAP_Int opt_level);
void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term); void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
YAP_Int core_get_trie_db_opt_min_prefix(void); YAP_Int core_get_trie_db_opt_min_prefix(void);
void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix); void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix);

406
library/tries/core_tries.c
View File

@ -807,7 +807,7 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) {
fprintf(stderr, "**************************************\n"); fprintf(stderr, "**************************************\n");
fprintf(stderr, " Tries core module: term stack full\n"); fprintf(stderr, " Tries core module: term stack full\n");
fprintf(stderr, "**************************************\n"); fprintf(stderr, "**************************************\n");
fflush(stderr); fflush(stderr);
} }
for (i = index; i > CURRENT_INDEX; i--) for (i = index; i > CURRENT_INDEX; i--)
stack_vars_base[i] = 0; stack_vars_base[i] = 0;
@ -875,10 +875,10 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) {
*cur_node = node; *cur_node = node;
return t; return t;
} else if (t == FloatEndTag) { } else if (t == FloatEndTag) {
volatile union { volatile union {
double f; double f;
YAP_Term p[SIZE_FLOAT_AS_TERM]; YAP_Term p[SIZE_FLOAT_AS_TERM];
} tf; /* to avoid gcc warning */ } tf; /* to avoid gcc warning */
#ifdef TAG_LOW_BITS_32 #ifdef TAG_LOW_BITS_32
node = TrNode_parent(node); node = TrNode_parent(node);
tf.p[1] = TrNode_entry(node); tf.p[1] = TrNode_entry(node);
@ -915,29 +915,29 @@ void remove_entry(TrNode node) {
while (parent) { while (parent) {
if (TrNode_previous(node)) { if (TrNode_previous(node)) {
if (IS_HASH_NODE(TrNode_child(parent))) { if (IS_HASH_NODE(TrNode_child(parent))) {
TrHash hash = (TrHash) TrNode_child(parent); TrHash hash = (TrHash) TrNode_child(parent);
TrHash_num_nodes(hash)--; TrHash_num_nodes(hash)--;
if (TrHash_num_nodes(hash)) { if (TrHash_num_nodes(hash)) {
if (TrNode_next(node)) { if (TrNode_next(node)) {
TrNode_next(TrNode_previous(node)) = TrNode_next(node); TrNode_next(TrNode_previous(node)) = TrNode_next(node);
TrNode_previous(TrNode_next(node)) = TrNode_previous(node); TrNode_previous(TrNode_next(node)) = TrNode_previous(node);
} else { } else {
TrNode_next(TrNode_previous(node)) = NULL; TrNode_next(TrNode_previous(node)) = NULL;
} }
free_trie_node(node); free_trie_node(node);
return; return;
} }
free_hash_buckets(TrHash_buckets(hash), TrHash_num_buckets(hash)); free_hash_buckets(TrHash_buckets(hash), TrHash_num_buckets(hash));
free_trie_hash(hash); free_trie_hash(hash);
} else { } else {
if (TrNode_next(node)) { if (TrNode_next(node)) {
TrNode_next(TrNode_previous(node)) = TrNode_next(node); TrNode_next(TrNode_previous(node)) = TrNode_next(node);
TrNode_previous(TrNode_next(node)) = TrNode_previous(node); TrNode_previous(TrNode_next(node)) = TrNode_previous(node);
} else { } else {
TrNode_next(TrNode_previous(node)) = NULL; TrNode_next(TrNode_previous(node)) = NULL;
} }
free_trie_node(node); free_trie_node(node);
return; return;
} }
} else if (TrNode_next(node)) { } else if (TrNode_next(node)) {
TrNode_child(parent) = TrNode_next(node); TrNode_child(parent) = TrNode_next(node);
@ -963,7 +963,7 @@ void remove_child_nodes(TrNode node) {
bucket = first_bucket + TrHash_num_buckets(hash); bucket = first_bucket + TrHash_num_buckets(hash);
do { do {
if (*--bucket) if (*--bucket)
remove_child_nodes(*bucket); remove_child_nodes(*bucket);
} while (bucket != first_bucket); } while (bucket != first_bucket);
free_hash_buckets(first_bucket, TrHash_num_buckets(hash)); free_hash_buckets(first_bucket, TrHash_num_buckets(hash));
free_trie_hash(hash); free_trie_hash(hash);
@ -971,9 +971,9 @@ void remove_child_nodes(TrNode node) {
} }
if (TrNode_next(node)) if (TrNode_next(node))
remove_child_nodes(TrNode_next(node)); remove_child_nodes(TrNode_next(node));
if (!IS_LEAF_TRIE_NODE(node)) if (!IS_LEAF_TRIE_NODE(node)) {
remove_child_nodes(TrNode_child(node)); remove_child_nodes(TrNode_child(node));
else { } else {
if (DATA_DESTRUCT_FUNCTION) if (DATA_DESTRUCT_FUNCTION)
(*DATA_DESTRUCT_FUNCTION)(node); (*DATA_DESTRUCT_FUNCTION)(node);
DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
@ -998,10 +998,10 @@ TrNode copy_child_nodes(TrNode parent_dest, TrNode child_source) {
do { do {
bucket_dest--; bucket_dest--;
if (*--bucket_source) { if (*--bucket_source) {
*bucket_dest = copy_child_nodes(parent_dest, *bucket_source); *bucket_dest = copy_child_nodes(parent_dest, *bucket_source);
TrNode_previous(*bucket_dest) = AS_TR_NODE_NEXT(bucket_dest); TrNode_previous(*bucket_dest) = AS_TR_NODE_NEXT(bucket_dest);
} else } else
*bucket_dest = NULL; *bucket_dest = NULL;
} while (bucket_source != first_bucket_source); } while (bucket_source != first_bucket_source);
return (TrNode) hash_dest; return (TrNode) hash_dest;
} }
@ -1039,18 +1039,18 @@ void traverse_and_add(TrNode parent_dest, TrNode parent_source) {
do { do {
child_source = *--bucket_source; child_source = *--bucket_source;
while (child_source) { while (child_source) {
/* parent_dest is not a leaf node */ /* parent_dest is not a leaf node */
child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check(parent_dest, TrNode_entry(child_source));
if (child_dest) { if (child_dest) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_add(child_dest, child_source); traverse_and_add(child_dest, child_source);
} }
child_source = TrNode_next(child_source); child_source = TrNode_next(child_source);
} }
} while (bucket_source != first_bucket_source); } while (bucket_source != first_bucket_source);
return; return;
@ -1060,12 +1060,12 @@ void traverse_and_add(TrNode parent_dest, TrNode parent_source) {
child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check(parent_dest, TrNode_entry(child_source));
if (child_dest) { if (child_dest) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_add(child_dest, child_source); traverse_and_add(child_dest, child_source);
} }
child_source = TrNode_next(child_source); child_source = TrNode_next(child_source);
} }
@ -1088,27 +1088,27 @@ void traverse_and_join(TrNode parent_dest, TrNode parent_source) {
do { do {
child_source = *--bucket_source; child_source = *--bucket_source;
while (child_source) { while (child_source) {
/* parent_dest is not a leaf node */ /* parent_dest is not a leaf node */
child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check(parent_dest, TrNode_entry(child_source));
if (child_dest) { if (child_dest) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_join(child_dest, child_source); traverse_and_join(child_dest, child_source);
} else { } else {
child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source));
if (IS_LEAF_TRIE_NODE(child_source)) { if (IS_LEAF_TRIE_NODE(child_source)) {
MARK_AS_LEAF_TRIE_NODE(child_dest); MARK_AS_LEAF_TRIE_NODE(child_dest);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
if (DATA_COPY_FUNCTION) if (DATA_COPY_FUNCTION)
(*DATA_COPY_FUNCTION)(child_dest, child_source); (*DATA_COPY_FUNCTION)(child_dest, child_source);
} else } else
TrNode_child(child_dest) = copy_child_nodes(child_dest, TrNode_child(child_source)); TrNode_child(child_dest) = copy_child_nodes(child_dest, TrNode_child(child_source));
} }
child_source = TrNode_next(child_source); child_source = TrNode_next(child_source);
} }
} while (bucket_source != first_bucket_source); } while (bucket_source != first_bucket_source);
return; return;
@ -1118,19 +1118,19 @@ void traverse_and_join(TrNode parent_dest, TrNode parent_source) {
child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check(parent_dest, TrNode_entry(child_source));
if (child_dest) { if (child_dest) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_join(child_dest, child_source); traverse_and_join(child_dest, child_source);
} else { } else {
child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source)); child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source));
if (IS_LEAF_TRIE_NODE(child_source)) { if (IS_LEAF_TRIE_NODE(child_source)) {
MARK_AS_LEAF_TRIE_NODE(child_dest); MARK_AS_LEAF_TRIE_NODE(child_dest);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
if (DATA_COPY_FUNCTION) if (DATA_COPY_FUNCTION)
(*DATA_COPY_FUNCTION)(child_dest, child_source); (*DATA_COPY_FUNCTION)(child_dest, child_source);
} else } else
TrNode_child(child_dest) = copy_child_nodes(child_dest, TrNode_child(child_source)); TrNode_child(child_dest) = copy_child_nodes(child_dest, TrNode_child(child_source));
} }
@ -1155,27 +1155,27 @@ void traverse_and_intersect(TrNode parent_dest, TrNode parent_source) {
do { do {
child_dest = *--bucket_dest; child_dest = *--bucket_dest;
while (child_dest) { while (child_dest) {
child_next = TrNode_next(child_dest); child_next = TrNode_next(child_dest);
/* parent_source is not a leaf node */ /* parent_source is not a leaf node */
child_source = trie_node_check(parent_source, TrNode_entry(child_dest)); child_source = trie_node_check(parent_source, TrNode_entry(child_dest));
if (child_source) { if (child_source) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_intersect(child_dest, child_source); traverse_and_intersect(child_dest, child_source);
} else { } else {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
if (DATA_DESTRUCT_FUNCTION) if (DATA_DESTRUCT_FUNCTION)
(*DATA_DESTRUCT_FUNCTION)(child_dest); (*DATA_DESTRUCT_FUNCTION)(child_dest);
DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
} else } else
remove_child_nodes(TrNode_child(child_dest)); remove_child_nodes(TrNode_child(child_dest));
remove_entry(child_dest); remove_entry(child_dest);
} }
child_dest = child_next; child_dest = child_next;
} }
} while (bucket_dest != first_bucket_dest); } while (bucket_dest != first_bucket_dest);
return; return;
@ -1186,19 +1186,19 @@ void traverse_and_intersect(TrNode parent_dest, TrNode parent_source) {
child_source = trie_node_check(parent_source, TrNode_entry(child_dest)); child_source = trie_node_check(parent_source, TrNode_entry(child_dest));
if (child_source) { if (child_source) {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
/* child_source is a leaf node */ /* child_source is a leaf node */
if (DATA_ADD_FUNCTION) if (DATA_ADD_FUNCTION)
(*DATA_ADD_FUNCTION)(child_dest, child_source); (*DATA_ADD_FUNCTION)(child_dest, child_source);
} else } else
/* child_dest and child_source are not leaf nodes */ /* child_dest and child_source are not leaf nodes */
traverse_and_intersect(child_dest, child_source); traverse_and_intersect(child_dest, child_source);
} else { } else {
if (IS_LEAF_TRIE_NODE(child_dest)) { if (IS_LEAF_TRIE_NODE(child_dest)) {
if (DATA_DESTRUCT_FUNCTION) if (DATA_DESTRUCT_FUNCTION)
(*DATA_DESTRUCT_FUNCTION)(child_dest); (*DATA_DESTRUCT_FUNCTION)(child_dest);
DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
} else } else
remove_child_nodes(TrNode_child(child_dest)); remove_child_nodes(TrNode_child(child_dest));
remove_entry(child_dest); remove_entry(child_dest);
} }
child_dest = child_next; child_dest = child_next;
@ -1223,17 +1223,17 @@ YAP_Int traverse_and_count_common_entries(TrNode parent1, TrNode parent2) {
do { do {
child1 = *--bucket; child1 = *--bucket;
while (child1) { while (child1) {
/* parent2 is not a leaf node */ /* parent2 is not a leaf node */
child2 = trie_node_check(parent2, TrNode_entry(child1)); child2 = trie_node_check(parent2, TrNode_entry(child1));
if (child2) { if (child2) {
if (IS_LEAF_TRIE_NODE(child1)) if (IS_LEAF_TRIE_NODE(child1))
/* child2 is a leaf node */ /* child2 is a leaf node */
count++; count++;
else else
/* child1 and child2 are not leaf nodes */ /* child1 and child2 are not leaf nodes */
count += traverse_and_count_common_entries(child1, child2); count += traverse_and_count_common_entries(child1, child2);
} }
child1 = TrNode_next(child1); child1 = TrNode_next(child1);
} }
} while (bucket != first_bucket); } while (bucket != first_bucket);
return count; return count;
@ -1243,11 +1243,11 @@ YAP_Int traverse_and_count_common_entries(TrNode parent1, TrNode parent2) {
child2 = trie_node_check(parent2, TrNode_entry(child1)); child2 = trie_node_check(parent2, TrNode_entry(child1));
if (child2) { if (child2) {
if (IS_LEAF_TRIE_NODE(child1)) if (IS_LEAF_TRIE_NODE(child1))
/* child2 is a leaf node */ /* child2 is a leaf node */
count++; count++;
else else
/* child1 and child2 are not leaf nodes */ /* child1 and child2 are not leaf nodes */
count += traverse_and_count_common_entries(child1, child2); count += traverse_and_count_common_entries(child1, child2);
} }
child1 = TrNode_next(child1); child1 = TrNode_next(child1);
} }
@ -1329,7 +1329,7 @@ void traverse_and_save(TrNode node, FILE *file, int float_block) {
do { do {
if (*--bucket) { if (*--bucket) {
node = *bucket; node = *bucket;
traverse_and_save(node, file, float_block); traverse_and_save(node, file, float_block);
} }
} while (bucket != first_bucket); } while (bucket != first_bucket);
return; return;
@ -1356,23 +1356,23 @@ void traverse_and_save(TrNode node, FILE *file, int float_block) {
int index; int index;
for (index = 0; index <= CURRENT_INDEX; index++) for (index = 0; index <= CURRENT_INDEX; index++)
if (AUXILIARY_TERM_STACK[index] == t) if (AUXILIARY_TERM_STACK[index] == t)
break; break;
if (index > CURRENT_INDEX) { if (index > CURRENT_INDEX) {
CURRENT_INDEX = index; CURRENT_INDEX = index;
if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE)
expand_auxiliary_term_stack(); expand_auxiliary_term_stack();
AUXILIARY_TERM_STACK[CURRENT_INDEX] = t; AUXILIARY_TERM_STACK[CURRENT_INDEX] = t;
if (YAP_IsAtomTerm(t)) if (YAP_IsAtomTerm(t))
fprintf(file, UInt_FORMAT " %d %s%c ", ATOM_SAVE_MARK, index, YAP_AtomName(YAP_AtomOfTerm(t)), '\0'); fprintf(file, UInt_FORMAT " %d %s%c ", ATOM_SAVE_MARK, index, YAP_AtomName(YAP_AtomOfTerm(t)), '\0');
else /* (ApplTag & t) */ else /* (ApplTag & t) */
fprintf(file, UInt_FORMAT " %d %s " UInt_FORMAT " ", FUNCTOR_SAVE_MARK, index, fprintf(file, UInt_FORMAT " %d %s " UInt_FORMAT " ", FUNCTOR_SAVE_MARK, index,
YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & t))), YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & t))),
YAP_ArityOfFunctor((YAP_Functor)(~ApplTag & t))); YAP_ArityOfFunctor((YAP_Functor)(~ApplTag & t)));
} else } else
if (YAP_IsAtomTerm(t)) if (YAP_IsAtomTerm(t))
fprintf(file, UInt_FORMAT " %d ", ATOM_SAVE_MARK, index); fprintf(file, UInt_FORMAT " %d ", ATOM_SAVE_MARK, index);
else else
fprintf(file, UInt_FORMAT " %d ", FUNCTOR_SAVE_MARK, index); fprintf(file, UInt_FORMAT " %d ", FUNCTOR_SAVE_MARK, index);
} }
if (IS_LEAF_TRIE_NODE(node)) { if (IS_LEAF_TRIE_NODE(node)) {
fprintf(file, "- "); fprintf(file, "- ");
@ -1415,34 +1415,34 @@ void traverse_and_load(TrNode parent, FILE *file) {
int index; int index;
n = fscanf(file, "%d", &index); n = fscanf(file, "%d", &index);
if (index > CURRENT_INDEX) { if (index > CURRENT_INDEX) {
char atom[1000]; char atom[1000];
if (CURRENT_LOAD_VERSION == 2) { if (CURRENT_LOAD_VERSION == 2) {
char *ptr, ch; char *ptr, ch;
ptr = atom; ptr = atom;
fgetc(file); /* skip the first empty space */ fgetc(file); /* skip the first empty space */
while ((ch = fgetc(file))) while ((ch = fgetc(file)))
*ptr++ = ch; *ptr++ = ch;
*ptr = '\0'; *ptr = '\0';
} else if (CURRENT_LOAD_VERSION == 1) { } else if (CURRENT_LOAD_VERSION == 1) {
n = fscanf(file, "%s", atom); n = fscanf(file, "%s", atom);
} }
CURRENT_INDEX = index; CURRENT_INDEX = index;
if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE)
expand_auxiliary_term_stack(); expand_auxiliary_term_stack();
AUXILIARY_TERM_STACK[CURRENT_INDEX] = YAP_MkAtomTerm(YAP_LookupAtom(atom)); AUXILIARY_TERM_STACK[CURRENT_INDEX] = YAP_MkAtomTerm(YAP_LookupAtom(atom));
} }
t = AUXILIARY_TERM_STACK[index]; t = AUXILIARY_TERM_STACK[index];
} else if (t == FUNCTOR_SAVE_MARK) { } else if (t == FUNCTOR_SAVE_MARK) {
int index; int index;
n = fscanf(file, "%d", &index); n = fscanf(file, "%d", &index);
if (index > CURRENT_INDEX) { if (index > CURRENT_INDEX) {
char atom[1000]; char atom[1000];
int arity; int arity;
n = fscanf(file, "%s %d", atom, &arity); n = fscanf(file, "%s %d", atom, &arity);
CURRENT_INDEX = index; CURRENT_INDEX = index;
if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE)
expand_auxiliary_term_stack(); expand_auxiliary_term_stack();
AUXILIARY_TERM_STACK[CURRENT_INDEX] = ApplTag | ((YAP_Term) YAP_MkFunctor(YAP_LookupAtom(atom), arity)); AUXILIARY_TERM_STACK[CURRENT_INDEX] = ApplTag | ((YAP_Term) YAP_MkFunctor(YAP_LookupAtom(atom), arity));
} }
t = AUXILIARY_TERM_STACK[index]; t = AUXILIARY_TERM_STACK[index];
} else if (t == FLOAT_SAVE_MARK) } else if (t == FLOAT_SAVE_MARK)
@ -1473,15 +1473,15 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m
if (*--bucket) { if (*--bucket) {
node = *bucket; node = *bucket;
traverse_and_print(node, arity, str, str_index, mode); traverse_and_print(node, arity, str, str_index, mode);
memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1)); memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1));
if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) {
/* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */
if (str_index > 0 && str[str_index - 1] != '[') if (str_index > 0 && str[str_index - 1] != '[')
str[str_index - 1] = ','; str[str_index - 1] = ',';
/* restore possible PairEndTermTag side-effect */ /* restore possible PairEndTermTag side-effect */
if (str[last_pair_mark] == '|') if (str[last_pair_mark] == '|')
str[last_pair_mark] = ','; str[last_pair_mark] = ',';
} }
} }
} while (bucket != first_bucket); } while (bucket != first_bucket);
free(current_arity); free(current_arity);
@ -1496,10 +1496,10 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m
if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) {
/* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */
if (str_index > 0 && str[str_index - 1] != '[') if (str_index > 0 && str[str_index - 1] != '[')
str[str_index - 1] = ','; str[str_index - 1] = ',';
/* restore possible PairEndTermTag side-effect */ /* restore possible PairEndTermTag side-effect */
if (str[last_pair_mark] == '|') if (str[last_pair_mark] == '|')
str[last_pair_mark] = ','; str[last_pair_mark] = ',';
} }
free(current_arity); free(current_arity);
} }
@ -1534,13 +1534,13 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m
arity[0]--; arity[0]--;
while (arity[0]) { while (arity[0]) {
if (arity[arity[0]] == 1) { if (arity[arity[0]] == 1) {
str_index += sprintf(& str[str_index], ")"); str_index += sprintf(& str[str_index], ")");
arity[0]--; arity[0]--;
} else { } else {
if (arity[arity[0]] > 1) if (arity[arity[0]] > 1)
arity[arity[0]]--; arity[arity[0]]--;
str_index += sprintf(& str[str_index], ","); str_index += sprintf(& str[str_index], ",");
break; break;
} }
} }
mode = TRIE_PRINT_NORMAL; mode = TRIE_PRINT_NORMAL;
@ -1548,39 +1548,39 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m
str_index += sprintf(& str[str_index], "VAR" UInt_FORMAT, TrieVarIndex(t)); str_index += sprintf(& str[str_index], "VAR" UInt_FORMAT, TrieVarIndex(t));
while (arity[0]) { while (arity[0]) {
if (arity[arity[0]] == 1) { if (arity[arity[0]] == 1) {
str_index += sprintf(& str[str_index], ")"); str_index += sprintf(& str[str_index], ")");
arity[0]--; arity[0]--;
} else { } else {
if (arity[arity[0]] > 1) if (arity[arity[0]] > 1)
arity[arity[0]]--; arity[arity[0]]--;
str_index += sprintf(& str[str_index], ","); str_index += sprintf(& str[str_index], ",");
break; break;
} }
} }
} else if (YAP_IsAtomTerm(t)) { } else if (YAP_IsAtomTerm(t)) {
str_index += sprintf(& str[str_index], "%s", YAP_AtomName(YAP_AtomOfTerm(t))); str_index += sprintf(& str[str_index], "%s", YAP_AtomName(YAP_AtomOfTerm(t)));
while (arity[0]) { while (arity[0]) {
if (arity[arity[0]] == 1) { if (arity[arity[0]] == 1) {
str_index += sprintf(& str[str_index], ")"); str_index += sprintf(& str[str_index], ")");
arity[0]--; arity[0]--;
} else { } else {
if (arity[arity[0]] > 1) if (arity[arity[0]] > 1)
arity[arity[0]]--; arity[arity[0]]--;
str_index += sprintf(& str[str_index], ","); str_index += sprintf(& str[str_index], ",");
break; break;
} }
} }
} else if (YAP_IsIntTerm(t)) { } else if (YAP_IsIntTerm(t)) {
str_index += sprintf(& str[str_index], UInt_FORMAT , YAP_IntOfTerm(t)); str_index += sprintf(& str[str_index], UInt_FORMAT , YAP_IntOfTerm(t));
while (arity[0]) { while (arity[0]) {
if (arity[arity[0]] == 1) { if (arity[arity[0]] == 1) {
str_index += sprintf(& str[str_index], ")"); str_index += sprintf(& str[str_index], ")");
arity[0]--; arity[0]--;
} else { } else {
if (arity[arity[0]] > 1) if (arity[arity[0]] > 1)
arity[arity[0]]--; arity[arity[0]]--;
str_index += sprintf(& str[str_index], ","); str_index += sprintf(& str[str_index], ",");
break; break;
} }
} }
} else if (YAP_IsPairTerm(t)) { } else if (YAP_IsPairTerm(t)) {
@ -1598,23 +1598,23 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m
arity[arity[0]] = -1; arity[arity[0]] = -1;
} else { } else {
if (t == PairEndEmptyTag) if (t == PairEndEmptyTag)
str[str_index - 1] = ']'; str[str_index - 1] = ']';
else if (t == PairEndTermTag) { else if (t == PairEndTermTag) {
str[last_pair_mark] = '|'; str[last_pair_mark] = '|';
str[str_index - 1] = ']'; str[str_index - 1] = ']';
} else /* (t == CommaEndTag) */ } else /* (t == CommaEndTag) */
str[str_index - 1] = ')'; str[str_index - 1] = ')';
arity[0]--; arity[0]--;
while (arity[0]) { while (arity[0]) {
if (arity[arity[0]] == 1) { if (arity[arity[0]] == 1) {
str_index += sprintf(& str[str_index], ")"); str_index += sprintf(& str[str_index], ")");
arity[0]--; arity[0]--;
} else { } else {
if (arity[arity[0]] > 1) if (arity[arity[0]] > 1)
arity[arity[0]]--; arity[arity[0]]--;
str_index += sprintf(& str[str_index], ","); str_index += sprintf(& str[str_index], ",");
break; break;
} }
} }
} }
} else if (ApplTag & t) { } else if (ApplTag & t) {

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)

7
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,7 +723,7 @@ 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;
@ -729,6 +731,7 @@ double CalcProbability(extmanager MyManager, DdNode *Current) {
char *curnode; //, *dynvalue; char *curnode; //, *dynvalue;
double lvalue, hvalue, tvalue; double lvalue, hvalue, tvalue;
// density_integral dynvalue_parsed; // 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);
@ -815,7 +818,7 @@ 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;
QueueIteratorAdvance(qiter); QueueIteratorAdvance(qiter);

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),

113
pl/debug.yap
View File

@ -57,18 +57,18 @@ programs:
Switches the debugger on. Switches the debugger on.
+ debugging + debugging
Outputs status information about the debugger which includes the leash Outputs status information about the debugger which includes the leash
mode and the existing spy-points, when the debugger is on. mode and the existing spy-points, when the debugger is on.
+ nodebug + nodebug
Switches the debugger off. Switches the debugger off.
*/ */
@ -164,14 +164,14 @@ mode and the existing spy-points, when the debugger is on.
'$do_suspy'(S,F,N,T,M) :- '$do_suspy'(S,F,N,T,M) :-
'$suspy2'(S,F,N,T,M). '$suspy2'(S,F,N,T,M).
'$suspy2'(spy,F,N,T,M) :- '$suspy2'(spy,F,N,T,M) :-
recorded('$spy','$spy'(T,M),_), !, recorded('$spy','$spy'(T,M),_), !,
print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,already)). print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,already)).
'$suspy2'(spy,F,N,T,M) :- !, '$suspy2'(spy,F,N,T,M) :- !,
recorda('$spy','$spy'(T,M),_), recorda('$spy','$spy'(T,M),_),
'$set_spy'(T,M), '$set_spy'(T,M),
print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,ok)). print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,ok)).
'$suspy2'(nospy,F,N,T,M) :- '$suspy2'(nospy,F,N,T,M) :-
recorded('$spy','$spy'(T,M),R), !, recorded('$spy','$spy'(T,M),R), !,
erase(R), erase(R),
'$rm_spy'(T,M), '$rm_spy'(T,M),
@ -182,17 +182,17 @@ 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
specifications. Each one must be of the form _Name/Arity_ specifications. Each one must be of the form _Name/Arity_
or _Name_. In the last case all predicates with the name or _Name_. In the last case all predicates with the name
_Name_ will be spied. As in C-Prolog, system predicates and _Name_ will be spied. As in C-Prolog, system predicates and
predicates written in C, cannot be spied. predicates written in C, cannot be spied.
*/ */
spy Spec :- spy Spec :-
'$init_debugger', '$init_debugger',
@ -208,7 +208,7 @@ predicates written in C, cannot be spied.
Removes spy-points from all predicates specified by _P_. Removes spy-points from all predicates specified by _P_.
The possible forms for _P_ are the same as in `spy P`. The possible forms for _P_ are the same as in `spy P`.
*/ */
nospy Spec :- nospy Spec :-
'$init_debugger', '$init_debugger',
@ -218,12 +218,12 @@ The possible forms for _P_ are the same as in `spy P`.
'$suspy'(L, nospy, M), fail. '$suspy'(L, nospy, M), fail.
nospy _. nospy _.
/** @pred nospyall /** @pred nospyall
Removes all existing spy-points. Removes all existing spy-points.
*/ */
nospyall :- nospyall :-
'$init_debugger', '$init_debugger',
@ -260,12 +260,12 @@ debug :-
% %
/** @pred trace /** @pred trace
Switches on the debugger and enters tracing mode. Switches on the debugger and enters tracing mode.
*/ */
trace :- trace :-
'$init_debugger', '$init_debugger',
@ -276,7 +276,7 @@ trace :-
print_message(informational,debug(trace)), print_message(informational,debug(trace)),
'$creep'. '$creep'.
/** @pred notrace /** @pred notrace
Ends tracing and exits the debugger. This is the same as Ends tracing and exits the debugger. This is the same as
@ -297,7 +297,7 @@ notrace :-
-----------------------------------------------------------------------------*/ -----------------------------------------------------------------------------*/
/** @pred leash(+ _M_) /** @pred leash(+ _M_)
Sets leashing mode to _M_. Sets leashing mode to _M_.
@ -323,13 +323,13 @@ never prompt, same as `off`
The initial leashing mode is `full`. The initial leashing mode is `full`.
The user may also specify directly the debugger ports The user may also specify directly the debugger ports
where he wants to be prompted. If the argument for leash where he wants to be prompted. If the argument for leash
is a number _N_, each of lower four bits of the number is used to is a number _N_, each of lower four bits of the number is used to
control prompting at one the ports of the box model. The debugger will control prompting at one the ports of the box model. The debugger will
prompt according to the following conditions: prompt according to the following conditions:
+ if `N/\ 1 =\= 0` prompt on fail + if `N/\ 1 =\= 0` prompt on fail
+ if `N/\ 2 =\= 0` prompt on redo + if `N/\ 2 =\= 0` prompt on redo
+ if `N/\ 4 =\= 0` prompt on exit + if `N/\ 4 =\= 0` prompt on exit
+ if `N/\ 8 =\= 0` prompt on call + if `N/\ 8 =\= 0` prompt on call
@ -428,10 +428,10 @@ model, execution is seen at the procedure level: each activation of a
procedure is seen as a box with control flowing into and out of that procedure is seen as a box with control flowing into and out of that
box. box.
In the four port model control is caught at four key points: before In the four port model control is caught at four key points: before
entering the procedure, after exiting the procedure (meaning successful entering the procedure, after exiting the procedure (meaning successful
evaluation of all queries activated by the procedure), after backtracking but evaluation of all queries activated by the procedure), after backtracking but
before trying new alternative to the procedure and after failing the before trying new alternative to the procedure and after failing the
procedure. Each one of these points is named a port: procedure. Each one of these points is named a port:
~~~~~ ~~~~~
@ -483,20 +483,20 @@ control and show a message of the form:
The debugger message will be shown while creeping, or at spy-points, The debugger message will be shown while creeping, or at spy-points,
and it includes four or five fields: and it includes four or five fields:
+ +
The first three characters are used to point out special states of the The first three characters are used to point out special states of the
debugger. If the port is exit and the first character is '?', the debugger. If the port is exit and the first character is '?', the
current call is non-deterministic, that is, it still has alternatives to current call is non-deterministic, that is, it still has alternatives to
be tried. If the second character is a `\*`, execution is at a be tried. If the second character is a `\*`, execution is at a
spy-point. If the third character is a `>`, execution has returned spy-point. If the third character is a `>`, execution has returned
either from a skip, a fail or a redo command. either from a skip, a fail or a redo command.
+ +
The second field is the activation number, and uniquely identifies the The second field is the activation number, and uniquely identifies the
activation. The number will start from 1 and will be incremented for activation. The number will start from 1 and will be incremented for
each activation found by the debugger. each activation found by the debugger.
+ +
In the third field, the debugger shows the active port. In the third field, the debugger shows the active port.
+ +
The fourth field is the goal. The goal is written by The fourth field is the goal. The goal is written by
`write_term/3` on the standard error stream, using the options `write_term/3` on the standard error stream, using the options
given by debugger_print_options. given by debugger_print_options.
@ -508,8 +508,8 @@ character, followed by a return. By default, only the call and redo
entries are leashed, but the leash/1 predicate can be used in entries are leashed, but the leash/1 predicate can be used in
order to make the debugger stop where needed. order to make the debugger stop where needed.
There are several commands available, but the user only needs to There are several commands available, but the user only needs to
remember the help command, which is `h`. This command shows all the remember the help command, which is `h`. This command shows all the
available options, which are: available options, which are:
+ `c` - creep + `c` - creep
@ -551,7 +551,7 @@ kept; useful if skip becomes slow.
+ `f [ _GoalId_]` - fail + `f [ _GoalId_]` - fail
If given no argument, forces YAP to fail the goal, skipping the fail If given no argument, forces YAP to fail the goal, skipping the fail
port and backtracking to the parent. port and backtracking to the parent.
If <tt>f</tt> receives a goal number as If <tt>f</tt> receives a goal number as
the argument, the command fails all the way to the goal. If goal _GoalId_ has completed execution, YAP fails until meeting the first active ancestor. the argument, the command fails all the way to the goal. If goal _GoalId_ has completed execution, YAP fails until meeting the first active ancestor.
@ -620,7 +620,7 @@ more information about `write_depth/2` ( (see Input/Output Control)).
+ `A` - alternatives + `A` - alternatives
show the list of backtrack points in the current execution. show the list of backtrack points in the current execution.
+ `g [ _N_]` + `g [ _N_]`
@ -647,7 +647,7 @@ be lost.
% Skip Create CP Create CP % Skip Create CP Create CP
% FastLeap Stop Ignore % FastLeap Stop Ignore
% FastIgnore Ignore Ignore % FastIgnore Ignore Ignore
% flag description initial possible values % flag description initial possible values
@ -669,7 +669,7 @@ be lost.
'$swi_current_prolog_flag'(debug, false), !, '$swi_current_prolog_flag'(debug, false), !,
'$execute_nonstop'(G,Mod). '$execute_nonstop'(G,Mod).
'$spy'([Mod|G]) :- '$spy'([Mod|G]) :-
CP is '$last_choice_pt', CP is '$last_choice_pt',
'$do_spy'(G, Mod, CP, spy). '$do_spy'(G, Mod, CP, spy).
% last argument to do_spy says that we are at the end of a context. It % last argument to do_spy says that we are at the end of a context. It
@ -724,7 +724,7 @@ be lost.
nb_setval('$spy_gn',L1), /* and save it globaly */ nb_setval('$spy_gn',L1), /* and save it globaly */
b_getval('$spy_glist',History), /* get goal list */ b_getval('$spy_glist',History), /* get goal list */
b_setval('$spy_glist',[info(L,Module,G,_Retry,_Det,_HasFoundAnswers)|History]), /* and update it */ b_setval('$spy_glist',[info(L,Module,G,_Retry,_Det,_HasFoundAnswers)|History]), /* and update it */
'$loop_spy'(L, G, Module, CalledFromDebugger). '$loop_spy'(L, G, Module, CalledFromDebugger).
% we are skipping, so we can just call the goal, % we are skipping, so we can just call the goal,
% while leaving the minimal structure in place. % while leaving the minimal structure in place.
@ -734,7 +734,7 @@ be lost.
Module, error(Event,Context), Module, error(Event,Context),
'$loop_spy_event'(error(Event,Context), GoalNumber, G, Module, CalledFromDebugger)). '$loop_spy_event'(error(Event,Context), GoalNumber, G, Module, CalledFromDebugger)).
% handle weird things happening in the debugger. % handle weird things happening in the debugger.
'$loop_spy_event'('$pass'(Event), _, _, _, _) :- !, '$loop_spy_event'('$pass'(Event), _, _, _, _) :- !,
throw(Event). throw(Event).
'$loop_spy_event'(error('$retry_spy'(G0),_), GoalNumber, G, Module, CalledFromDebugger) :- '$loop_spy_event'(error('$retry_spy'(G0),_), GoalNumber, G, Module, CalledFromDebugger) :-
@ -773,8 +773,8 @@ be lost.
'$continue_debugging'(fail, CalledFromDebugger), '$continue_debugging'(fail, CalledFromDebugger),
fail. fail.
% if we are in % if we are in
'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :- '$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :-
/* the following choice point is where the predicate is called */ /* the following choice point is where the predicate is called */
b_getval('$spy_glist',[Info|_]), /* get goal list */ b_getval('$spy_glist',[Info|_]), /* get goal list */
Info = info(_,_,_,Retry,Det,false), Info = info(_,_,_,Retry,Det,false),
@ -805,7 +805,7 @@ be lost.
; ;
true true
), ),
'$continue_debugging'(exit, CalledFromDebugger) '$continue_debugging'(exit, CalledFromDebugger)
; ;
% make sure we are in system mode when running the debugger. % make sure we are in system mode when running the debugger.
/* backtracking from exit */ /* backtracking from exit */
@ -828,7 +828,7 @@ be lost.
/* fail port */ /* fail port */
fail fail
). ).
'$enter_goal'(GoalNumber, G, Module) :- '$enter_goal'(GoalNumber, G, Module) :-
'$zip'(GoalNumber, G, Module), !. '$zip'(GoalNumber, G, Module), !.
'$enter_goal'(GoalNumber, G, Module) :- '$enter_goal'(GoalNumber, G, Module) :-
@ -857,10 +857,10 @@ be lost.
-> ->
StopPoint < GoalNumber StopPoint < GoalNumber
). ).
%
%
'$spycall'(G, M, _, _) :- '$spycall'(G, M, _, _) :-
nb_getval('$debug_jump',true), nb_getval('$debug_jump',true),
!, !,
@ -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) :-
@ -941,7 +941,7 @@ be lost.
'$swi_set_prolog_flag'(debug, false), '$swi_set_prolog_flag'(debug, false),
repeat, repeat,
'$trace_msg'(P,G,Module,L,Deterministic), '$trace_msg'(P,G,Module,L,Deterministic),
( (
'$unleashed'(P) -> '$unleashed'(P) ->
'$action'(10,P,L,G,Module,Debug), '$action'(10,P,L,G,Module,Debug),
put_code(user_error, 10) put_code(user_error, 10)
@ -975,7 +975,7 @@ be lost.
-> ->
GW = Module:G GW = Module:G
; ;
GW = G GW = G
), ),
format(user_error,'~a~a~a (~d) ~q:',[Det,CSPY,SLL,L,P0]), format(user_error,'~a~a~a (~d) ~q:',[Det,CSPY,SLL,L,P0]),
'$debugger_write'(user_error,GW). '$debugger_write'(user_error,GW).
@ -1086,7 +1086,7 @@ be lost.
'$swi_set_prolog_flag'(debug, true), '$swi_set_prolog_flag'(debug, true),
throw(error('$retry_spy'(ScanNumber),[])). throw(error('$retry_spy'(ScanNumber),[])).
'$action'(0's,P,CallNumber,_,_,on) :- !, % 's skip '$action'(0's,P,CallNumber,_,_,on) :- !, % 's skip
'$skipeol'(0's), % ' '$skipeol'(0's), % '
( (P=call; P=redo) -> ( (P=call; P=redo) ->
nb_setval('$debug_run',CallNumber), nb_setval('$debug_run',CallNumber),
nb_setval('$debug_jump',false) nb_setval('$debug_jump',false)
@ -1142,7 +1142,7 @@ be lost.
'$execute_dgoal'(G). '$execute_dgoal'(G).
'$continue_debugging_goal'(_,G) :- '$continue_debugging_goal'(_,G) :-
'$execute_creep_dgoal'(G). '$execute_creep_dgoal'(G).
'$execute_dgoal'('$execute_nonstop'(G,M)) :- '$execute_dgoal'('$execute_nonstop'(G,M)) :-
'$execute_nonstop'(G,M). '$execute_nonstop'(G,M).
'$execute_dgoal'('$execute_clause'(G, M, R, CP)) :- '$execute_dgoal'('$execute_clause'(G, M, R, CP)) :-
@ -1199,7 +1199,7 @@ be lost.
format(user_error,'^ view subg ^^ view using~n', []), format(user_error,'^ view subg ^^ view using~n', []),
format(user_error,'A choices g [N] ancestors~n', []), format(user_error,'A choices g [N] ancestors~n', []),
format(user_error,'! g execute goal~n', []). format(user_error,'! g execute goal~n', []).
'$ilgl'(C) :- '$ilgl'(C) :-
print_message(warning, trace_command(C)), print_message(warning, trace_command(C)),
print_message(help, trace_help), print_message(help, trace_help),
@ -1229,7 +1229,7 @@ be lost.
NbI is Nb0*10+(C-"0"), NbI is Nb0*10+(C-"0"),
get0(user, NC), get0(user, NC),
'$scan_number3'( NC, NbI, Nb). '$scan_number3'( NC, NbI, Nb).
'$print_deb_sterm'(G) :- '$print_deb_sterm'(G) :-
'$get_sterm_list'(L), !, '$get_sterm_list'(L), !,
'$deb_get_sterm_in_g'(L,G,A), '$deb_get_sterm_in_g'(L,G,A),
@ -1285,7 +1285,7 @@ be lost.
recorda('$print_options','$debugger'([max_depth(D)|LN]),_). recorda('$print_options','$debugger'([max_depth(D)|LN]),_).
'$set_deb_depth'(D) :- '$set_deb_depth'(D) :-
recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(D)]),_). recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(D)]),_).
'$delete_if_there'([], _, []). '$delete_if_there'([], _, []).
'$delete_if_there'([T|L], T, LN) :- !, '$delete_if_there'([T|L], T, LN) :- !,
'$delete_if_there'(L, T, LN). '$delete_if_there'(L, T, LN).
@ -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(_).

169
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,_,_),_),
@ -1163,82 +1168,39 @@ predicate_erased_statistics(P,NCls,Sz,ISz) :-
/** @pred current_predicate( _A_, _P_) /** @pred current_predicate( _A_, _P_)
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_.
Notice that this predicatae always reports alll built-ins that are available to a module.
Also, it is possible to enumerate over all modules by allowing the module to be unbound:
~~~~~~
?- system_predicate(A,M:P).
~~~~~~
will report all built-in predicates _P_ in the system, independently of their module _M_.
*/ */
system_predicate( A, P ) :- system_predicate(A,T) :-
strip_module(P, M, P0), '$ground_module'(T, M, T0),
( atom(A) -> (
( '$current_predicate'(A, M, T0, Flags)
atom( M ) -> ;
( '$current_system_predicate_for_atom'( M, A, P0 ) '$current_predicate'(A, prolog, T0, Flags)
; ),
'$imported_system_predicate'( M, A, P0 ) Flags /\ 0x00004000 =\= 0,
) \+ '$hidden'(A).
;
'$current_system_predicate_for_atom'( M , A , P0 )
)
;
atom( M ) ->
( '$current_system_predicate'( M, A, P )
;
'$imported_system_predicate'( M, A, P )
)
;
/* var(M) */
'$current_system_predicate'( M , A , P )
).
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
@ -1246,65 +1208,32 @@ system_predicate( A, 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'(_, _).
@ -1328,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