diff --git a/C/absmi.c b/C/absmi.c index dbdec12f1..5e8f35d35 100755 --- a/C/absmi.c +++ b/C/absmi.c @@ -951,7 +951,7 @@ interrupt_execute( USES_REGS1 ) } if (PP) UNLOCKPE(1,PP); 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; } SET_ASP(YENV, E_CB*sizeof(CELL)); @@ -979,7 +979,7 @@ interrupt_call( USES_REGS1 ) if (PP) UNLOCKPE(1,PP); PP = P->y_u.Osbpp.p0; if (Yap_only_has_signal(YAP_CREEP_SIGNAL) && - (PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) ) { + (PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) ) { return 2; } SET_ASP(YENV, P->y_u.Osbpp.s); @@ -1238,7 +1238,7 @@ interrupt_dexecute( USES_REGS1 ) if (PP) UNLOCKPE(1,PP); PP = P->y_u.pp.p0; 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; } /* set S for next instructions */ @@ -7830,8 +7830,7 @@ Yap_absmi(int inp) BOp(call_cpred, Osbpp); check_trail(TR); - if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag)) && - !(PREG->y_u.Osbpp.p0->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag))) { + if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag|NoTracePredFlag|HiddenPredFlag))) { CACHE_Y_AS_ENV(YREG); check_stack(NoStackCCall, HR); ENDCACHE_Y_AS_ENV(); diff --git a/C/adtdefs.c b/C/adtdefs.c index fe560bf15..9103f3a64 100755 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -848,7 +848,7 @@ Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) } } if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { - p->ExtraPredFlags |= NoTracePredFlag; + p->PredFlags |= NoTracePredFlag; } p->FunctorOfPred = fe; if (fe->PropsOfFE) { @@ -937,7 +937,7 @@ Yap_NewThreadPred(PredEntry *ap USES_REGS) p->FunctorOfPred = ap->FunctorOfPred; 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)) { - p->ExtraPredFlags |= (NoSpyPredFlag|NoTracePredFlag); + p->PredFlags |= (NoSpyPredFlag|NoTracePredFlag); } 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); @@ -1008,7 +1008,7 @@ Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod) p0 = AbsPredProp(p); p->FunctorOfPred = (Functor)AbsAtom(ae); if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { - p->ExtraPredFlags |= (NoTracePredFlag|NoSpyPredFlag); + p->PredFlags |= (NoTracePredFlag|NoSpyPredFlag); } WRITE_UNLOCK(ae->ARWLock); { diff --git a/C/cdmgr.c b/C/cdmgr.c index 052657cde..8287ecbe2 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -2136,7 +2136,7 @@ Yap_discontiguous( PredEntry *ap USES_REGS ) { register consult_obj *fp; - if (ap->ExtraPredFlags & (DiscontiguousPredFlag|MultiFileFlag)) + if (ap->PredFlags & (DiscontiguousPredFlag|MultiFileFlag)) return FALSE; if (!LOCAL_ConsultSp) { return FALSE; @@ -2339,7 +2339,7 @@ addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref) PELOCK(20,p); pflags = p->PredFlags; /* 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)) || (p->ModuleOfPred == PROLOG_MODULE && @@ -2847,7 +2847,7 @@ p_sys_export( USES_REGS1 ) return (FALSE); } PELOCK(100,pred); - pred->ExtraPredFlags |= SysExportPredFlag; + pred->PredFlags |= SysExportPredFlag; UNLOCKPE(100,pred); return TRUE; } @@ -2868,7 +2868,7 @@ p_is_no_trace( USES_REGS1 ) if (EndOfPAEntr(pe)) return TRUE; PELOCK(36,pe); - if (pe->ExtraPredFlags & NoTracePredFlag) { + if (pe->PredFlags & NoTracePredFlag) { UNLOCKPE(57,pe); return TRUE; } @@ -2886,7 +2886,7 @@ p_set_no_trace( USES_REGS1 ) if (EndOfPAEntr(pe)) return FALSE; PELOCK(36,pe); - pe->ExtraPredFlags |= NoTracePredFlag; + pe->PredFlags |= NoTracePredFlag; UNLOCKPE(57,pe); return TRUE; } @@ -2904,7 +2904,7 @@ Yap_SetNoTrace(char *name, UInt arity, Term tmod) if (EndOfPAEntr(pe)) return FALSE; PELOCK(36,pe); - pe->ExtraPredFlags |= NoTracePredFlag; + pe->PredFlags |= NoTracePredFlag; UNLOCKPE(57,pe); return TRUE; } @@ -3164,7 +3164,7 @@ p_new_discontiguous( USES_REGS1 ) else pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod)); PELOCK(26,pe); - pe->ExtraPredFlags |= DiscontiguousPredFlag; + pe->PredFlags |= DiscontiguousPredFlag; /* mutifile-predicates are weird, they do not seat really on the default module */ if (pe->ModuleOfPred == PROLOG_MODULE) pe->ModuleOfPred = TermProlog; @@ -3183,7 +3183,7 @@ p_is_discontiguous( USES_REGS1 ) if (EndOfPAEntr(pe)) return FALSE; PELOCK(27,pe); - out = (pe->ExtraPredFlags & DiscontiguousPredFlag); + out = (pe->PredFlags & DiscontiguousPredFlag); UNLOCKPE(44,pe); return(out); } diff --git a/C/exec.c b/C/exec.c index 30999f03c..5b2b4e3a4 100755 --- a/C/exec.c +++ b/C/exec.c @@ -1991,8 +1991,8 @@ Yap_InitExecFs(void) #ifdef DEPTH_LIMIT Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0); #endif - Yap_InitCPred("$execute0", 2, p_execute0, 0); - Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop, 0); + Yap_InitCPred("$execute0", 2, p_execute0, NoTracePredFlag); + Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop,NoTracePredFlag ); Yap_InitCPred("$execute_clause", 4, p_execute_clause, 0); Yap_InitCPred("$current_choice_point", 1, p_save_cp, 0); Yap_InitCPred("$current_choicepoint", 1, p_save_cp, 0); diff --git a/C/modules.c b/C/modules.c index 1984eb699..479804cf9 100644 --- a/C/modules.c +++ b/C/modules.c @@ -15,7 +15,7 @@ * * *************************************************************************/ #ifdef SCCS -static char SccsId[] = "%W% %G%"; +static char SccsId[] = "%W% %G%"; #endif #include "Yap.h" @@ -23,12 +23,12 @@ static char SccsId[] = "%W% %G%"; #include "YapHeap.h" #include "pl-shared.h" -static Int p_current_module( USES_REGS1 ); -static Int p_current_module1( USES_REGS1 ); +static Int p_current_module(USES_REGS1); +static Int p_current_module1(USES_REGS1); static ModEntry *LookupModule(Term a); +static Term Yap_YapStripModule(Term t, Term *modp); -inline static ModEntry * -FetchModuleEntry(Atom at) +inline static ModEntry *FetchModuleEntry(Atom at) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; @@ -38,8 +38,7 @@ FetchModuleEntry(Atom at) p0 = ae->PropsOfAE; while (p0) { ModEntry *me = RepModProp(p0); - if ( me->KindOfPE == ModProperty - ) { + if (me->KindOfPE == ModProperty) { READ_UNLOCK(ae->ARWLock); return me; } @@ -49,27 +48,24 @@ FetchModuleEntry(Atom at) return NULL; } -inline static ModEntry * -GetModuleEntry(Atom at) +inline static ModEntry *GetModuleEntry(Atom at) /* get predicate entry for ap/arity; create it if neccessary. */ { Prop p0; AtomEntry *ae = RepAtom(at); ModEntry *new; - p0 = ae->PropsOfAE; while (p0) { ModEntry *me = RepModProp(p0); - if ( me->KindOfPE == ModProperty - ) { + if (me->KindOfPE == ModProperty) { return me; } p0 = me->NextOfPE; } { CACHE_REGS - new = (ModEntry *) Yap_AllocAtomSpace(sizeof(*new)); + new = (ModEntry *)Yap_AllocAtomSpace(sizeof(*new)); INIT_RWLOCK(new->ModRWLock); new->KindOfPE = ModProperty; new->PredForME = NULL; @@ -77,7 +73,7 @@ GetModuleEntry(Atom at) CurrentModules = new; new->AtomOfME = ae; if (at == AtomProlog) - new->flags = UNKNOWN_FAIL|M_SYSTEM|M_CHARESCAPE; + new->flags = UNKNOWN_FAIL | M_SYSTEM | M_CHARESCAPE; else new->flags = LookupModule(LOCAL_SourceModule)->flags; AddPropToAtom(ae, (PropEntry *)new); @@ -85,20 +81,16 @@ GetModuleEntry(Atom at) return new; } - unsigned int - getUnknownModule(ModEntry * m) { - if (m && m->flags & UNKNOWN_MASK) - return m->flags & UNKNOWN_MASK; - else { - return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK; - } - +unsigned int getUnknownModule(ModEntry *m) { + if (m && m->flags & UNKNOWN_MASK) + return m->flags & UNKNOWN_MASK; + else { + return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK; + } } -#define ByteAdr(X) ((char *) &(X)) -Term -Yap_Module_Name(PredEntry *ap) -{ +#define ByteAdr(X) ((char *)&(X)) +Term Yap_Module_Name(PredEntry *ap) { CACHE_REGS Term mod; if (!ap->ModuleOfPred) @@ -109,63 +101,53 @@ Yap_Module_Name(PredEntry *ap) So I will return the current module in case the system predicate is a meta-call. Otherwise it will still work. */ - mod = CurrentModule; + mod = CurrentModule; else { mod = ap->ModuleOfPred; } - if (mod) return mod; + if (mod) + return mod; return TermProlog; } -static ModEntry * -LookupModule(Term a ) -{ +static ModEntry *LookupModule(Term a) { Atom at; ModEntry *me; /* prolog module */ if (a == 0) { - return GetModuleEntry(AtomUser); + return GetModuleEntry(AtomProlog); } at = AtomOfTerm(a); me = GetModuleEntry(at); return me; } -Term -Yap_Module(Term tmod) -{ +Term Yap_Module(Term tmod) { LookupModule(tmod); return tmod; } -ModEntry * -Yap_GetModuleEntry(Term mod) -{ +ModEntry *Yap_GetModuleEntry(Term mod) { ModEntry *me; if (!(me = LookupModule(mod))) return NULL; return me; } -Term -Yap_GetModuleFromEntry(ModEntry *me) -{ - return MkAtomTerm(me->AtomOfME);; +Term Yap_GetModuleFromEntry(ModEntry *me) { + return MkAtomTerm(me->AtomOfME); + ; } -struct pred_entry * -Yap_ModulePred(Term mod) -{ +struct pred_entry *Yap_ModulePred(Term mod) { ModEntry *me; if (!(me = LookupModule(mod))) return NULL; return me->PredForME; } -void -Yap_NewModulePred(Term mod, struct pred_entry *ap) -{ +void Yap_NewModulePred(Term mod, struct pred_entry *ap) { ModEntry *me; if (!(me = LookupModule(mod))) @@ -176,13 +158,12 @@ Yap_NewModulePred(Term mod, struct pred_entry *ap) WRITE_UNLOCK(me->ModRWLock); } -static Int -p_current_module( USES_REGS1 ) -{ /* $current_module(Old,New) */ - Term t; - +static Int + p_current_module(USES_REGS1) { /* $current_module(Old,New) */ + Term t; + if (CurrentModule) { - if(!Yap_unify_constant(ARG1, CurrentModule)) + if (!Yap_unify_constant(ARG1, CurrentModule)) return FALSE; } else { if (!Yap_unify_constant(ARG1, TermProlog)) @@ -201,17 +182,14 @@ p_current_module( USES_REGS1 ) return TRUE; } -static Int -p_current_module1( USES_REGS1 ) -{ /* $current_module(Old) */ +static Int p_current_module1(USES_REGS1) { /* $current_module(Old) + */ if (CurrentModule) return Yap_unify_constant(ARG1, CurrentModule); return Yap_unify_constant(ARG1, TermProlog); } -static Int -p_change_module( USES_REGS1 ) -{ /* $change_module(New) */ +static Int p_change_module(USES_REGS1) { /* $change_module(New) */ Term mod = Deref(ARG1); LookupModule(mod); CurrentModule = mod; @@ -219,57 +197,94 @@ p_change_module( USES_REGS1 ) return TRUE; } -static Int -cont_current_module( USES_REGS1 ) -{ - ModEntry *imod = (ModEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(1,1)), *next; +static Int cont_current_module(USES_REGS1) { + ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(1, 1)), *next; Term t = MkAtomTerm(imod->AtomOfME); next = imod->NextME; /* ARG1 is unbound */ - Yap_unify(ARG1,t); + Yap_unify(ARG1, t); if (!next) cut_succeed(); - EXTRA_CBACK_ARG(1,1) = MkIntegerTerm((Int)next); + EXTRA_CBACK_ARG(1, 1) = MkAddressTerm(next); return TRUE; } -static Int -init_current_module( USES_REGS1 ) -{ /* current_module(?ModuleName) */ +static Int init_current_module( + USES_REGS1) { /* current_module(?ModuleName) */ Term t = Deref(ARG1); if (!IsVarTerm(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; } if (FetchModuleEntry(AtomOfTerm(t)) != NULL) cut_succeed(); cut_fail(); } - EXTRA_CBACK_ARG(1,1) = MkIntegerTerm((Int)CurrentModules); - return cont_current_module( PASS_REGS1 ); + EXTRA_CBACK_ARG(1, 1) = MkIntegerTerm((Int)CurrentModules); + return cont_current_module(PASS_REGS1); } -static Int -p_strip_module( USES_REGS1 ) -{ +static Int cont_ground_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; if (tmod == PROLOG_MODULE) { tmod = TermProlog; } - t1 = Yap_StripModule( t1, &tmod ); + t1 = Yap_StripModule(t1, &tmod); 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 Yap_unify(ARG3, t1) && - Yap_unify(ARG2, tmod); + return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod); } -static Term -Yap_YapStripModule(Term t, Term *modp) -{ +static Term Yap_YapStripModule(Term t, Term *modp) { CACHE_REGS Term tmod; @@ -281,18 +296,18 @@ Yap_YapStripModule(Term t, Term *modp) tmod = TermProlog; } } - restart: +restart: if (IsVarTerm(t) || !IsApplTerm(t)) { if (modp) *modp = tmod; return t; } else { - Functor fun = FunctorOfTerm(t); + Functor fun = FunctorOfTerm(t); if (fun == FunctorModule) { - Term t1 = ArgOfTerm(1, t); + Term t1 = ArgOfTerm(1, t); tmod = t1; - if (!IsVarTerm(tmod) && !IsAtomTerm(tmod) ) { - return 0L; + if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) { + return 0L; } t = ArgOfTerm(2, t); goto restart; @@ -304,50 +319,38 @@ Yap_YapStripModule(Term t, Term *modp) return 0L; } - - - -static Int -p_yap_strip_module( USES_REGS1 ) -{ +static Int p_yap_strip_module(USES_REGS1) { Term t1 = Deref(ARG1), tmod = CurrentModule; if (tmod == PROLOG_MODULE) { tmod = TermProlog; } - t1 = Yap_YapStripModule( t1, &tmod ); + t1 = Yap_YapStripModule(t1, &tmod); if (!t1) { Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module"); return FALSE; } - return Yap_unify(ARG3, t1) && - Yap_unify(ARG2, tmod); + return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod); } -static Int -p_context_module( USES_REGS1 ) -{ +static Int p_context_module(USES_REGS1) { yamop *parentcp = P; CELL *yenv; PredEntry *ap = EnvPreg(parentcp); - if (ap->ModuleOfPred && - !(ap->PredFlags & MetaPredFlag)) + if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag)) return Yap_unify(ARG1, ap->ModuleOfPred); parentcp = CP; yenv = ENV; do { ap = EnvPreg(parentcp); - if (ap->ModuleOfPred && - !(ap->PredFlags & MetaPredFlag)) + if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag)) return Yap_unify(ARG1, ap->ModuleOfPred); parentcp = (yamop *)yenv[E_CP]; yenv = (CELL *)yenv[E_E]; - } while(yenv); + } while (yenv); return Yap_unify(ARG1, CurrentModule); } -Term -Yap_StripModule(Term t, Term *modp) -{ +Term Yap_StripModule(Term t, Term *modp) { CACHE_REGS Term tmod; @@ -359,22 +362,22 @@ Yap_StripModule(Term t, Term *modp) tmod = TermProlog; } } - restart: +restart: if (IsVarTerm(t) || !IsApplTerm(t)) { if (modp) *modp = tmod; return t; } else { - Functor fun = FunctorOfTerm(t); + Functor fun = FunctorOfTerm(t); if (fun == FunctorModule) { - Term t1 = ArgOfTerm(1, t); - if (IsVarTerm( t1 ) ) { - *modp = tmod; - return t; + Term t1 = ArgOfTerm(1, t); + if (IsVarTerm(t1)) { + *modp = tmod; + return t; } tmod = t1; - if (!IsVarTerm(tmod) && !IsAtomTerm(tmod) ) { - return 0L; + if (!IsVarTerm(tmod) && !IsAtomTerm(tmod)) { + return 0L; } t = ArgOfTerm(2, t); goto restart; @@ -386,28 +389,29 @@ Yap_StripModule(Term t, Term *modp) return 0L; } - - -void -Yap_InitModulesC(void) -{ - Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag); - Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module, SafePredFlag|SyncPredFlag); +void Yap_InitModulesC(void) { + Yap_InitCPred("$current_module", 2, p_current_module, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$current_module", 1, p_current_module1, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$change_module", 1, p_change_module, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag | SyncPredFlag); + Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module, + SafePredFlag | SyncPredFlag); Yap_InitCPred("context_module", 1, p_context_module, 0); - Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, cont_current_module, - SafePredFlag|SyncPredFlag); + Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, + 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 LookupModule(MkAtomTerm(AtomProlog)); - LOCAL_SourceModule = MkAtomTerm(AtomProlog); + LOCAL_SourceModule = MkAtomTerm(AtomProlog); LookupModule(USER_MODULE); LookupModule(IDB_MODULE); LookupModule(ATTRIBUTES_MODULE); diff --git a/C/stdpreds.c b/C/stdpreds.c index 1d3c6bf4a..054df7721 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -11,7 +11,8 @@ * File: stdpreds.c * * comments: General-purpose C implemented system predicates * * * -* Last rev: $Date: 2008-07-24 16:02:00 $,$Author: vsc $ * +* Last rev: $Date: 2008-07-24 16:02:00 $,$Author: vsc $ +** * $Log: not supported by cvs2svn $ * Revision 1.131 2008/06/12 10:55:52 vsc * fix syntax error messages @@ -145,7 +146,8 @@ * solved warning: cast from pointer to integer of different size * * Revision 1.91 2005/07/06 19:33:54 ricroc -* TABLING: answers for completed calls can now be obtained by loading (new option) or executing (default) them from the trie data structure. +* TABLING: answers for completed calls can now be obtained by loading (new +*option) or executing (default) them from the trie data structure. * * Revision 1.90 2005/07/06 15:10:14 vsc * improvements to compiler: merged instructions and fixes for -> @@ -160,10 +162,15 @@ * changs to support gibbs sampling in CLP(BN) * * Revision 1.87 2005/04/07 17:48:55 ricroc -* Adding tabling support for mixed strategy evaluation (batched and local scheduling) -* UPDATE: compilation flags -DTABLING_BATCHED_SCHEDULING and -DTABLING_LOCAL_SCHEDULING removed. To support tabling use -DTABLING in the Makefile or --enable-tabling in configure. -* NEW: yap_flag(tabling_mode,MODE) changes the tabling execution mode of all tabled predicates to MODE (batched, local or default). -* NEW: tabling_mode(PRED,MODE) changes the default tabling execution mode of predicate PRED to MODE (batched or local). +* Adding tabling support for mixed strategy evaluation (batched and local +*scheduling) +* UPDATE: compilation flags -DTABLING_BATCHED_SCHEDULING and +*-DTABLING_LOCAL_SCHEDULING removed. To support tabling use -DTABLING in the +*Makefile or --enable-tabling in configure. +* NEW: yap_flag(tabling_mode,MODE) changes the tabling execution mode of all +*tabled predicates to MODE (batched, local or default). +* NEW: tabling_mode(PRED,MODE) changes the default tabling execution mode of +*predicate PRED to MODE (batched or local). * * Revision 1.86 2005/03/13 06:26:11 vsc * fix excessive pruning in meta-calls @@ -194,7 +201,8 @@ * Ricardo's latest version of profiler. * * Revision 1.79 2004/12/28 22:20:36 vsc -* some extra bug fixes for trail overflows: some cannot be recovered that easily, +* some extra bug fixes for trail overflows: some cannot be recovered that +*easily, * some can. * * Revision 1.78 2004/12/08 04:45:03 vsc @@ -221,7 +229,8 @@ * a few fixes for 64 bit compiling. * * Revision 1.72 2004/11/18 22:32:37 vsc -* fix situation where we might assume nonextsing double initialisation of C predicates (use +* fix situation where we might assume nonextsing double initialisation of C +*predicates (use * Hidden Pred Flag). * $host_type was double initialised. * @@ -254,19 +263,19 @@ * * *************************************************************************/ #ifdef SCCS -static char SccsId[] = "%W% %G%"; +static char SccsId[] = "%W% %G%"; #endif #define HAS_CACHE_REGS 1 /* - * This file includes the definition of a miscellania of standard predicates - * for yap refering to: Consulting, Executing a C predicate from call, - * Comparisons (both general and numeric), Structure manipulation, Direct - * access to atoms and predicates, Basic support for the debugger - * - * It also includes a table where all C-predicates are initializated - * - */ +* This file includes the definition of a miscellania of standard predicates +* for yap refering to: Consulting, Executing a C predicate from call, +* Comparisons (both general and numeric), Structure manipulation, Direct +* access to atoms and predicates, Basic support for the debugger +* +* It also includes a table where all C-predicates are initializated +* +*/ #include "Yap.h" #include "Yatom.h" @@ -286,170 +295,174 @@ static char SccsId[] = "%W% %G%"; #endif #include -static Int p_setval( USES_REGS1 ); -static Int p_value( USES_REGS1 ); -static Int p_values( USES_REGS1 ); +static Int p_setval(USES_REGS1); +static Int p_value(USES_REGS1); +static Int p_values(USES_REGS1); #ifdef undefined static CODEADDR *FindAtom(CODEADDR, int *); #endif /* undefined */ -static Int p_opdec( USES_REGS1 ); -static Int p_univ( USES_REGS1 ); -static Int p_abort( USES_REGS1 ); +static Int p_opdec(USES_REGS1); +static Int p_univ(USES_REGS1); +static Int p_abort(USES_REGS1); #ifdef BEAM -Int p_halt( USES_REGS1 ); +Int p_halt(USES_REGS1); #else -static Int p_halt( USES_REGS1 ); +static Int p_halt(USES_REGS1); #endif -static Int init_current_predicate( USES_REGS1 ); -static Int cont_current_predicate( USES_REGS1 ); -static Int init_current_predicate_for_atom( USES_REGS1 ); -static Int cont_current_predicate_for_atom( USES_REGS1 ); -static OpEntry *NextOp(OpEntry * CACHE_TYPE); -static Int init_current_op( USES_REGS1 ); -static Int cont_current_op( USES_REGS1 ); -static Int init_current_atom_op( USES_REGS1 ); -static Int cont_current_atom_op( USES_REGS1 ); -static Int p_flags( USES_REGS1 ); +static Int init_current_predicate(USES_REGS1); +static Int cont_current_predicate(USES_REGS1); +static OpEntry *NextOp(OpEntry *CACHE_TYPE); +static Int init_current_op(USES_REGS1); +static Int cont_current_op(USES_REGS1); +static Int init_current_atom_op(USES_REGS1); +static Int cont_current_atom_op(USES_REGS1); +static Int p_flags(USES_REGS1); static Int TrailMax(void); static Int GlobalMax(void); static Int LocalMax(void); -static Int p_statistics_heap_max( USES_REGS1 ); -static Int p_statistics_global_max( USES_REGS1 ); -static Int p_statistics_local_max( USES_REGS1 ); -static Int p_statistics_heap_info( USES_REGS1 ); -static Int p_statistics_stacks_info( USES_REGS1 ); -static Int p_statistics_trail_info( USES_REGS1 ); -static Term mk_argc_list( USES_REGS1 ); -static Int p_argv( USES_REGS1 ); -static Int p_cputime( USES_REGS1 ); -static Int p_systime( USES_REGS1 ); -static Int p_runtime( USES_REGS1 ); -static Int p_walltime( USES_REGS1 ); -static Int p_access_yap_flags( USES_REGS1 ); -static Int p_set_yap_flags( USES_REGS1 ); -static Int p_break( USES_REGS1 ); +static Int p_statistics_heap_max(USES_REGS1); +static Int p_statistics_global_max(USES_REGS1); +static Int p_statistics_local_max(USES_REGS1); +static Int p_statistics_heap_info(USES_REGS1); +static Int p_statistics_stacks_info(USES_REGS1); +static Int p_statistics_trail_info(USES_REGS1); +static Term mk_argc_list(USES_REGS1); +static Int p_argv(USES_REGS1); +static Int p_cputime(USES_REGS1); +static Int p_systime(USES_REGS1); +static Int p_runtime(USES_REGS1); +static Int p_walltime(USES_REGS1); +static Int p_access_yap_flags(USES_REGS1); +static Int p_set_yap_flags(USES_REGS1); +static Int p_break(USES_REGS1); #ifdef BEAM -Int use_eam( USES_REGS1 ); -Int eager_split( USES_REGS1 ); -Int force_wait( USES_REGS1 ); -Int commit( USES_REGS1 ); -Int skip_while_var( USES_REGS1 ); -Int wait_while_var( USES_REGS1 ); -Int show_time( USES_REGS1 ); -Int start_eam( USES_REGS1 ); -Int cont_eam( USES_REGS1 ); +Int use_eam(USES_REGS1); +Int eager_split(USES_REGS1); +Int force_wait(USES_REGS1); +Int commit(USES_REGS1); +Int skip_while_var(USES_REGS1); +Int wait_while_var(USES_REGS1); +Int show_time(USES_REGS1); +Int start_eam(USES_REGS1); +Int cont_eam(USES_REGS1); extern int EAM; -extern int eam_am(PredEntry*); -extern int showTime(void); +extern int eam_am(PredEntry *); +extern int showTime(void); -Int start_eam( USES_REGS1 ) { - if (eam_am((PredEntry *) 0x1)) return (TRUE); - else { cut_fail(); return (FALSE); } -} - -Int cont_eam( USES_REGS1 ) { - if (eam_am((PredEntry *) 0x2)) return (TRUE); - else { cut_fail(); return (FALSE); } -} - -Int use_eam( USES_REGS1 ) { - if (EAM) EAM=0; - else { Yap_PutValue(AtomCArith,0); EAM=1; } - return(TRUE); -} - -Int commit( USES_REGS1 ) { - if (EAM) { - printf("Nao deveria ter sido chamado commit do stdpreds\n"); - exit(1); +Int start_eam(USES_REGS1) { + if (eam_am((PredEntry *)0x1)) + return (TRUE); + else { + cut_fail(); + return (FALSE); } - return(TRUE); } -Int skip_while_var( USES_REGS1 ) { - if (EAM) { - printf("Nao deveria ter sido chamado skip_while_var do stdpreds\n"); - exit(1); +Int cont_eam(USES_REGS1) { + if (eam_am((PredEntry *)0x2)) + return (TRUE); + else { + cut_fail(); + return (FALSE); } - return(TRUE); } -Int wait_while_var( USES_REGS1 ) { - if (EAM) { - printf("Nao deveria ter sido chamado wait_while_var do stdpreds\n"); - exit(1); +Int use_eam(USES_REGS1) { + if (EAM) + EAM = 0; + else { + Yap_PutValue(AtomCArith, 0); + EAM = 1; } - return(TRUE); + return (TRUE); } -Int force_wait( USES_REGS1 ) { +Int commit(USES_REGS1) { if (EAM) { - printf("Nao deveria ter sido chamado force_wait do stdpreds\n"); - exit(1); + printf("Nao deveria ter sido chamado commit do stdpreds\n"); + exit(1); } - return(TRUE); + return (TRUE); } -Int eager_split( USES_REGS1 ) { +Int skip_while_var(USES_REGS1) { if (EAM) { - printf("Nao deveria ter sido chamado eager_split do stdpreds\n"); - exit(1); + printf("Nao deveria ter sido chamado skip_while_var do stdpreds\n"); + exit(1); } - return(TRUE); + return (TRUE); } -Int show_time( USES_REGS1 ) /* MORE PRECISION */ +Int wait_while_var(USES_REGS1) { + if (EAM) { + printf("Nao deveria ter sido chamado wait_while_var do stdpreds\n"); + exit(1); + } + return (TRUE); +} + +Int force_wait(USES_REGS1) { + if (EAM) { + printf("Nao deveria ter sido chamado force_wait do stdpreds\n"); + exit(1); + } + return (TRUE); +} + +Int eager_split(USES_REGS1) { + if (EAM) { + printf("Nao deveria ter sido chamado eager_split do stdpreds\n"); + exit(1); + } + return (TRUE); +} + +Int show_time(USES_REGS1) /* MORE PRECISION */ { return (showTime()); } -#endif /* BEAM */ +#endif /* BEAM */ -static Int -p_setval( USES_REGS1 ) -{ /* '$set_value'(+Atom,+Atomic) */ - Term t1 = Deref(ARG1), t2 = Deref(ARG2); - if (!IsVarTerm(t1) && IsAtomTerm(t1) && - (!IsVarTerm(t2) && (IsAtomTerm(t2) || IsNumTerm(t2)))) { - Yap_PutValue(AtomOfTerm(t1), t2); - return (TRUE); - } - return (FALSE); +static Int p_setval(USES_REGS1) { /* '$set_value'(+Atom,+Atomic) */ + Term t1 = Deref(ARG1), t2 = Deref(ARG2); + if (!IsVarTerm(t1) && IsAtomTerm(t1) && + (!IsVarTerm(t2) && (IsAtomTerm(t2) || IsNumTerm(t2)))) { + Yap_PutValue(AtomOfTerm(t1), t2); + return (TRUE); + } + return (FALSE); } -static Int -p_value( USES_REGS1 ) -{ /* '$get_value'(+Atom,?Val) */ +static Int p_value(USES_REGS1) { /* '$get_value'(+Atom,?Val) */ Term t1 = Deref(ARG1); if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR,t1,"get_value/2"); + Yap_Error(INSTANTIATION_ERROR, t1, "get_value/2"); return (FALSE); } if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM,t1,"get_value/2"); + Yap_Error(TYPE_ERROR_ATOM, t1, "get_value/2"); return (FALSE); } return (Yap_unify_constant(ARG2, Yap_GetValue(AtomOfTerm(t1)))); } - -static Int -p_values( USES_REGS1 ) -{ /* '$values'(Atom,Old,New) */ - Term t1 = Deref(ARG1), t3 = Deref(ARG3); +static Int p_values(USES_REGS1) { /* '$values'(Atom,Old,New) */ + Term t1 = Deref(ARG1), t3 = Deref(ARG3); if (IsVarTerm(t1)) { - Yap_Error(INSTANTIATION_ERROR,t1,"set_value/2"); + Yap_Error(INSTANTIATION_ERROR, t1, "set_value/2"); return (FALSE); } if (!IsAtomTerm(t1)) { - Yap_Error(TYPE_ERROR_ATOM,t1,"set_value/2"); + Yap_Error(TYPE_ERROR_ATOM, t1, "set_value/2"); return (FALSE); } - if (!Yap_unify_constant(ARG2, Yap_GetValue(AtomOfTerm(t1)))) + if (!Yap_unify_constant(ARG2, Yap_GetValue(AtomOfTerm(t1)))) { return (FALSE); + } if (!IsVarTerm(t3)) { if (IsAtomTerm(t3) || IsNumTerm(t3)) { Yap_PutValue(AtomOfTerm(t1), t3); @@ -459,52 +472,56 @@ p_values( USES_REGS1 ) return (TRUE); } -static Int -p_opdec( USES_REGS1 ) -{ /* '$opdec'(p,type,atom) */ +static Int p_opdec(USES_REGS1) { /* '$opdec'(p,type,atom) */ /* we know the arguments are integer, atom, atom */ - Term p = Deref(ARG1), t = Deref(ARG2), at = Deref(ARG3); + Term p = Deref(ARG1), t = Deref(ARG2), at = Deref(ARG3); Term tmod = Deref(ARG4); if (tmod == TermProlog) { tmod = PROLOG_MODULE; } - return Yap_OpDec((int) IntOfTerm(p), RepAtom(AtomOfTerm(t))->StrOfAE, - AtomOfTerm(at), tmod); + return Yap_OpDec((int)IntOfTerm(p), RepAtom(AtomOfTerm(t))->StrOfAE, + AtomOfTerm(at), tmod); } - #ifdef NO_STRTOD #if HAVE_CTYPE_H #include #endif -double -strtod(s, pe) - char *s, **pe; +double strtod(s, pe) char *s, **pe; { - double r = atof(s); - *pe = s; - while (*s == ' ') - ++s; - if (*s == '+' || *s == '-') - ++s; - if (!isdigit(*s)) - return (r); - while (isdigit(*s)) - ++s; - if (*s == '.') - ++s; - while (isdigit(*s)) - ++s; - if (*s == 'e' || *s == 'E') - ++s; - if (*s == '+' || *s == '-') - ++s; - while (isdigit(*s)) - ++s; - *pe = s; - return (r); + double r = atof(s); + *pe = s; + while (*s == ' ') { + ++s; + } + if (*s == '+' || *s == '-') { + ++s; + } + if (!isdigit(*s)) { + return (r); + } + while (isdigit(*s)) { + ++s; + } + if (*s == '.') { + ++s; + } + while (isdigit(*s)) { + ++s; + } + if (*s == 'e' || *s == 'E') { + ++s; + } + if (*s == '+' || *s == '-') { + ++s; + } + while (isdigit(*s)) { + ++s; + } + *pe = s; + return (r); } #else @@ -514,23 +531,16 @@ strtod(s, pe) #endif #ifndef INFINITY -#define INFINITY (1.0/0.0) +#define INFINITY (1.0 / 0.0) #endif - -static UInt -runtime( USES_REGS1 ) -{ - return(Yap_cputime()-Yap_total_gc_time()-Yap_total_stack_shift_time()); +static UInt runtime(USES_REGS1) { + return (Yap_cputime() - Yap_total_gc_time() - Yap_total_stack_shift_time()); } /* $runtime(-SinceInterval,-SinceStart) */ -static Int -p_runtime( USES_REGS1 ) -{ - Int now, interval, - gc_time, - ss_time; +static Int p_runtime(USES_REGS1) { + Int now, interval, gc_time, ss_time; Term tnow, tinterval; Yap_cputime_interval(&now, &interval); @@ -538,106 +548,98 @@ p_runtime( USES_REGS1 ) now -= gc_time; ss_time = Yap_total_stack_shift_time(); now -= ss_time; - interval -= (gc_time-LOCAL_LastGcTime)+(ss_time-LOCAL_LastSSTime); + interval -= (gc_time - LOCAL_LastGcTime) + (ss_time - LOCAL_LastSSTime); LOCAL_LastGcTime = gc_time; LOCAL_LastSSTime = ss_time; tnow = MkIntegerTerm(now); tinterval = MkIntegerTerm(interval); - return( Yap_unify_constant(ARG1, tnow) && - Yap_unify_constant(ARG2, tinterval) ); + return (Yap_unify_constant(ARG1, tnow) && + Yap_unify_constant(ARG2, tinterval)); } /* $cputime(-SinceInterval,-SinceStart) */ -static Int -p_cputime( USES_REGS1 ) -{ +static Int p_cputime(USES_REGS1) { Int now, interval; Yap_cputime_interval(&now, &interval); - return( Yap_unify_constant(ARG1, MkIntegerTerm(now)) && - Yap_unify_constant(ARG2, MkIntegerTerm(interval)) ); + return (Yap_unify_constant(ARG1, MkIntegerTerm(now)) && + Yap_unify_constant(ARG2, MkIntegerTerm(interval))); } -static Int -p_systime( USES_REGS1 ) -{ +static Int p_systime(USES_REGS1) { Int now, interval; Yap_systime_interval(&now, &interval); - return( Yap_unify_constant(ARG1, MkIntegerTerm(now)) && - Yap_unify_constant(ARG2, MkIntegerTerm(interval)) ); + return (Yap_unify_constant(ARG1, MkIntegerTerm(now)) && + Yap_unify_constant(ARG2, MkIntegerTerm(interval))); } -static Int -p_walltime( USES_REGS1 ) -{ +static Int p_walltime(USES_REGS1) { Int now, interval; Yap_walltime_interval(&now, &interval); - return( Yap_unify_constant(ARG1, MkIntegerTerm(now)) && - Yap_unify_constant(ARG2, MkIntegerTerm(interval)) ); + return (Yap_unify_constant(ARG1, MkIntegerTerm(now)) && + Yap_unify_constant(ARG2, MkIntegerTerm(interval))); } -static Int -p_univ( USES_REGS1 ) -{ /* A =.. L */ - unsigned int arity; - register Term tin; - Term twork, t2; - Atom at; +static Int p_univ(USES_REGS1) { /* A =.. L */ + unsigned int arity; + register Term tin; + Term twork, t2; + Atom at; tin = Deref(ARG1); t2 = Deref(ARG2); if (IsVarTerm(tin)) { /* we need to have a list */ - Term *Ar; + Term *Ar; if (IsVarTerm(t2)) { Yap_Error(INSTANTIATION_ERROR, t2, "(=..)/2"); - return(FALSE); + return (FALSE); } if (!IsPairTerm(t2)) { if (t2 == TermNil) - Yap_Error(DOMAIN_ERROR_NON_EMPTY_LIST, t2, "(=..)/2"); + Yap_Error(DOMAIN_ERROR_NON_EMPTY_LIST, t2, "(=..)/2"); else - Yap_Error(TYPE_ERROR_LIST, ARG2, "(=..)/2"); + Yap_Error(TYPE_ERROR_LIST, ARG2, "(=..)/2"); return (FALSE); } twork = HeadOfTerm(t2); if (IsVarTerm(twork)) { Yap_Error(INSTANTIATION_ERROR, twork, "(=..)/2"); - return(FALSE); + return (FALSE); } if (IsNumTerm(twork)) { Term tt = TailOfTerm(t2); if (IsVarTerm(tt)) { - Yap_Error(INSTANTIATION_ERROR, tt, "(=..)/2"); - return (FALSE); + Yap_Error(INSTANTIATION_ERROR, tt, "(=..)/2"); + return (FALSE); } - if ( tt != MkAtomTerm(AtomNil)) { - Yap_Error(TYPE_ERROR_ATOMIC, twork, "(=..)/2"); - return (FALSE); + if (tt != MkAtomTerm(AtomNil)) { + Yap_Error(TYPE_ERROR_ATOMIC, twork, "(=..)/2"); + return (FALSE); } return (Yap_unify_constant(ARG1, twork)); } if (!IsAtomTerm(twork)) { Term tt = TailOfTerm(t2); if (IsVarTerm(tt)) { - Yap_Error(INSTANTIATION_ERROR, twork, "(=..)/2"); - return(FALSE); + Yap_Error(INSTANTIATION_ERROR, twork, "(=..)/2"); + return (FALSE); } else if (tt == MkAtomTerm(AtomNil)) { - Yap_Error(TYPE_ERROR_ATOMIC, twork, "(=..)/2"); - return (FALSE); + Yap_Error(TYPE_ERROR_ATOMIC, twork, "(=..)/2"); + return (FALSE); } else { - Yap_Error(TYPE_ERROR_ATOM, twork, "(=..)/2"); - return (FALSE); + Yap_Error(TYPE_ERROR_ATOM, twork, "(=..)/2"); + return (FALSE); } - } + } at = AtomOfTerm(twork); twork = TailOfTerm(t2); if (IsVarTerm(twork)) { Yap_Error(INSTANTIATION_ERROR, twork, "(=..)/2"); - return(FALSE); - } else if (!IsPairTerm(twork)) { + return (FALSE); + } else if (!IsPairTerm(twork)) { if (twork != TermNil) { - Yap_Error(TYPE_ERROR_LIST, ARG2, "(=..)/2"); - return(FALSE); + Yap_Error(TYPE_ERROR_LIST, ARG2, "(=..)/2"); + return (FALSE); } return (Yap_unify_constant(ARG1, MkAtomTerm(at))); } @@ -645,24 +647,24 @@ p_univ( USES_REGS1 ) /* build the term directly on the heap */ Ar = HR; HR++; - + while (!IsVarTerm(twork) && IsPairTerm(twork)) { *HR++ = HeadOfTerm(twork); if (HR > ASP - 1024) { - /* restore space */ - HR = Ar; - if (!Yap_gcl((ASP-HR)*sizeof(CELL), 2, ENV, gc_P(P,CP))) { - Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); - return FALSE; - } - twork = TailOfTerm(Deref(ARG2)); - goto build_compound; + /* restore space */ + HR = Ar; + if (!Yap_gcl((ASP - HR) * sizeof(CELL), 2, ENV, gc_P(P, CP))) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); + return FALSE; + } + twork = TailOfTerm(Deref(ARG2)); + goto build_compound; } twork = TailOfTerm(twork); } if (IsVarTerm(twork)) { Yap_Error(INSTANTIATION_ERROR, twork, "(=..)/2"); - return(FALSE); + return (FALSE); } if (twork != TermNil) { Yap_Error(TYPE_ERROR_LIST, ARG2, "(=..)/2"); @@ -671,22 +673,21 @@ p_univ( USES_REGS1 ) #ifdef SFUNC DOES_NOT_WORK(); { - SFEntry *pe = (SFEntry *) Yap_GetAProp(at, SFProperty); + SFEntry *pe = (SFEntry *)Yap_GetAProp(at, SFProperty); if (pe) - twork = MkSFTerm(Yap_MkFunctor(at, SFArity), - arity, CellPtr(TR), pe->NilValue); + twork = MkSFTerm(Yap_MkFunctor(at, SFArity), arity, CellPtr(TR), + pe->NilValue); else - twork = Yap_MkApplTerm(Yap_MkFunctor(at, arity), - arity, CellPtr(TR)); + twork = Yap_MkApplTerm(Yap_MkFunctor(at, arity), arity, CellPtr(TR)); } #else - arity = HR-Ar-1; + arity = HR - Ar - 1; if (at == AtomDot && arity == 2) { Ar[0] = Ar[1]; Ar[1] = Ar[2]; - HR --; + HR--; twork = AbsPair(Ar); - } else { + } else { *Ar = (CELL)(Yap_MkFunctor(at, arity)); twork = AbsAppl(Ar); } @@ -700,8 +701,8 @@ p_univ( USES_REGS1 ) if (IsRefTerm(tin)) return (FALSE); if (IsApplTerm(tin)) { - Functor fun = FunctorOfTerm(tin); - if (IsExtensionFunctor ( fun ) ) { + Functor fun = FunctorOfTerm(tin); + if (IsExtensionFunctor(fun)) { twork = MkPairTerm(tin, MkAtomTerm(AtomNil)); return (Yap_unify(twork, ARG2)); } @@ -709,35 +710,35 @@ p_univ( USES_REGS1 ) at = NameOfFunctor(fun); #ifdef SFUNC if (arity == SFArity) { - CELL *p = CellPtr(TR); - CELL *q = ArgsOfSFTerm(tin); - int argno = 1; + CELL *p = CellPtr(TR); + CELL *q = ArgsOfSFTerm(tin); + int argno = 1; while (*q) { - while (*q > argno++) - *p++ = MkVarTerm(); - ++q; - *p++ = Deref(*q++); + while (*q > argno++) + *p++ = MkVarTerm(); + ++q; + *p++ = Deref(*q++); } twork = Yap_ArrayToList(CellPtr(TR), argno - 1); while (IsIntTerm(twork)) { - if (!Yap_gc(2, ENV, gc_P(P,CP))) { - Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); - return(FALSE); - } - twork = Yap_ArrayToList(CellPtr(TR), argno - 1); + if (!Yap_gc(2, ENV, gc_P(P, CP))) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); + return (FALSE); + } + twork = Yap_ArrayToList(CellPtr(TR), argno - 1); } } else #endif - { - while (HR+arity*2 > ASP-1024) { - if (!Yap_gcl((arity*2)*sizeof(CELL), 2, ENV, gc_P(P,CP))) { - Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); - return(FALSE); - } - tin = Deref(ARG1); - } - twork = Yap_ArrayToList(RepAppl(tin) + 1, arity); + { + while (HR + arity * 2 > ASP - 1024) { + if (!Yap_gcl((arity * 2) * sizeof(CELL), 2, ENV, gc_P(P, CP))) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, LOCAL_ErrorMessage); + return (FALSE); + } + tin = Deref(ARG1); } + twork = Yap_ArrayToList(RepAppl(tin) + 1, arity); + } } else { /* We found a list */ at = AtomDot; @@ -747,189 +748,286 @@ p_univ( USES_REGS1 ) return (Yap_unify(ARG2, twork)); } -static Int -p_abort( USES_REGS1 ) -{ /* abort */ +static Int p_abort(USES_REGS1) { /* abort */ /* make sure we won't go creeping around */ Yap_Error(PURE_ABORT, TermNil, ""); - return(FALSE); + return (FALSE); } #ifdef BEAM -extern void exit_eam(char *s); +extern void exit_eam(char *s); -Int +Int #else -static Int +static Int #endif -p_halt( USES_REGS1 ) -{ /* halt */ + p_halt(USES_REGS1) { /* halt */ Term t = Deref(ARG1); Int out; #ifdef BEAM - if (EAM) exit_eam("\n\n[ Prolog execution halted ]\n"); + if (EAM) + exit_eam("\n\n[ Prolog execution halted ]\n"); #endif if (IsVarTerm(t)) { - Yap_Error(INSTANTIATION_ERROR,t,"halt/1"); - return(FALSE); + Yap_Error(INSTANTIATION_ERROR, t, "halt/1"); + return (FALSE); } if (!IsIntegerTerm(t)) { - Yap_Error(TYPE_ERROR_INTEGER,t,"halt/1"); - return(FALSE); + Yap_Error(TYPE_ERROR_INTEGER, t, "halt/1"); + return (FALSE); } out = IntegerOfTerm(t); Yap_exit(out); return TRUE; } - -static Int -cont_current_predicate( USES_REGS1 ) -{ - PredEntry *pp = (PredEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(3,1)); +static Int cont_current_predicate(USES_REGS1) { + PredEntry *pp = NULL; UInt Arity; Term name; + Term t1 = Deref(ARG1), t2 = Deref(ARG2), t3; + bool is_det = false, rc; + Functor f; - while (pp != NULL) { - if (pp->PredFlags & HiddenPredFlag) { - pp = pp->NextPredOfModule; - } else - break; + if (IsNonVarTerm(t1)) { + PropEntry *p = AddressOfTerm(EXTRA_CBACK_ARG(4, 1)); + PropEntry *q = AddressOfTerm(EXTRA_CBACK_ARG(4, 2)); + // restart inner loop + for (; q; q = q->NextOfPE) { + if (q->KindOfPE == PEProp) { + pp = RepPredProp(q); + q = q->NextOfPE; + if (q == NIL) + p = p->NextOfPE; + if (!p) + is_det = true; + // we are done with this loop. + break; + } + } + if (!pp) { + // try using outer loop + for (; p; p = p->NextOfPE) { + if (p->KindOfPE == PEProp) { + q = NULL; + pp = RepPredProp(p); + p = p->NextOfPE; + if (!p) + is_det = true; + break; + } else if (p->KindOfPE == FunctorProperty) { + // looping on p/n + for (q = RepFunctorProp(p)->PropsOfFE; q; q = q->NextOfPE) { + if (q->KindOfPE == PEProp) { + pp = RepPredProp(q); + q = q->NextOfPE; + if (!q) + p = p->NextOfPE; + if (!p) + is_det = true; + break; + } + } + } + } + } + if (pp == NULL) // nothing more + cut_fail(); + if (!is_det) { + EXTRA_CBACK_ARG(4, 1) = MkAddressTerm(p); + EXTRA_CBACK_ARG(4, 2) = MkAddressTerm(q); + } + } else if (IsNonVarTerm(t2)) { + // operating within the same module. + PredEntry *npp; + pp = AddressOfTerm(EXTRA_CBACK_ARG(4, 1)); + + if (!pp) + cut_fail(); + // just try next one + npp = pp->NextPredOfModule; + if (npp) { + EXTRA_CBACK_ARG(4, 1) = MkAddressTerm(npp); + } else { + is_det = true; + } + } else { + pp = AddressOfTerm(EXTRA_CBACK_ARG(4, 1)); + + while (!pp) { + ModEntry *m = AddressOfTerm(EXTRA_CBACK_ARG(4, 2)); + m = m->NextME; + if (!m) + cut_fail(); + else { + pp = m->PredForME; + EXTRA_CBACK_ARG(4, 2) = MkAddressTerm(m); + } + } // we found a new answer + if (!pp) + cut_fail(); + else + EXTRA_CBACK_ARG(4, 2) = MkAddressTerm(pp->NextPredOfModule); } - if (pp == NULL) - cut_fail(); - EXTRA_CBACK_ARG(3,1) = (CELL)MkIntegerTerm((Int)(pp->NextPredOfModule)); - if (pp->FunctorOfPred == FunctorModule) - return FALSE; if (pp->ModuleOfPred != IDB_MODULE) { + f = pp->FunctorOfPred; Arity = pp->ArityOfPE; if (Arity) - name = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred)); + name = MkAtomTerm(NameOfFunctor(f)); else - name = MkAtomTerm((Atom)pp->FunctorOfPred); + name = MkAtomTerm((Atom)f); } else { if (pp->PredFlags & NumberDBPredFlag) { name = MkIntegerTerm(pp->src.IndxId); Arity = 0; } else if (pp->PredFlags & AtomDBPredFlag) { - name = MkAtomTerm((Atom)pp->FunctorOfPred); + f = pp->FunctorOfPred; + name = MkAtomTerm((Atom)f); Arity = 0; } else { - Functor f = pp->FunctorOfPred; + f = pp->FunctorOfPred; + f = pp->FunctorOfPred; name = MkAtomTerm(NameOfFunctor(f)); - Arity = ArityOfFunctor(f); + Arity = ArityOfFunctor(pp->FunctorOfPred); } } - if (pp->PredFlags & HiddenPredFlag) - return FALSE; - return - Yap_unify(ARG2,name) && - Yap_unify(ARG3, MkIntegerTerm((Int)Arity)); -} - -static Int -init_current_predicate( USES_REGS1 ) -{ - Term t1 = Deref(ARG1); - - if (IsVarTerm(t1) || !IsAtomTerm(t1)) cut_fail(); - EXTRA_CBACK_ARG(3,1) = MkIntegerTerm((Int)Yap_ModulePred(t1)); - return cont_current_predicate( PASS_REGS1 ); -} - -static Int -cont_current_predicate_for_atom( USES_REGS1 ) -{ - Prop pf = (Prop)IntegerOfTerm(EXTRA_CBACK_ARG(3,1)); - Term mod = Deref(ARG2); - - while (pf != NIL) { - FunctorEntry *pp = RepFunctorProp(pf); - if (IsFunctorProperty(pp->KindOfPE)) { - Prop p0; - FUNC_READ_LOCK(pp); - p0 = pp->PropsOfFE; - if (p0) { - PredEntry *p = RepPredProp(p0); - if (p->ModuleOfPred == mod || - p->ModuleOfPred == 0) { - UInt ar = p->ArityOfPE; - /* we found the predicate */ - EXTRA_CBACK_ARG(3,1) = MkIntegerTerm((Int)(pp->NextOfPE)); - FUNC_READ_UNLOCK(pp); - return - Yap_unify(ARG3,MkIntegerTerm(ar)); - } else if (p->NextOfPE) { - UInt hash = PRED_HASH(pp,mod,PredHashTableSize); - READ_LOCK(PredHashRWLock); - PredEntry *p = PredHash[hash]; - - while (p) { - if (p->FunctorOfPred == pp && - p->ModuleOfPred == mod) - { - READ_UNLOCK(PredHashRWLock); - FUNC_READ_UNLOCK(pp); - /* we found the predicate */ - EXTRA_CBACK_ARG(3,1) = MkIntegerTerm((Int)(p->NextOfPE)); - return Yap_unify(ARG3,MkIntegerTerm(p->ArityOfPE)); - } - p = RepPredProp(p->NextOfPE); - } - } - } - FUNC_READ_UNLOCK(pp); - } else if (pp->KindOfPE == PEProp) { - PredEntry *pe = RepPredProp(pf); - PELOCK(31,pe); - if (pe->PredFlags & HiddenPredFlag) - return FALSE; - if (pe->ModuleOfPred == mod || - pe->ModuleOfPred == 0) { - /* we found the predicate */ - EXTRA_CBACK_ARG(3,1) = MkIntegerTerm((Int)(pp->NextOfPE)); - UNLOCKPE(31,pe); - return Yap_unify(ARG3,MkIntTerm(0)); - } - UNLOCKPE(31,pe); - } - pf = pp->NextOfPE; + if (Arity) { + t3 = Yap_MkNewApplTerm(f, Arity); + } else { + t3 = name; } - cut_fail(); + rc = (!(pp->PredFlags & HiddenPredFlag)) && + Yap_unify(ARG2, ModToTerm(pp->ModuleOfPred)) && Yap_unify(ARG1, name) && + Yap_unify(ARG3, t3) && Yap_unify(ARG4, MkIntegerTerm(pp->PredFlags)); + if (is_det) { + if (rc) + cut_succeed(); + else + cut_fail(); + } + return rc; } -static Int -init_current_predicate_for_atom( USES_REGS1 ) -{ - Term t1 = Deref(ARG1); +static Int init_current_predicate(USES_REGS1) { + Term t1 = Deref(ARG1), t2 = Deref(ARG2), t3 = Deref(ARG3); + unsigned int arity; + Functor f = NIL; + Atom at; + PredEntry *pp = NULL; + ModEntry *m = NULL; - if (IsVarTerm(t1) || !IsAtomTerm(t1)) cut_fail(); - EXTRA_CBACK_ARG(3,1) = MkIntegerTerm((Int)RepAtom(AtomOfTerm(t1))->PropsOfAE); - return (cont_current_predicate_for_atom( PASS_REGS1 )); + // check term + if (!IsVarTerm(t3)) { + t3 = Yap_StripModule(t3, &t2); + if (IsAtomTerm(t3)) { + at = AtomOfTerm(t3); + arity = 0; + } else if (IsIntTerm(t3)) { + if (IsNonVarTerm(t2) && t2 != IDB_MODULE) { + Yap_Error(TYPE_ERROR_CALLABLE, t3, "current_predicate/2"); + cut_fail(); + } else if (IsVarTerm(t2)) { + Yap_unify(t2, IDB_MODULE); // should always succeed + if (Yap_unify(ARG1, t3)) + cut_succeed(); + else + cut_fail(); + } + } else if (IsPairTerm(t3)) { + f = FunctorDot; + at = AtomDot; + arity = 2; + } else { + f = FunctorOfTerm(t3); + if (IsExtensionFunctor(f)) { + Yap_Error(TYPE_ERROR_CALLABLE, t3, "current_predicate/2"); + cut_fail(); + } + at = NameOfFunctor(f); + arity = ArityOfFunctor(f); + } + if (IsAtomTerm(t2)) // we know the module and the main predicate + // so that we are deterministic + { + if (arity == 0) { + if (Yap_GetPredPropByAtom(at, t2) != NIL && + Yap_unify(ARG1, MkAtomTerm(at))) + cut_succeed(); + } else { + if (Yap_GetPredPropByFunc(f, t2) != NIL && + Yap_unify(ARG1, MkAtomTerm(at))) + cut_succeed(); + } + cut_fail(); + } + } + // check name + if (IsNonVarTerm(t1)) { + if (IsIntTerm(t1) && (IsVarTerm(t2) || t2 == IDB_MODULE)) { + // idb allows numeric keys. + if (Yap_FindLUIntKey(IntOfTerm(t2))) { + if (Yap_unify(ARG2, IDB_MODULE)) + cut_succeed(); + cut_fail(); + } + } else if (!IsAtomTerm(t1)) { + Yap_Error(TYPE_ERROR_ATOM, t1, "current_predicate/2"); + cut_fail(); + } else { + PropEntry *p = RepAtom(AtomOfTerm(t1))->PropsOfAE, *q = NIL; + while (p && p->KindOfPE == FunctorProperty && + (q = RepFunctorProp(p)->PropsOfFE) == NIL) { + p = p->NextOfPE; + } + if (!q) { + if (p) + p = p->NextOfPE; + } else if (!p) + cut_fail(); + EXTRA_CBACK_ARG(4, 1) = MkAddressTerm(p); + EXTRA_CBACK_ARG(4, 2) = MkAddressTerm(q); + } + } + // check module + else { + if (IsNonVarTerm(t2)) { + if (!IsAtomTerm(t2)) { + Yap_Error(TYPE_ERROR_ATOM, t2, "current_predicate/2"); + cut_fail(); + } + m = Yap_GetModuleEntry(t2); + } else { + m = CurrentModules; + } + if (!m) + cut_fail(); + pp = m->PredForME; + if (IsNonVarTerm(t2) && !pp) { + cut_fail(); + } + EXTRA_CBACK_ARG(4, 2) = MkAddressTerm(m); + EXTRA_CBACK_ARG(4, 1) = MkAddressTerm(pp); + } + // ensure deref access to choice-point fields. + return cont_current_predicate(PASS_REGS1); } -static OpEntry * -NextOp(OpEntry *pp USES_REGS) -{ +static OpEntry *NextOp(OpEntry *pp USES_REGS) { while (!EndOfPAEntr(pp) && pp->KindOfPE != OpProperty && - (pp->OpModule != PROLOG_MODULE || pp->OpModule != CurrentModule)) + (pp->OpModule != PROLOG_MODULE || pp->OpModule != CurrentModule)) pp = RepOpProp(pp->NextOfPE); return (pp); } -int -Yap_IsOp(Atom at) -{ +int Yap_IsOp(Atom at) { CACHE_REGS OpEntry *op = NextOp(RepOpProp((Prop)(RepAtom(at)->PropsOfAE)) PASS_REGS); return (!EndOfPAEntr(op)); } -int -Yap_IsOpMaxPrio(Atom at) -{ +int Yap_IsOpMaxPrio(Atom at) { CACHE_REGS OpEntry *op = NextOp(RepOpProp((Prop)(RepAtom(at)->PropsOfAE)) PASS_REGS); int max; @@ -944,32 +1042,27 @@ Yap_IsOpMaxPrio(Atom at) return max; } -static Int -unify_op(OpEntry *op USES_REGS) -{ +static Int unify_op(OpEntry *op USES_REGS) { Term tmod = op->OpModule; if (tmod == PROLOG_MODULE) tmod = TermProlog; - return - Yap_unify_constant(ARG2,tmod) && - Yap_unify_constant(ARG3,MkIntegerTerm(op->Prefix)) && - Yap_unify_constant(ARG4,MkIntegerTerm(op->Infix)) && - Yap_unify_constant(ARG5,MkIntegerTerm(op->Posfix)); + return Yap_unify_constant(ARG2, tmod) && + Yap_unify_constant(ARG3, MkIntegerTerm(op->Prefix)) && + Yap_unify_constant(ARG4, MkIntegerTerm(op->Infix)) && + Yap_unify_constant(ARG5, MkIntegerTerm(op->Posfix)); } -static Int -cont_current_op( USES_REGS1 ) -{ - OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5,1)), *next; - +static Int cont_current_op(USES_REGS1) { + OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5, 1)), *next; + READ_LOCK(op->OpRWLock); next = op->OpNext; - if (Yap_unify_constant(ARG1,MkAtomTerm(op->OpName)) && + if (Yap_unify_constant(ARG1, MkAtomTerm(op->OpName)) && unify_op(op PASS_REGS)) { READ_UNLOCK(op->OpRWLock); if (next) { - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next); + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); return TRUE; } else { cut_succeed(); @@ -977,7 +1070,7 @@ cont_current_op( USES_REGS1 ) } else { READ_UNLOCK(op->OpRWLock); if (next) { - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next); + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); return FALSE; } else { cut_fail(); @@ -985,24 +1078,21 @@ cont_current_op( USES_REGS1 ) } } -static Int -init_current_op( USES_REGS1 ) -{ /* current_op(-Precedence,-Type,-Atom) */ - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)OpList); - return cont_current_op( PASS_REGS1 ); +static Int init_current_op( + USES_REGS1) { /* current_op(-Precedence,-Type,-Atom) */ + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)OpList); + return cont_current_op(PASS_REGS1); } -static Int -cont_current_atom_op( USES_REGS1 ) -{ - OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5,1)), *next; - +static Int cont_current_atom_op(USES_REGS1) { + OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5, 1)), *next; + READ_LOCK(op->OpRWLock); next = NextOp(RepOpProp(op->NextOfPE) PASS_REGS); if (unify_op(op PASS_REGS)) { READ_UNLOCK(op->OpRWLock); if (next) { - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next); + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); return TRUE; } else { cut_succeed(); @@ -1010,7 +1100,7 @@ cont_current_atom_op( USES_REGS1 ) } else { READ_UNLOCK(op->OpRWLock); if (next) { - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next); + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); return FALSE; } else { cut_fail(); @@ -1018,53 +1108,50 @@ cont_current_atom_op( USES_REGS1 ) } } -static Int -init_current_atom_op( USES_REGS1 ) -{ /* current_op(-Precedence,-Type,-Atom) */ +static Int init_current_atom_op( + USES_REGS1) { /* current_op(-Precedence,-Type,-Atom) */ Term t = Deref(ARG1); AtomEntry *ae; OpEntry *ope; if (IsVarTerm(t) || !IsAtomTerm(t)) { - Yap_Error(TYPE_ERROR_ATOM,t,"current_op/3"); + Yap_Error(TYPE_ERROR_ATOM, t, "current_op/3"); cut_fail(); } ae = RepAtom(AtomOfTerm(t)); if (EndOfPAEntr((ope = NextOp(RepOpProp(ae->PropsOfAE) PASS_REGS)))) { cut_fail(); } - EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((Int)ope); - return cont_current_atom_op( PASS_REGS1 ); + EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((Int)ope); + return cont_current_atom_op(PASS_REGS1); } -static Int -p_flags( USES_REGS1 ) -{ /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */ - PredEntry *pe; - Int newFl; +static Int p_flags(USES_REGS1) { /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */ + PredEntry *pe; + Int newFl; Term t1 = Deref(ARG1); Term mod = Deref(ARG2); if (IsVarTerm(mod) || !IsAtomTerm(mod)) { - return(FALSE); + return (FALSE); } if (IsVarTerm(t1)) return (FALSE); if (IsAtomTerm(t1)) { - while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)))== NULL) { + while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod))) == NULL) { if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); - return FALSE; + Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); + return FALSE; } t1 = Deref(ARG1); mod = Deref(ARG2); } } else if (IsApplTerm(t1)) { - Functor funt = FunctorOfTerm(t1); - while ((pe = RepPredProp(PredPropByFunc(funt, mod)))== NULL) { + Functor funt = FunctorOfTerm(t1); + while ((pe = RepPredProp(PredPropByFunc(funt, mod))) == NULL) { if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); - return FALSE; + Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); + return FALSE; } t1 = Deref(ARG1); mod = Deref(ARG2); @@ -1073,10 +1160,10 @@ p_flags( USES_REGS1 ) return (FALSE); if (EndOfPAEntr(pe)) return (FALSE); - PELOCK(92,pe); + PELOCK(92, pe); if (!Yap_unify_constant(ARG3, MkIntegerTerm(pe->PredFlags))) { UNLOCK(pe->PELock); - return(FALSE); + return (FALSE); } ARG4 = Deref(ARG4); if (IsVarTerm(ARG4)) { @@ -1090,7 +1177,7 @@ p_flags( USES_REGS1 ) } else { UNLOCK(pe->PELock); Yap_Error(TYPE_ERROR_INTEGER, ARG4, "flags"); - return(FALSE); + return (FALSE); } } else newFl = IntegerOfTerm(ARG4); @@ -1099,35 +1186,34 @@ p_flags( USES_REGS1 ) return TRUE; } -static Int -p_set_flag( USES_REGS1 ) -{ /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */ - PredEntry *pe; +static Int + p_set_flag(USES_REGS1) { /* $flags(+Functor,+Mod,?OldFlags,?NewFlags) */ + PredEntry *pe; Term t1 = Deref(ARG1); Term mod = Deref(ARG2); Term v = Deref(ARG4); char *s; if (IsVarTerm(mod) || !IsAtomTerm(mod)) { - return(FALSE); + return (FALSE); } if (IsVarTerm(t1)) return (FALSE); if (IsAtomTerm(t1)) { - while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)))== NULL) { + while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod))) == NULL) { if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); - return FALSE; + Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); + return FALSE; } t1 = Deref(ARG1); mod = Deref(ARG2); } } else if (IsApplTerm(t1)) { - Functor funt = FunctorOfTerm(t1); - while ((pe = RepPredProp(PredPropByFunc(funt, mod)))== NULL) { + Functor funt = FunctorOfTerm(t1); + while ((pe = RepPredProp(PredPropByFunc(funt, mod))) == NULL) { if (!Yap_growheap(FALSE, 0, NULL)) { - Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); - return FALSE; + Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate"); + return FALSE; } t1 = Deref(ARG1); mod = Deref(ARG2); @@ -1141,47 +1227,45 @@ p_set_flag( USES_REGS1 ) UNLOCK(pe->PELock); return (FALSE); } else if (!IsAtomTerm(ARG3)) { - Yap_Error(TYPE_ERROR_ATOM,ARG3,"set_property/1"); - return(FALSE); + Yap_Error(TYPE_ERROR_ATOM, ARG3, "set_property/1"); + return (FALSE); } v = Deref(ARG4); if (IsVarTerm(ARG4)) { UNLOCK(pe->PELock); return (FALSE); } else if (!IsIntTerm(v)) { - Yap_Error(TYPE_ERROR_ATOM,v,"set_property/1"); - return(FALSE); + Yap_Error(TYPE_ERROR_ATOM, v, "set_property/1"); + return (FALSE); } s = RepAtom(AtomOfTerm(ARG3))->StrOfAE; if (v == MkIntTerm(1)) { if (!strcmp(s, "quasi_quotation_syntax")) { - pe->ExtraPredFlags |= QuasiQuotationPredFlag; + pe->PredFlags |= QuasiQuotationPredFlag; } else if (!strcmp(s, "trace")) { // proc->ExtraPredFlags |= QuasiQuotationPredFlag; } else { - fprintf( stderr, "not implemented"); + fprintf(stderr, "not implemented"); UNLOCK(pe->PELock); return FALSE; } } else if (v == MkIntTerm(0)) { if (!strcmp(s, "quasi_quotation_syntax")) { - pe->ExtraPredFlags &= ~QuasiQuotationPredFlag; + pe->PredFlags &= ~QuasiQuotationPredFlag; } else if (!strcmp(s, "trace")) { - // proc->ExtraPredFlags |= QuasiQuotationPredFlag; + // proc->PredFlags |= QuasiQuotationPredFlag; } else { - fprintf( stderr, "not implemented"); + fprintf(stderr, "not implemented"); UNLOCK(pe->PELock); return FALSE; } } - + UNLOCK(pe->PELock); return TRUE; } -void -Yap_show_statistics(void) -{ +void Yap_show_statistics(void) { CACHE_REGS unsigned long int heap_space_taken; double frag; @@ -1189,48 +1273,50 @@ Yap_show_statistics(void) #if USE_SYSTEM_MALLOC && HAVE_MALLINFO struct mallinfo mi = mallinfo(); - heap_space_taken = (mi.arena+mi.hblkhd)-Yap_HoleSize; + heap_space_taken = (mi.arena + mi.hblkhd) - Yap_HoleSize; #else - heap_space_taken = - (unsigned long int)(Unsigned(HeapTop)-Unsigned(Yap_HeapBase))-Yap_HoleSize; + heap_space_taken = + (unsigned long int)(Unsigned(HeapTop) - Unsigned(Yap_HeapBase)) - + Yap_HoleSize; #endif - frag = (100.0*(heap_space_taken-HeapUsed))/heap_space_taken; + frag = (100.0 * (heap_space_taken - HeapUsed)) / heap_space_taken; - Sfprintf(GLOBAL_stderr, "Code Space: %ld (%ld bytes needed, %ld bytes used, fragmentation %.3f%%).\n", - (unsigned long int)(Unsigned (H0) - Unsigned (Yap_HeapBase)), - (unsigned long int)(Unsigned(HeapTop)-Unsigned(Yap_HeapBase)), - (unsigned long int)(HeapUsed), - frag); - Sfprintf(GLOBAL_stderr, "Stack Space: %ld (%ld for Global, %ld for local).\n", - (unsigned long int)(sizeof(CELL)*(LCL0-H0)), - (unsigned long int)(sizeof(CELL)*(HR-H0)), - (unsigned long int)(sizeof(CELL)*(LCL0-ASP))); - Sfprintf(GLOBAL_stderr, "Trail Space: %ld (%ld used).\n", - (unsigned long int)(sizeof(tr_fr_ptr)*(Unsigned(LOCAL_TrailTop)-Unsigned(LOCAL_TrailBase))), - (unsigned long int)(sizeof(tr_fr_ptr)*(Unsigned(TR)-Unsigned(LOCAL_TrailBase)))); - Sfprintf(GLOBAL_stderr, "Runtime: %lds.\n", (unsigned long int)(runtime ( PASS_REGS1 ))); - Sfprintf(GLOBAL_stderr, "Cputime: %lds.\n", (unsigned long int)(Yap_cputime ())); - Sfprintf(GLOBAL_stderr, "Walltime: %lds.\n", (unsigned long int)(Yap_walltime ())); + Sfprintf(GLOBAL_stderr, "Code Space: %ld (%ld bytes needed, %ld bytes used, " + "fragmentation %.3f%%).\n", + (unsigned long int)(Unsigned(H0) - Unsigned(Yap_HeapBase)), + (unsigned long int)(Unsigned(HeapTop) - Unsigned(Yap_HeapBase)), + (unsigned long int)(HeapUsed), frag); + Sfprintf(GLOBAL_stderr, "Stack Space: %ld (%ld for Global, %ld for local).\n", + (unsigned long int)(sizeof(CELL) * (LCL0 - H0)), + (unsigned long int)(sizeof(CELL) * (HR - H0)), + (unsigned long int)(sizeof(CELL) * (LCL0 - ASP))); + Sfprintf(GLOBAL_stderr, "Trail Space: %ld (%ld used).\n", + (unsigned long int)(sizeof(tr_fr_ptr) * (Unsigned(LOCAL_TrailTop) - + Unsigned(LOCAL_TrailBase))), + (unsigned long int)(sizeof(tr_fr_ptr) * + (Unsigned(TR) - Unsigned(LOCAL_TrailBase)))); + Sfprintf(GLOBAL_stderr, "Runtime: %lds.\n", + (unsigned long int)(runtime(PASS_REGS1))); + Sfprintf(GLOBAL_stderr, "Cputime: %lds.\n", + (unsigned long int)(Yap_cputime())); + Sfprintf(GLOBAL_stderr, "Walltime: %lds.\n", + (unsigned long int)(Yap_walltime())); } -static Int -p_statistics_heap_max( USES_REGS1 ) -{ +static Int p_statistics_heap_max(USES_REGS1) { Term tmax = MkIntegerTerm(HeapMax); - return(Yap_unify(tmax, ARG1)); + return (Yap_unify(tmax, ARG1)); } /* The results of the next routines are not to be trusted too */ /* much. Basically, any stack shifting will seriously confuse the */ /* results */ -static Int TrailTide = -1, LocalTide = -1, GlobalTide = -1; +static Int TrailTide = -1, LocalTide = -1, GlobalTide = -1; /* maximum Trail usage */ -static Int -TrailMax(void) -{ +static Int TrailMax(void) { CACHE_REGS Int i; Int TrWidth = Unsigned(LOCAL_TrailTop) - Unsigned(LOCAL_TrailBase); @@ -1238,40 +1324,33 @@ TrailMax(void) if (TrailTide != TrWidth) { pt = (CELL *)TR; - while (pt+2 < (CELL *)LOCAL_TrailTop) { - if (pt[0] == 0 && - pt[1] == 0 && - pt[2] == 0) - break; + while (pt + 2 < (CELL *)LOCAL_TrailTop) { + if (pt[0] == 0 && pt[1] == 0 && pt[2] == 0) + break; else - pt++; + pt++; } - if (pt+2 < (CELL *)LOCAL_TrailTop) + if (pt + 2 < (CELL *)LOCAL_TrailTop) i = Unsigned(pt) - Unsigned(LOCAL_TrailBase); else i = TrWidth; } else - return(TrWidth); + return (TrWidth); if (TrailTide > i) i = TrailTide; else TrailTide = i; - return(i); + return (i); } -static Int -p_statistics_trail_max( USES_REGS1 ) -{ +static Int p_statistics_trail_max(USES_REGS1) { Term tmax = MkIntegerTerm(TrailMax()); - return(Yap_unify(tmax, ARG1)); - + return (Yap_unify(tmax, ARG1)); } /* maximum Global usage */ -static Int -GlobalMax(void) -{ +static Int GlobalMax(void) { CACHE_REGS Int i; Int StkWidth = Unsigned(LCL0) - Unsigned(H0); @@ -1279,41 +1358,33 @@ GlobalMax(void) if (GlobalTide != StkWidth) { pt = HR; - while (pt+2 < ASP) { - if (pt[0] == 0 && - pt[1] == 0 && - pt[2] == 0) - break; + while (pt + 2 < ASP) { + if (pt[0] == 0 && pt[1] == 0 && pt[2] == 0) + break; else - pt++; + pt++; } - if (pt+2 < ASP) + if (pt + 2 < ASP) i = Unsigned(pt) - Unsigned(H0); else /* so that both Local and Global have reached maximum width */ GlobalTide = LocalTide = i = StkWidth; } else - return(StkWidth); + return (StkWidth); if (GlobalTide > i) i = GlobalTide; else GlobalTide = i; - return(i); + return (i); } -static Int -p_statistics_global_max( USES_REGS1 ) -{ +static Int p_statistics_global_max(USES_REGS1) { Term tmax = MkIntegerTerm(GlobalMax()); - return(Yap_unify(tmax, ARG1)); - + return (Yap_unify(tmax, ARG1)); } - -static Int -LocalMax(void) -{ +static Int LocalMax(void) { CACHE_REGS Int i; Int StkWidth = Unsigned(LCL0) - Unsigned(H0); @@ -1321,89 +1392,70 @@ LocalMax(void) if (LocalTide != StkWidth) { pt = LCL0; - while (pt-3 > HR) { - if (pt[-1] == 0 && - pt[-2] == 0 && - pt[-3] == 0) - break; + while (pt - 3 > HR) { + if (pt[-1] == 0 && pt[-2] == 0 && pt[-3] == 0) + break; else - --pt; + --pt; } - if (pt-3 > HR) + if (pt - 3 > HR) i = Unsigned(LCL0) - Unsigned(pt); else /* so that both Local and Global have reached maximum width */ GlobalTide = LocalTide = i = StkWidth; } else - return(StkWidth); + return (StkWidth); if (LocalTide > i) i = LocalTide; else LocalTide = i; - return(i); + return (i); } -static Int -p_statistics_local_max( USES_REGS1 ) -{ +static Int p_statistics_local_max(USES_REGS1) { Term tmax = MkIntegerTerm(LocalMax()); - return(Yap_unify(tmax, ARG1)); - + return (Yap_unify(tmax, ARG1)); } - - -static Int -p_statistics_heap_info( USES_REGS1 ) -{ +static Int p_statistics_heap_info(USES_REGS1) { Term tusage = MkIntegerTerm(HeapUsed); #if USE_SYSTEM_MALLOC && HAVE_MALLINFO struct mallinfo mi = mallinfo(); - UInt sstack = Yap_HoleSize+(LOCAL_TrailTop-LOCAL_GlobalBase); - UInt mmax = (mi.arena+mi.hblkhd); - Term tmax = MkIntegerTerm(mmax-sstack); - tusage = MkIntegerTerm(mmax-(mi.fordblks+sstack)); + UInt sstack = Yap_HoleSize + (LOCAL_TrailTop - LOCAL_GlobalBase); + UInt mmax = (mi.arena + mi.hblkhd); + Term tmax = MkIntegerTerm(mmax - sstack); + tusage = MkIntegerTerm(mmax - (mi.fordblks + sstack)); #else - Term tmax = MkIntegerTerm((LOCAL_GlobalBase - Yap_HeapBase)-Yap_HoleSize); + Term tmax = MkIntegerTerm((LOCAL_GlobalBase - Yap_HeapBase) - Yap_HoleSize); #endif - return(Yap_unify(tmax, ARG1) && Yap_unify(tusage,ARG2)); - + return (Yap_unify(tmax, ARG1) && Yap_unify(tusage, ARG2)); } - -static Int -p_statistics_stacks_info( USES_REGS1 ) -{ +static Int p_statistics_stacks_info(USES_REGS1) { Term tmax = MkIntegerTerm(Unsigned(LCL0) - Unsigned(H0)); Term tgusage = MkIntegerTerm(Unsigned(HR) - Unsigned(H0)); Term tlusage = MkIntegerTerm(Unsigned(LCL0) - Unsigned(ASP)); - return(Yap_unify(tmax, ARG1) && Yap_unify(tgusage,ARG2) && Yap_unify(tlusage,ARG3)); - + return (Yap_unify(tmax, ARG1) && Yap_unify(tgusage, ARG2) && + Yap_unify(tlusage, ARG3)); } - - -static Int -p_statistics_trail_info( USES_REGS1 ) -{ - Term tmax = MkIntegerTerm(Unsigned(LOCAL_TrailTop) - Unsigned(LOCAL_TrailBase)); +static Int p_statistics_trail_info(USES_REGS1) { + Term tmax = + MkIntegerTerm(Unsigned(LOCAL_TrailTop) - Unsigned(LOCAL_TrailBase)); Term tusage = MkIntegerTerm(Unsigned(TR) - Unsigned(LOCAL_TrailBase)); - return(Yap_unify(tmax, ARG1) && Yap_unify(tusage,ARG2)); - + return (Yap_unify(tmax, ARG1) && Yap_unify(tusage, ARG2)); } -static Int -p_statistics_atom_info( USES_REGS1 ) -{ +static Int p_statistics_atom_info(USES_REGS1) { UInt count = 0, spaceused = 0, i; - for (i =0; i < AtomHashTableSize; i++) { + for (i = 0; i < AtomHashTableSize; i++) { Atom catom; READ_LOCK(HashChain[i].AERWLock); @@ -1415,16 +1467,16 @@ p_statistics_atom_info( USES_REGS1 ) while (catom != NIL) { Atom ncatom; count++; - spaceused += sizeof(AtomEntry)+strlen(RepAtom(catom)->StrOfAE)+1; + spaceused += sizeof(AtomEntry) + strlen(RepAtom(catom)->StrOfAE) + 1; ncatom = RepAtom(catom)->NextOfAE; if (ncatom != NIL) { - READ_LOCK(RepAtom(ncatom)->ARWLock); + READ_LOCK(RepAtom(ncatom)->ARWLock); } READ_UNLOCK(RepAtom(catom)->ARWLock); catom = ncatom; } } - for (i =0; i < WideAtomHashTableSize; i++) { + for (i = 0; i < WideAtomHashTableSize; i++) { Atom catom; READ_LOCK(WideHashChain[i].AERWLock); @@ -1436,59 +1488,44 @@ p_statistics_atom_info( USES_REGS1 ) while (catom != NIL) { Atom ncatom; count++; - spaceused += sizeof(AtomEntry)+sizeof(wchar_t)*(wcslen((wchar_t *)( RepAtom(catom)->StrOfAE)+1)); + spaceused += + sizeof(AtomEntry) + + sizeof(wchar_t) * (wcslen((wchar_t *)(RepAtom(catom)->StrOfAE) + 1)); ncatom = RepAtom(catom)->NextOfAE; if (ncatom != NIL) { - READ_LOCK(RepAtom(ncatom)->ARWLock); + READ_LOCK(RepAtom(ncatom)->ARWLock); } READ_UNLOCK(RepAtom(catom)->ARWLock); catom = ncatom; } } return Yap_unify(ARG1, MkIntegerTerm(count)) && - Yap_unify(ARG2, MkIntegerTerm(spaceused)); + Yap_unify(ARG2, MkIntegerTerm(spaceused)); } - -static Int -p_statistics_db_size( USES_REGS1 ) -{ +static Int p_statistics_db_size(USES_REGS1) { Term t = MkIntegerTerm(Yap_ClauseSpace); Term tit = MkIntegerTerm(Yap_IndexSpace_Tree); Term tis = MkIntegerTerm(Yap_IndexSpace_SW); Term tie = MkIntegerTerm(Yap_IndexSpace_EXT); - return - Yap_unify(t, ARG1) && - Yap_unify(tit, ARG2) && - Yap_unify(tis, ARG3) && - Yap_unify(tie, ARG4); - + return Yap_unify(t, ARG1) && Yap_unify(tit, ARG2) && Yap_unify(tis, ARG3) && + Yap_unify(tie, ARG4); } -static Int -p_statistics_lu_db_size( USES_REGS1 ) -{ +static Int p_statistics_lu_db_size(USES_REGS1) { Term t = MkIntegerTerm(Yap_LUClauseSpace); Term tit = MkIntegerTerm(Yap_LUIndexSpace_Tree); Term tic = MkIntegerTerm(Yap_LUIndexSpace_CP); Term tix = MkIntegerTerm(Yap_LUIndexSpace_EXT); Term tis = MkIntegerTerm(Yap_LUIndexSpace_SW); - return - Yap_unify(t, ARG1) && - Yap_unify(tit, ARG2) && - Yap_unify(tic, ARG3) && - Yap_unify(tis, ARG4) && - Yap_unify(tix, ARG5); + return Yap_unify(t, ARG1) && Yap_unify(tit, ARG2) && Yap_unify(tic, ARG3) && + Yap_unify(tis, ARG4) && Yap_unify(tix, ARG5); } - - -static Term -mk_argc_list( USES_REGS1 ) -{ - int i =0; +static Term mk_argc_list(USES_REGS1) { + int i = 0; Term t = TermNil; while (i < GLOBAL_argc) { char *arg = GLOBAL_argv[i]; @@ -1496,91 +1533,83 @@ mk_argc_list( USES_REGS1 ) if (arg[0] == '-' && arg[1] == 'L') { arg += 2; while (*arg != '\0' && (*arg == ' ' || *arg == '\t')) - arg++; + arg++; if (*arg == '-' && arg[1] == '-' && arg[2] == '\0') { - /* we found the separator */ - int j; - for (j = GLOBAL_argc-1; j > i+1; --j) { - t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])),t); - } - return t; - } else if (GLOBAL_argv[i+1] && GLOBAL_argv[i+1][0] == '-' && GLOBAL_argv[i+1][1] == '-' && GLOBAL_argv[i+1][2] == '\0') { - /* we found the separator */ - int j; - for (j = GLOBAL_argc-1; j > i+2; --j) { - t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])),t); - } - return t; + /* we found the separator */ + int j; + for (j = GLOBAL_argc - 1; j > i + 1; --j) { + t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])), t); + } + return t; + } else if (GLOBAL_argv[i + 1] && GLOBAL_argv[i + 1][0] == '-' && + GLOBAL_argv[i + 1][1] == '-' && + GLOBAL_argv[i + 1][2] == '\0') { + /* we found the separator */ + int j; + for (j = GLOBAL_argc - 1; j > i + 2; --j) { + t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])), t); + } + return t; } } if (arg[0] == '-' && arg[1] == '-' && arg[2] == '\0') { /* we found the separator */ int j; - for (j = GLOBAL_argc-1; j > i; --j) { - t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])),t); + for (j = GLOBAL_argc - 1; j > i; --j) { + t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(GLOBAL_argv[j])), t); } - return(t); + return (t); } i++; - } - return(t); + } + return (t); } -static Term -mk_os_argc_list( USES_REGS1 ) -{ - int i =0; +static Term mk_os_argc_list(USES_REGS1) { + int i = 0; Term t = TermNil; - for (i = 0 ; i < GLOBAL_argc; i++) { + for (i = 0; i < GLOBAL_argc; i++) { char *arg = GLOBAL_argv[i]; - t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(arg)),t); - } - return(t); + t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(arg)), t); + } + return (t); } -static Int -p_argv( USES_REGS1 ) -{ - Term t = mk_argc_list( PASS_REGS1 ); +static Int p_argv(USES_REGS1) { + Term t = mk_argc_list(PASS_REGS1); return Yap_unify(t, ARG1); } -static Int -p_os_argv( USES_REGS1 ) -{ - Term t = mk_os_argc_list( PASS_REGS1 ); +static Int p_os_argv(USES_REGS1) { + Term t = mk_os_argc_list(PASS_REGS1); return Yap_unify(t, ARG1); } -static Int -p_executable( USES_REGS1 ) -{ +static Int p_executable(USES_REGS1) { if (GLOBAL_argv && GLOBAL_argv[0]) - Yap_TrueFileName (GLOBAL_argv[0], LOCAL_FileNameBuf, FALSE); + Yap_TrueFileName(GLOBAL_argv[0], LOCAL_FileNameBuf, FALSE); else - strncpy(LOCAL_FileNameBuf, Yap_FindExecutable(), YAP_FILENAME_MAX-1) ; + strncpy(LOCAL_FileNameBuf, Yap_FindExecutable(), YAP_FILENAME_MAX - 1); - return Yap_unify(MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf)),ARG1); + return Yap_unify(MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf)), ARG1); } -static Int -p_access_yap_flags( USES_REGS1 ) -{ +static Int p_access_yap_flags(USES_REGS1) { Term tflag = Deref(ARG1); Int flag; Term tout = 0; if (IsVarTerm(tflag)) { Yap_Error(INSTANTIATION_ERROR, tflag, "access_yap_flags/2"); - return(FALSE); + return (FALSE); } if (!IsIntTerm(tflag)) { Yap_Error(TYPE_ERROR_INTEGER, tflag, "access_yap_flags/2"); - return(FALSE); + return (FALSE); } flag = IntOfTerm(tflag); if (flag < 0 || flag >= NUMBER_OF_YAP_FLAGS) { - return(FALSE); + return (FALSE); } if (flag == TABLING_MODE_FLAG) { #ifdef TABLING @@ -1603,188 +1632,181 @@ p_access_yap_flags( USES_REGS1 ) tout = MkAtomTerm(AtomFalse); #endif /* TABLING */ } else - tout = MkIntegerTerm(yap_flags[flag]); - return(Yap_unify(ARG2, tout)); + tout = MkIntegerTerm(yap_flags[flag]); + return (Yap_unify(ARG2, tout)); } -static Int -p_has_yap_or( USES_REGS1 ) -{ +static Int p_has_yap_or(USES_REGS1) { #ifdef YAPOR - return(TRUE); + return (TRUE); #else - return(FALSE); + return (FALSE); #endif } -static Int -p_has_eam( USES_REGS1 ) -{ +static Int p_has_eam(USES_REGS1) { #ifdef BEAM - return(TRUE); + return (TRUE); #else - return(FALSE); + return (FALSE); #endif } - -static Int -p_set_yap_flags( USES_REGS1 ) -{ +static Int p_set_yap_flags(USES_REGS1) { Term tflag = Deref(ARG1); Term tvalue = Deref(ARG2); Int flag, value; if (IsVarTerm(tflag)) { Yap_Error(INSTANTIATION_ERROR, tflag, "set_yap_flags/2"); - return(FALSE); + return (FALSE); } if (!IsIntTerm(tflag)) { Yap_Error(TYPE_ERROR_INTEGER, tflag, "set_yap_flags/2"); - return(FALSE); + return (FALSE); } flag = IntOfTerm(tflag); if (IsVarTerm(tvalue)) { Yap_Error(INSTANTIATION_ERROR, tvalue, "set_yap_flags/2"); - return(FALSE); + return (FALSE); } if (!IsIntTerm(tvalue)) { Yap_Error(TYPE_ERROR_INTEGER, tvalue, "set_yap_flags/2"); - return(FALSE); + return (FALSE); } value = IntOfTerm(tvalue); /* checking should have been performed */ - switch(flag) { + switch (flag) { case LANGUAGE_MODE_FLAG: if (value < 0 || value > 2) - return(FALSE); + return (FALSE); if (value == 1) { - Yap_heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(FunctorMetaCall,0)); + Yap_heap_regs->pred_meta_call = + RepPredProp(PredPropByFunc(FunctorMetaCall, 0)); } else { - Yap_heap_regs->pred_meta_call = RepPredProp(PredPropByFunc(FunctorMetaCall,0)); + Yap_heap_regs->pred_meta_call = + RepPredProp(PredPropByFunc(FunctorMetaCall, 0)); } yap_flags[LANGUAGE_MODE_FLAG] = value; break; case SOURCE_MODE_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[SOURCE_MODE_FLAG] = value; break; case FLOATING_POINT_EXCEPTION_MODE_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[FLOATING_POINT_EXCEPTION_MODE_FLAG] = value; break; case WRITE_QUOTED_STRING_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[WRITE_QUOTED_STRING_FLAG] = value; break; case ALLOW_ASSERTING_STATIC_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[ALLOW_ASSERTING_STATIC_FLAG] = value; break; case STACK_DUMP_ON_ERROR_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[STACK_DUMP_ON_ERROR_FLAG] = value; break; case INDEXING_MODE_FLAG: - if (value < INDEX_MODE_OFF || value > INDEX_MODE_MAX) - return(FALSE); + if (value < INDEX_MODE_OFF || value > INDEX_MODE_MAX) + return (FALSE); yap_flags[INDEXING_MODE_FLAG] = value; break; #ifdef TABLING case TABLING_MODE_FLAG: - if (value == 0) { /* default */ + if (value == 0) { /* default */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - TabEnt_mode(tab_ent) = TabEnt_flags(tab_ent); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + TabEnt_mode(tab_ent) = TabEnt_flags(tab_ent); + tab_ent = TabEnt_next(tab_ent); } yap_flags[TABLING_MODE_FLAG] = 0; - } else if (value == 1) { /* batched */ + } else if (value == 1) { /* batched */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_Batched(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_Batched(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_Batched(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 2) { /* local */ + } else if (value == 2) { /* local */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_Local(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_Local(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_Local(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 3) { /* exec_answers */ + } else if (value == 3) { /* exec_answers */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_ExecAnswers(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_ExecAnswers(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_ExecAnswers(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 4) { /* load_answers */ + } else if (value == 4) { /* load_answers */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_LoadAnswers(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_LoadAnswers(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 5) { /* local_trie */ + } else if (value == 5) { /* local_trie */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_LocalTrie(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_LocalTrie(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_LocalTrie(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 6) { /* global_trie */ + } else if (value == 6) { /* global_trie */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { - SetMode_GlobalTrie(TabEnt_mode(tab_ent)); - tab_ent = TabEnt_next(tab_ent); + while (tab_ent) { + SetMode_GlobalTrie(TabEnt_mode(tab_ent)); + tab_ent = TabEnt_next(tab_ent); } SetMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG]); - } else if (value == 7) { /* CoInductive */ + } else if (value == 7) { /* CoInductive */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; - while(tab_ent) { + while (tab_ent) { SetMode_CoInductive(TabEnt_mode(tab_ent)); tab_ent = TabEnt_next(tab_ent); } SetMode_CoInductive(yap_flags[TABLING_MODE_FLAG]); - } + } break; #endif /* TABLING */ case VARS_CAN_HAVE_QUOTE_FLAG: - if (value != 0 && value != 1) - return(FALSE); + if (value != 0 && value != 1) + return (FALSE); yap_flags[VARS_CAN_HAVE_QUOTE_FLAG] = value; break; case QUIET_MODE_FLAG: - if (value != 0 && value != 1) + if (value != 0 && value != 1) return FALSE; yap_flags[QUIET_MODE_FLAG] = value; break; default: - return(FALSE); + return (FALSE); } - return(TRUE); + return (TRUE); } -static Int -p_system_mode( USES_REGS1 ) -{ +static Int p_system_mode(USES_REGS1) { Term t1 = Deref(ARG1); if (IsVarTerm(t1)) { if (LOCAL_PrologMode & SystemMode) - return Yap_unify( t1, MkAtomTerm(AtomTrue)); + return Yap_unify(t1, MkAtomTerm(AtomTrue)); else - return Yap_unify( t1, MkAtomTerm(AtomFalse)); + return Yap_unify(t1, MkAtomTerm(AtomFalse)); } else { Atom at = AtomOfTerm(t1); - if (at == AtomFalse) + if (at == AtomFalse) LOCAL_PrologMode &= ~SystemMode; else LOCAL_PrologMode |= SystemMode; @@ -1792,23 +1814,17 @@ p_system_mode( USES_REGS1 ) return TRUE; } -static Int -p_lock_system( USES_REGS1 ) -{ +static Int p_lock_system(USES_REGS1) { LOCK(GLOBAL_BGL); return TRUE; } -static Int -p_unlock_system( USES_REGS1 ) -{ +static Int p_unlock_system(USES_REGS1) { UNLOCK(GLOBAL_BGL); return TRUE; } -static Int -p_enterundefp( USES_REGS1 ) -{ +static Int p_enterundefp(USES_REGS1) { if (LOCAL_DoingUndefp) { return FALSE; } @@ -1816,9 +1832,7 @@ p_enterundefp( USES_REGS1 ) return TRUE; } -static Int -p_exitundefp( USES_REGS1 ) -{ +static Int p_exitundefp(USES_REGS1) { if (LOCAL_DoingUndefp) { LOCAL_DoingUndefp = FALSE; return TRUE; @@ -1829,38 +1843,37 @@ p_exitundefp( USES_REGS1 ) #ifdef DEBUG extern void DumpActiveGoals(void); -static Int -p_dump_active_goals( USES_REGS1 ) { +static Int p_dump_active_goals(USES_REGS1) { DumpActiveGoals(); - return(TRUE); + return (TRUE); } #endif #ifdef INES -static Int -p_euc_dist( USES_REGS1 ) { +static Int p_euc_dist(USES_REGS1) { Term t1 = Deref(ARG1); Term t2 = Deref(ARG2); - double d1 = (double)(IntegerOfTerm(ArgOfTerm(1,t1))-IntegerOfTerm(ArgOfTerm(1,t2))); - double d2 = (double)(IntegerOfTerm(ArgOfTerm(2,t1))-IntegerOfTerm(ArgOfTerm(2,t2))); - double d3 = (double)(IntegerOfTerm(ArgOfTerm(3,t1))-IntegerOfTerm(ArgOfTerm(3,t2))); - Int result = (Int)sqrt(d1*d1+d2*d2+d3*d3); - return(Yap_unify(ARG3,MkIntegerTerm(result))); + double d1 = (double)(IntegerOfTerm(ArgOfTerm(1, t1)) - + IntegerOfTerm(ArgOfTerm(1, t2))); + double d2 = (double)(IntegerOfTerm(ArgOfTerm(2, t1)) - + IntegerOfTerm(ArgOfTerm(2, t2))); + double d3 = (double)(IntegerOfTerm(ArgOfTerm(3, t1)) - + IntegerOfTerm(ArgOfTerm(3, t2))); + Int result = (Int)sqrt(d1 * d1 + d2 * d2 + d3 * d3); + return (Yap_unify(ARG3, MkIntegerTerm(result))); } volatile int loop_counter = 0; -static Int -p_loop( USES_REGS1 ) { - while (loop_counter == 0); - return(TRUE); +static Int p_loop(USES_REGS1) { + while (loop_counter == 0) + ; + return (TRUE); } #endif - -static Int -p_break( USES_REGS1 ) { - Atom at = AtomOfTerm(Deref( ARG1 )); +static Int p_break(USES_REGS1) { + Atom at = AtomOfTerm(Deref(ARG1)); if (at == AtomTrue) { LOCAL_PL_local_data_p->break_level++; return TRUE; @@ -1872,20 +1885,15 @@ p_break( USES_REGS1 ) { return FALSE; } -void -Yap_InitBackCPreds(void) -{ - Yap_InitCPredBack("$current_predicate", 3, 1, init_current_predicate, cont_current_predicate, - SafePredFlag|SyncPredFlag); - Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom, - SafePredFlag|SyncPredFlag); +void Yap_InitBackCPreds(void) { + Yap_InitCPredBack("$current_predicate", 4, 2, init_current_predicate, + cont_current_predicate, SafePredFlag | SyncPredFlag); Yap_InitCPredBack("$current_op", 5, 1, init_current_op, cont_current_op, - SafePredFlag|SyncPredFlag); - Yap_InitCPredBack("$current_atom_op", 5, 1, init_current_atom_op, cont_current_atom_op, - SafePredFlag|SyncPredFlag); + SafePredFlag | SyncPredFlag); + Yap_InitCPredBack("$current_atom_op", 5, 1, init_current_atom_op, + cont_current_atom_op, SafePredFlag | SyncPredFlag); #ifdef BEAM - Yap_InitCPredBack("eam", 1, 0, start_eam, cont_eam, - SafePredFlag); + Yap_InitCPredBack("eam", 1, 0, start_eam, cont_eam, SafePredFlag); #endif Yap_InitBackAtoms(); @@ -1896,110 +1904,115 @@ Yap_InitBackCPreds(void) typedef void (*Proc)(void); -Proc E_Modules[]= {/* init_fc,*/ (Proc) 0 }; +Proc E_Modules[] = {/* init_fc,*/ (Proc)0}; #ifndef YAPOR -static Int p_parallel_mode( USES_REGS1 ) { - return FALSE; -} +static Int p_parallel_mode(USES_REGS1) { return FALSE; } -static Int p_yapor_workers( USES_REGS1 ) { - return FALSE; -} +static Int p_yapor_workers(USES_REGS1) { return FALSE; } #endif /* YAPOR */ - -void -Yap_InitCPreds(void) -{ +void Yap_InitCPreds(void) { /* numerical comparison */ - Yap_InitCPred("set_value", 2, p_setval, SafePredFlag|SyncPredFlag); -/** @pred set_value(+ _A_,+ _C_) + Yap_InitCPred("set_value", 2, p_setval, SafePredFlag | SyncPredFlag); + /** @pred set_value(+ _A_,+ _C_) -Associate atom _A_ with constant _C_. + Associate atom _A_ with constant _C_. -The `set_value` and `get_value` built-ins give a fast alternative to -the internal data-base. This is a simple form of implementing a global -counter. + The `set_value` and `get_value` built-ins give a fast alternative to + the internal data-base. This is a simple form of implementing a global + counter. -~~~~~ - read_and_increment_counter(Value) :- - get_value(counter, Value), - Value1 is Value+1, - set_value(counter, Value1). -~~~~~ -This predicate is YAP specific. + ~~~~~ + read_and_increment_counter(Value) :- + get_value(counter, Value), + Value1 is Value+1, + set_value(counter, Value1). + ~~~~~ + This predicate is YAP specific. - -*/ - Yap_InitCPred("get_value", 2, p_value, TestPredFlag|SafePredFlag|SyncPredFlag); -/** @pred get_value(+ _A_,- _V_) + + */ + Yap_InitCPred("get_value", 2, p_value, + TestPredFlag | SafePredFlag | SyncPredFlag); + /** @pred get_value(+ _A_,- _V_) -In YAP, atoms can be associated with constants. If one such -association exists for atom _A_, unify the second argument with the -constant. Otherwise, unify _V_ with `[]`. + In YAP, atoms can be associated with constants. If one such + association exists for atom _A_, unify the second argument with the + constant. Otherwise, unify _V_ with `[]`. -This predicate is YAP specific. + This predicate is YAP specific. - -*/ - Yap_InitCPred("$values", 3, p_values, SafePredFlag|SyncPredFlag); + + */ + Yap_InitCPred("$values", 3, p_values, SafePredFlag | SyncPredFlag); /* general purpose */ - Yap_InitCPred("$opdec", 4, p_opdec, SafePredFlag|SyncPredFlag); + Yap_InitCPred("$opdec", 4, p_opdec, SafePredFlag | SyncPredFlag); Yap_InitCPred("=..", 2, p_univ, 0); -/** @pred _T_ =.. _L_ is iso + /** @pred _T_ =.. _L_ is iso -The list _L_ is built with the functor and arguments of the term - _T_. If _T_ is instantiated to a variable, then _L_ must be -instantiated either to a list whose head is an atom, or to a list -consisting of just a number. + The list _L_ is built with the functor and arguments of the term + _T_. If _T_ is instantiated to a variable, then _L_ must be + instantiated either to a list whose head is an atom, or to a list + consisting of just a number. - -*/ - Yap_InitCPred("$statistics_trail_max", 1, p_statistics_trail_max, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_heap_max", 1, p_statistics_heap_max, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_global_max", 1, p_statistics_global_max, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_local_max", 1, p_statistics_local_max, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_heap_info", 2, p_statistics_heap_info, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_stacks_info", 3, p_statistics_stacks_info, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_trail_info", 2, p_statistics_trail_info, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_atom_info", 2, p_statistics_atom_info, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_db_size", 4, p_statistics_db_size, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$statistics_lu_db_size", 5, p_statistics_lu_db_size, SafePredFlag|SyncPredFlag); + + */ + Yap_InitCPred("$statistics_trail_max", 1, p_statistics_trail_max, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_heap_max", 1, p_statistics_heap_max, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_global_max", 1, p_statistics_global_max, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_local_max", 1, p_statistics_local_max, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_heap_info", 2, p_statistics_heap_info, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_stacks_info", 3, p_statistics_stacks_info, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_trail_info", 2, p_statistics_trail_info, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_atom_info", 2, p_statistics_atom_info, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_db_size", 4, p_statistics_db_size, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$statistics_lu_db_size", 5, p_statistics_lu_db_size, + SafePredFlag | SyncPredFlag); Yap_InitCPred("$argv", 1, p_argv, SafePredFlag); Yap_InitCPred("$os_argv", 1, p_os_argv, SafePredFlag); Yap_InitCPred("$executable", 1, p_executable, SafePredFlag); - Yap_InitCPred("$runtime", 2, p_runtime, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$cputime", 2, p_cputime, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$systime", 2, p_systime, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$walltime", 2, p_walltime, SafePredFlag|SyncPredFlag); + Yap_InitCPred("$runtime", 2, p_runtime, SafePredFlag | SyncPredFlag); + Yap_InitCPred("$cputime", 2, p_cputime, SafePredFlag | SyncPredFlag); + Yap_InitCPred("$systime", 2, p_systime, SafePredFlag | SyncPredFlag); + Yap_InitCPred("$walltime", 2, p_walltime, SafePredFlag | SyncPredFlag); Yap_InitCPred("$access_yap_flags", 2, p_access_yap_flags, SafePredFlag); - Yap_InitCPred("$set_yap_flags", 2, p_set_yap_flags, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$system_mode", 1, p_system_mode, SafePredFlag|SyncPredFlag); + Yap_InitCPred("$set_yap_flags", 2, p_set_yap_flags, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$system_mode", 1, p_system_mode, SafePredFlag | SyncPredFlag); Yap_InitCPred("abort", 0, p_abort, SyncPredFlag); -/** @pred abort + /** @pred abort -Abandons the execution of the current goal and returns to top level. All -break levels (see break/0 below) are terminated. It is mainly -used during debugging or after a serious execution error, to return to -the top-level. + Abandons the execution of the current goal and returns to top level. All + break levels (see break/0 below) are terminated. It is mainly + used during debugging or after a serious execution error, to return to + the top-level. - -*/ + + */ Yap_InitCPred("$break", 1, p_break, SafePredFlag); #ifdef BEAM Yap_InitCPred("@", 0, eager_split, SafePredFlag); Yap_InitCPred(":", 0, force_wait, SafePredFlag); Yap_InitCPred("/", 0, commit, SafePredFlag); - Yap_InitCPred("skip_while_var",1,skip_while_var,SafePredFlag); - Yap_InitCPred("wait_while_var",1,wait_while_var,SafePredFlag); + Yap_InitCPred("skip_while_var", 1, skip_while_var, SafePredFlag); + Yap_InitCPred("wait_while_var", 1, wait_while_var, SafePredFlag); Yap_InitCPred("eamtime", 0, show_time, SafePredFlag); Yap_InitCPred("eam", 0, use_eam, SafePredFlag); #endif @@ -2011,22 +2024,25 @@ the top-level. /* Accessing and changing the flags for a predicate */ Yap_InitCPred("$flags", 4, p_flags, SyncPredFlag); Yap_InitCPred("$set_flag", 4, p_set_flag, SyncPredFlag); - Yap_InitCPred("$has_yap_or", 0, p_has_yap_or, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$has_eam", 0, p_has_eam, SafePredFlag|SyncPredFlag); + Yap_InitCPred("$has_yap_or", 0, p_has_yap_or, SafePredFlag | SyncPredFlag); + Yap_InitCPred("$has_eam", 0, p_has_eam, SafePredFlag | SyncPredFlag); #ifndef YAPOR - Yap_InitCPred("parallel_mode", 1, p_parallel_mode, SafePredFlag|SyncPredFlag); - Yap_InitCPred("$c_yapor_workers", 1, p_yapor_workers, SafePredFlag|SyncPredFlag); + Yap_InitCPred("parallel_mode", 1, p_parallel_mode, + SafePredFlag | SyncPredFlag); + Yap_InitCPred("$c_yapor_workers", 1, p_yapor_workers, + SafePredFlag | SyncPredFlag); #endif /* YAPOR */ #ifdef INES Yap_InitCPred("euc_dist", 3, p_euc_dist, SafePredFlag); Yap_InitCPred("loop", 0, p_loop, SafePredFlag); #endif #if QSAR - Yap_InitCPred("in_range", 8, p_in_range, TestPredFlag|SafePredFlag); - Yap_InitCPred("in_range", 4, p_in_range2, TestPredFlag|SafePredFlag); + Yap_InitCPred("in_range", 8, p_in_range, TestPredFlag | SafePredFlag); + Yap_InitCPred("in_range", 4, p_in_range2, TestPredFlag | SafePredFlag); #endif #ifdef DEBUG - Yap_InitCPred("dump_active_goals", 0, p_dump_active_goals, SafePredFlag|SyncPredFlag); + Yap_InitCPred("dump_active_goals", 0, p_dump_active_goals, + SafePredFlag | SyncPredFlag); #endif Yap_InitArrayPreds(); @@ -2074,21 +2090,21 @@ the top-level. #endif /* YAPOR || TABLING */ Yap_InitThreadPreds(); { - void (*(*(p))) (void) = E_Modules; + void (*(*(p)))(void) = E_Modules; while (*p) - (*(*p++)) (); + (*(*p++))(); } #if CAMACHO { extern void InitForeignPreds(void); - + Yap_InitForeignPreds(); } #endif #if APRIL { extern void init_ol(void), init_time(void); - + init_ol(); init_time(); } diff --git a/C/sysbits.c b/C/sysbits.c index c5c076f59..6de5527cf 100644 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -205,7 +205,7 @@ Yap_dir_separator (int ch) return dir_separator (ch); } -#if _MSC_VER || defined(__MINGW32__) +#if __WINDOWS__ #include char *libdir = NULL; @@ -217,9 +217,8 @@ initSysPath(Term tlib, Term tcommons) { int len; int dir_done = FALSE; int commons_done = FALSE; - Int rcl, rcc; -#if _MSC_VER || defined(__MINGW32__) || defined(__MSYS__) +#if __WINDOWS__ { char *dir; if ((dir = Yap_RegistryGetString("library")) && @@ -236,7 +235,7 @@ initSysPath(Term tlib, Term tcommons) { } } if (dir_done && commons_done) - return rcl && rcc; + return TRUE; #endif strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX); strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX); @@ -260,7 +259,7 @@ initSysPath(Term tlib, Term tcommons) { } } if (dir_done && commons_done) - return rcl && rcc; + return TRUE; #if __WINDOWS__ { diff --git a/C/threads.c b/C/threads.c index 73b383bd3..7b08ebc9e 100644 --- a/C/threads.c +++ b/C/threads.c @@ -356,6 +356,8 @@ kill_thread_engine (int wid, int always_die) } if (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_ThreadHandle(wid).current_yaam_regs = NULL; if (REMOTE_ThreadHandle(wid).start_of_timesp) @@ -878,6 +880,18 @@ typedef struct swi_mutex { pthread_mutex_t m; } 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 p_new_mutex( USES_REGS1 ) { @@ -1111,7 +1125,245 @@ p_mbox_create( USES_REGS1 ) mboxp = mboxp->next; if (mboxp) { 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)); if (mboxp == NULL) { @@ -1156,7 +1408,156 @@ p_mbox_destroy( USES_REGS1 ) UNLOCK(GLOBAL_mboxq_lock); mboxDestroy(mboxp PASS_REGS); 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* diff --git a/H/YapTags.h b/H/YapTags.h index 096b1a7f4..f9834ab17 100644 --- a/H/YapTags.h +++ b/H/YapTags.h @@ -394,6 +394,34 @@ IntegerOfTerm (Term 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 #endif diff --git a/H/Yatom.h b/H/Yatom.h index d869673e3..7401f8acf 100755 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -403,7 +403,8 @@ AbsModProp (ModEntry * p) return (Prop) (p); } - +#define ModToTerm(m) (m == PROLOG_MODULE ? TermProlog : m ) + #endif #define ModProperty ((PropFlags)0xfffa) @@ -651,55 +652,55 @@ IsValProperty (int flags) C_Preds are things write, read, ... implemented in C. In this case 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 { - DiscontiguousPredFlag = ((UInt)0x00000010 << EXTRA_FLAG_BASE), /* predicates whose clauses may be all-over the place.. */ - SysExportPredFlag = ((UInt)0x00000008 << EXTRA_FLAG_BASE), /* reuse export list to prolog module. */ - NoTracePredFlag = ((UInt)0x00000004 << EXTRA_FLAG_BASE), /* cannot trace this predicate */ - NoSpyPredFlag = ((UInt)0x00000002 << EXTRA_FLAG_BASE), /* cannot spy this predicate */ - QuasiQuotationPredFlag = ((UInt)0x00000001 << EXTRA_FLAG_BASE), /* SWI-like quasi quotations */ - MegaClausePredFlag = (UInt)0x80000000, /* predicate is implemented as a mega-clause */ - ThreadLocalPredFlag = (UInt)0x40000000, /* local to a thread */ - MultiFileFlag = (UInt)0x20000000, /* is multi-file */ - UserCPredFlag = (UInt)0x10000000, /* CPred defined by the user */ - LogUpdatePredFlag = (UInt)0x08000000, /* dynamic predicate with log. upd. sem. */ - InUsePredFlag = (UInt)0x04000000, /* count calls to pred */ - CountPredFlag = (UInt)0x02000000, /* count calls to pred */ - HiddenPredFlag = (UInt)0x01000000, /* invisible predicate */ - CArgsPredFlag = (UInt)0x00800000, /* SWI-like C-interface pred. */ - SourcePredFlag = (UInt)0x00400000, /* static predicate with source declaration */ - MetaPredFlag = (UInt)0x00200000, /* predicate subject to a meta declaration */ - SyncPredFlag = (UInt)0x00100000, /* has to synch before it can execute */ - NumberDBPredFlag = (UInt)0x00080000, /* entry for a number key */ - AtomDBPredFlag = (UInt)0x00040000, /* entry for an atom key */ - GoalExPredFlag = (UInt)0x00020000, /* predicate that is called by goal_expand */ - TestPredFlag = (UInt)0x00010000, /* is a test (optim. comit) */ - AsmPredFlag = (UInt)0x00008000, /* inline */ - StandardPredFlag = (UInt)0x00004000, /* system predicate */ - DynamicPredFlag = (UInt)0x00002000, /* dynamic predicate */ - CPredFlag = (UInt)0x00001000, /* written in C */ - SafePredFlag = (UInt)0x00000800, /* does not alter arguments */ - CompiledPredFlag = (UInt)0x00000400, /* is static */ - IndexedPredFlag = (UInt)0x00000200, /* has indexing code */ - SpiedPredFlag = (UInt)0x00000100, /* is a spy point */ - BinaryPredFlag = (UInt)0x00000080, /* test predicate */ - TabledPredFlag = (UInt)0x00000040, /* is tabled */ - SequentialPredFlag = (UInt)0x00000020, /* may not create parallel choice points! */ - ProfiledPredFlag = (UInt)0x00000010, /* pred is being profiled */ - BackCPredFlag = (UInt)0x00000008, /* Myddas Imported pred */ - ModuleTransparentPredFlag = (UInt)0x00000004, /* ModuleTransparent pred */ - SWIEnvPredFlag = (UInt)0x00000002, /* new SWI interface */ - UDIPredFlag = (UInt)0x00000001 /* User Defined Indexing */ + DiscontiguousPredFlag = ((uint64_t)((uint64_t)0x1000000000)), /* predicates whose clauses may be all-over the place.. */ + SysExportPredFlag = ((uint64_t)0x800000000), /* reuse export list to prolog module. */ + NoTracePredFlag = ((uint64_t)0x400000000), /* cannot trace this predicate */ + NoSpyPredFlag = ((uint64_t)0x200000000), /* cannot spy this predicate */ + QuasiQuotationPredFlag = ((uint64_t)0x100000000), /* SWI-like quasi quotations */ + MegaClausePredFlag = (uint64_t)0x80000000, /* predicate is implemented as a mega-clause */ + ThreadLocalPredFlag = (uint64_t)0x40000000, /* local to a thread */ + MultiFileFlag = (uint64_t)0x20000000, /* is multi-file */ + UserCPredFlag = (uint64_t)0x10000000, /* CPred defined by the user */ + LogUpdatePredFlag = (uint64_t)0x08000000, /* dynamic predicate with log. upd. sem. */ + InUsePredFlag = (uint64_t)0x04000000, /* count calls to pred */ + CountPredFlag = (uint64_t)0x02000000, /* count calls to pred */ + HiddenPredFlag = (uint64_t)0x01000000, /* invisible predicate */ + CArgsPredFlag = (uint64_t)0x00800000, /* SWI-like C-interface pred. */ + SourcePredFlag = (uint64_t)0x00400000, /* static predicate with source declaration */ + MetaPredFlag = (uint64_t)0x00200000, /* predicate subject to a meta declaration */ + SyncPredFlag = (uint64_t)0x00100000, /* has to synch before it can execute */ + NumberDBPredFlag = (uint64_t)0x00080000, /* entry for a number key */ + AtomDBPredFlag = (uint64_t)0x00040000, /* entry for an atom key */ + GoalExPredFlag = (uint64_t)0x00020000, /* predicate that is called by goal_expand */ + TestPredFlag = (uint64_t)0x00010000, /* is a test (optim. comit) */ + AsmPredFlag = (uint64_t)0x00008000, /* inline */ + StandardPredFlag = (uint64_t)0x00004000, /* system predicate */ + DynamicPredFlag = (uint64_t)0x00002000, /* dynamic predicate */ + CPredFlag = (uint64_t)0x00001000, /* written in C */ + SafePredFlag = (uint64_t)0x00000800, /* does not alter arguments */ + CompiledPredFlag = (uint64_t)0x00000400, /* is static */ + IndexedPredFlag = (uint64_t)0x00000200, /* has indexing code */ + SpiedPredFlag = (uint64_t)0x00000100, /* is a spy point */ + BinaryPredFlag = (uint64_t)0x00000080, /* test predicate */ + TabledPredFlag = (uint64_t)0x00000040, /* is tabled */ + SequentialPredFlag = (uint64_t)0x00000020, /* may not create parallel choice points! */ + ProfiledPredFlag = (uint64_t)0x00000010, /* pred is being profiled */ + BackCPredFlag = (uint64_t)0x00000008, /* Myddas Imported pred */ + ModuleTransparentPredFlag = (uint64_t)0x00000004, /* ModuleTransparent pred */ + SWIEnvPredFlag = (uint64_t)0x00000002, /* new SWI interface */ + UDIPredFlag = (uint64_t)0x00000001 /* User Defined Indexing */ } pred_flag; /* profile data */ typedef struct { - YAP_ULONG_LONG NOfEntries; /* nbr of times head unification succeeded */ - YAP_ULONG_LONG NOfHeadSuccesses; /* nbr of times head unification succeeded */ - YAP_ULONG_LONG NOfRetries; /* nbr of times a clause for the pred + uint64_t NOfEntries; /* nbr of times head unification succeeded */ + uint64_t NOfHeadSuccesses; /* nbr of times head unification succeeded */ + uint64_t NOfRetries; /* nbr of times a clause for the pred was retried */ #if defined(YAPOR) || defined(THREADS) lockvar lock; /* a simple lock to protect this entry */ @@ -721,12 +722,7 @@ typedef struct pred_entry PropFlags KindOfPE; /* kind of property */ struct yami *CodeOfPred; OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */ -#if SIZEOF_INT_P==4 - CELL PredFlags, ExtraPredFlags; -#else - CELL PredFlags; -#define ExtraPredFlags PredFlags -#endif + uint64_t PredFlags; UInt ArityOfPE; /* arity of property */ union { diff --git a/library/lineutils.yap b/library/lineutils.yap index b24f07bb3..a067139a2 100644 --- a/library/lineutils.yap +++ b/library/lineutils.yap @@ -4,6 +4,9 @@ search_for/3, scan_natural/3, scan_integer/3, + natural/3, + integer/3, + blank/3, split/2, split/3, fields/2, @@ -66,6 +69,19 @@ scan_integer(N) --> scan_integer(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_) Scan the list of codes _Line_ for a natural number _Nat_, zero @@ -82,6 +98,49 @@ scan_natural(N0,N) --> get_natural(N1,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_) 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 `call(Goal,LineIn,LineOut)`, and output _LineOut_ to file _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) :- - open(Inp, read, StreamInp), + open(Inp, read, StreamInp, [alias(filter_input)]), open(Out, write, StreamOut), filter(StreamInp, StreamOut, Command), close(StreamInp), @@ -258,8 +320,8 @@ Same as file_filter/3, but before starting the filter execute _Arguments_. */ file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :- - open(Inp, read, StreamInp), - open(Out, write, StreamOut), + open(Inp, read, StreamInp, [alias(filter_input)]), + open(Out, write, StreamOut, [alias(filter_output)]), format(StreamOut, FormatString, Parameters), filter(StreamInp, StreamOut, Command), close(StreamInp), diff --git a/library/tries/base_dbtries.c b/library/tries/base_dbtries.c index 083b4e5fc..72a38603e 100644 --- a/library/tries/base_dbtries.c +++ b/library/tries/base_dbtries.c @@ -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); /* We only need to simplify the trie once! */ /* This can be a 10% overhead for sld cases :-( */ +// printf("simplification\n"); trie_print(trie); if (TrNode_child(TrEntry_trie(trie))) simplification_reduction(trie); while (TrNode_child(TrEntry_trie(trie))) { +// printf("depth\n"); trie_print(trie); nested_trie = depth_reduction(trie, depth_node, opt_level); if (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(); 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); if (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) { - 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; } diff --git a/library/tries/base_tries.c b/library/tries/base_tries.c index 907334c7f..867d30c52 100644 --- a/library/tries/base_tries.c +++ b/library/tries/base_tries.c @@ -74,8 +74,23 @@ void trie_data_destruct(TrNode node) { data = (TrData) GET_DATA_FROM_LEAF_TRIE_NODE(node); trie = TrData_trie(data); - if (data == TrEntry_traverse_data(trie)) - TrEntry_traverse_data(trie) = TrData_previous(data); + if (data == TrEntry_traverse_data(trie)) { + 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)) { TrData_previous(TrData_next(data)) = TrData_previous(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 data; - + TrData data, temp = NULL; data = TrEntry_traverse_data(trie); 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) data = TrData_next(data); else { @@ -223,6 +247,8 @@ TrData trie_traverse_cont(TrEntry trie) { data = NULL; } TrEntry_traverse_data(trie) = data; + if (temp) + free_trie_data(temp); } return data; } @@ -325,7 +351,6 @@ void trie_print(TrEntry trie) { void trie_data_construct(TrNode node) { TrData data; - new_trie_data(data, CURRENT_TRIE, node); PUT_DATA_IN_LEAF_TRIE_NODE(node, data); return; diff --git a/library/tries/core_dbtries.c b/library/tries/core_dbtries.c index 865ffa4de..f2a2a1c70 100644 --- a/library/tries/core_dbtries.c +++ b/library/tries/core_dbtries.c @@ -210,9 +210,9 @@ int traverse_get_counter(TrNode node); 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 get_return_node_term(TrNode node); -void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term); -TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term); -void check_attach_childs(TrNode search_child, TrNode existing_child); +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, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)); +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 check_parent_first(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) { - traverse_and_replace_nested_trie(node, nested_trie_id, 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, construct_function, destruct_function); return; } 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; if (TrNode_entry(node) == PairEndTag) { 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; } else if (IS_HASH_NODE(node)) { 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 { if ((node = *--bucket)) { 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); } while(node); } @@ -303,13 +303,13 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T do { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { 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) { temp = TrNode_next(node); if (temp) node = temp; } 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; } } @@ -322,10 +322,10 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T do { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { temp = TrNode_next(node); - node = replace_nested_trie(node, child, new_term); - traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, 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, construct_function, destruct_function); 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; } 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)) - 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; } /* 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; - YAP_Term term_search = (YAP_Term) NULL; if (YAP_IsApplTerm(new_term)) { YAP_Term new_term_functor = ApplTag | ((YAP_Term) 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_child(newnodef) = newnode; } else { - // Rewind to first uncle node - temp = TrNode_parent(node); - if (IS_FUNCTOR_NODE(temp)) - term_search = TrNode_entry(temp); + /* Check if one of the node siblings have new_term */ + temp = node; while (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) temp = TrNode_next(temp); - if (temp) { // Found a node we can reuse + if (temp) { newnode = temp; // Check if the childs of node/child exist already otherwise attach them - check_attach_childs(TrNode_child(child), TrNode_child(newnode)); - //DATA_DESTRUCT_FUNCTION = destruct_function; + check_attach_childs(newnode, TrNode_child(child), TrNode_child(newnode), construct_function, destruct_function); + DATA_DESTRUCT_FUNCTION = destruct_function; remove_child_nodes(TrNode_child(child)); + TrNode_child(child) = NULL; remove_entry(child); return newnode; } 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 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); + if (existing_child) { - if (TrNode_entry(existing_child) != PairEndTag) { - check_attach_childs(TrNode_child(search_child), TrNode_child(existing_child)); - } + if (TrNode_entry(existing_child) != PairEndTag) + 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 { - printf("Need to attach child!\n"); - abort(); + existing_child = search_child; + 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); } @@ -624,7 +651,7 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node, stack_args_base = stack_args = AUXILIARY_TERM_STACK; stack_top = AUXILIARY_TERM_STACK + CURRENT_AUXILIARY_TERM_STACK_SIZE - 1; node = TrNode_parent(TrNode_parent(node)); -// printf("start node: "); displaynode(node); + // printf("start node: "); displaynode(node); if (IS_FUNCTOR_NODE(node)) { while(IS_FUNCTOR_NODE(node)) node = TrNode_parent(node); @@ -633,7 +660,7 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node, child = TrNode_child(child); } else child = TrNode_child(node); -// printf("Chosen start node: "); displaynode(child); + // printf("Chosen start node: "); displaynode(child); if (IS_HASH_NODE(child)) { printf("HASH NODE ERROR: db_tries do not support hash nodes.\n"); 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 */ 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; - PUSH_DOWN(stack_args, TrNode_entry(child), stack_top); count++; if (IS_FUNCTOR_NODE(TrNode_parent(child))) { diff --git a/library/tries/core_dbtries.h b/library/tries/core_dbtries.h index 39b2b42f6..6a2e6f171 100644 --- a/library/tries/core_dbtries.h +++ b/library/tries/core_dbtries.h @@ -225,6 +225,6 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_no YAP_Term core_get_trie_db_return_term(void); void core_set_trie_db_return_term(YAP_Term return_value); 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); void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix); diff --git a/library/tries/core_tries.c b/library/tries/core_tries.c index c3974a12b..f66380be2 100644 --- a/library/tries/core_tries.c +++ b/library/tries/core_tries.c @@ -807,7 +807,7 @@ YAP_Term get_entry(TrNode node, YAP_Term *stack_mark, TrNode *cur_node) { fprintf(stderr, "**************************************\n"); fprintf(stderr, " Tries core module: term stack full\n"); fprintf(stderr, "**************************************\n"); - fflush(stderr); + fflush(stderr); } for (i = index; i > CURRENT_INDEX; i--) 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; return t; } else if (t == FloatEndTag) { - volatile union { - double f; - YAP_Term p[SIZE_FLOAT_AS_TERM]; - } tf; /* to avoid gcc warning */ + volatile union { + double f; + YAP_Term p[SIZE_FLOAT_AS_TERM]; + } tf; /* to avoid gcc warning */ #ifdef TAG_LOW_BITS_32 node = TrNode_parent(node); tf.p[1] = TrNode_entry(node); @@ -915,29 +915,29 @@ void remove_entry(TrNode node) { while (parent) { if (TrNode_previous(node)) { if (IS_HASH_NODE(TrNode_child(parent))) { - TrHash hash = (TrHash) TrNode_child(parent); - TrHash_num_nodes(hash)--; - if (TrHash_num_nodes(hash)) { - if (TrNode_next(node)) { - TrNode_next(TrNode_previous(node)) = TrNode_next(node); - TrNode_previous(TrNode_next(node)) = TrNode_previous(node); - } else { - TrNode_next(TrNode_previous(node)) = NULL; - } - free_trie_node(node); - return; - } - free_hash_buckets(TrHash_buckets(hash), TrHash_num_buckets(hash)); - free_trie_hash(hash); + TrHash hash = (TrHash) TrNode_child(parent); + TrHash_num_nodes(hash)--; + if (TrHash_num_nodes(hash)) { + if (TrNode_next(node)) { + TrNode_next(TrNode_previous(node)) = TrNode_next(node); + TrNode_previous(TrNode_next(node)) = TrNode_previous(node); + } else { + TrNode_next(TrNode_previous(node)) = NULL; + } + free_trie_node(node); + return; + } + free_hash_buckets(TrHash_buckets(hash), TrHash_num_buckets(hash)); + free_trie_hash(hash); } else { - if (TrNode_next(node)) { - TrNode_next(TrNode_previous(node)) = TrNode_next(node); - TrNode_previous(TrNode_next(node)) = TrNode_previous(node); - } else { - TrNode_next(TrNode_previous(node)) = NULL; - } - free_trie_node(node); - return; + if (TrNode_next(node)) { + TrNode_next(TrNode_previous(node)) = TrNode_next(node); + TrNode_previous(TrNode_next(node)) = TrNode_previous(node); + } else { + TrNode_next(TrNode_previous(node)) = NULL; + } + free_trie_node(node); + return; } } else if (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); do { if (*--bucket) - remove_child_nodes(*bucket); + remove_child_nodes(*bucket); } while (bucket != first_bucket); free_hash_buckets(first_bucket, TrHash_num_buckets(hash)); free_trie_hash(hash); @@ -971,9 +971,9 @@ void remove_child_nodes(TrNode node) { } if (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)); - else { + } else { if (DATA_DESTRUCT_FUNCTION) (*DATA_DESTRUCT_FUNCTION)(node); DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); @@ -998,10 +998,10 @@ TrNode copy_child_nodes(TrNode parent_dest, TrNode child_source) { do { bucket_dest--; if (*--bucket_source) { - *bucket_dest = copy_child_nodes(parent_dest, *bucket_source); - TrNode_previous(*bucket_dest) = AS_TR_NODE_NEXT(bucket_dest); + *bucket_dest = copy_child_nodes(parent_dest, *bucket_source); + TrNode_previous(*bucket_dest) = AS_TR_NODE_NEXT(bucket_dest); } else - *bucket_dest = NULL; + *bucket_dest = NULL; } while (bucket_source != first_bucket_source); return (TrNode) hash_dest; } @@ -1039,18 +1039,18 @@ void traverse_and_add(TrNode parent_dest, TrNode parent_source) { do { child_source = *--bucket_source; while (child_source) { - /* parent_dest is not a leaf node */ - child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); - if (child_dest) { - if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); - } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_add(child_dest, child_source); - } - child_source = TrNode_next(child_source); + /* parent_dest is not a leaf node */ + child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); + if (child_dest) { + if (IS_LEAF_TRIE_NODE(child_dest)) { + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); + } else + /* child_dest and child_source are not leaf nodes */ + traverse_and_add(child_dest, child_source); + } + child_source = TrNode_next(child_source); } } while (bucket_source != first_bucket_source); 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)); if (child_dest) { if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_add(child_dest, child_source); + /* child_dest and child_source are not leaf nodes */ + traverse_and_add(child_dest, child_source); } child_source = TrNode_next(child_source); } @@ -1088,27 +1088,27 @@ void traverse_and_join(TrNode parent_dest, TrNode parent_source) { do { child_source = *--bucket_source; while (child_source) { - /* parent_dest is not a leaf node */ - child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); - if (child_dest) { - if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); - } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_join(child_dest, child_source); - } else { - child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source)); - if (IS_LEAF_TRIE_NODE(child_source)) { - MARK_AS_LEAF_TRIE_NODE(child_dest); - INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); - if (DATA_COPY_FUNCTION) - (*DATA_COPY_FUNCTION)(child_dest, child_source); - } else + /* parent_dest is not a leaf node */ + child_dest = trie_node_check(parent_dest, TrNode_entry(child_source)); + if (child_dest) { + if (IS_LEAF_TRIE_NODE(child_dest)) { + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); + } else + /* child_dest and child_source are not leaf nodes */ + traverse_and_join(child_dest, child_source); + } else { + child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source)); + if (IS_LEAF_TRIE_NODE(child_source)) { + MARK_AS_LEAF_TRIE_NODE(child_dest); + INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); + if (DATA_COPY_FUNCTION) + (*DATA_COPY_FUNCTION)(child_dest, child_source); + } else 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); 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)); if (child_dest) { if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_join(child_dest, child_source); + /* child_dest and child_source are not leaf nodes */ + traverse_and_join(child_dest, child_source); } else { child_dest = trie_node_check_insert(parent_dest, TrNode_entry(child_source)); if (IS_LEAF_TRIE_NODE(child_source)) { - MARK_AS_LEAF_TRIE_NODE(child_dest); - INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); - if (DATA_COPY_FUNCTION) - (*DATA_COPY_FUNCTION)(child_dest, child_source); + MARK_AS_LEAF_TRIE_NODE(child_dest); + INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE); + if (DATA_COPY_FUNCTION) + (*DATA_COPY_FUNCTION)(child_dest, child_source); } else 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 { child_dest = *--bucket_dest; while (child_dest) { - child_next = TrNode_next(child_dest); - /* parent_source is not a leaf node */ - child_source = trie_node_check(parent_source, TrNode_entry(child_dest)); - if (child_source) { - if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); - } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_intersect(child_dest, child_source); - } else { - if (IS_LEAF_TRIE_NODE(child_dest)) { - if (DATA_DESTRUCT_FUNCTION) - (*DATA_DESTRUCT_FUNCTION)(child_dest); - DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); - } else - remove_child_nodes(TrNode_child(child_dest)); - remove_entry(child_dest); - } - child_dest = child_next; + child_next = TrNode_next(child_dest); + /* parent_source is not a leaf node */ + child_source = trie_node_check(parent_source, TrNode_entry(child_dest)); + if (child_source) { + if (IS_LEAF_TRIE_NODE(child_dest)) { + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); + } else + /* child_dest and child_source are not leaf nodes */ + traverse_and_intersect(child_dest, child_source); + } else { + if (IS_LEAF_TRIE_NODE(child_dest)) { + if (DATA_DESTRUCT_FUNCTION) + (*DATA_DESTRUCT_FUNCTION)(child_dest); + DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); + } else + remove_child_nodes(TrNode_child(child_dest)); + remove_entry(child_dest); + } + child_dest = child_next; } } while (bucket_dest != first_bucket_dest); 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)); if (child_source) { if (IS_LEAF_TRIE_NODE(child_dest)) { - /* child_source is a leaf node */ - if (DATA_ADD_FUNCTION) - (*DATA_ADD_FUNCTION)(child_dest, child_source); + /* child_source is a leaf node */ + if (DATA_ADD_FUNCTION) + (*DATA_ADD_FUNCTION)(child_dest, child_source); } else - /* child_dest and child_source are not leaf nodes */ - traverse_and_intersect(child_dest, child_source); + /* child_dest and child_source are not leaf nodes */ + traverse_and_intersect(child_dest, child_source); } else { if (IS_LEAF_TRIE_NODE(child_dest)) { - if (DATA_DESTRUCT_FUNCTION) - (*DATA_DESTRUCT_FUNCTION)(child_dest); - DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); + if (DATA_DESTRUCT_FUNCTION) + (*DATA_DESTRUCT_FUNCTION)(child_dest); + DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); } else - remove_child_nodes(TrNode_child(child_dest)); + remove_child_nodes(TrNode_child(child_dest)); remove_entry(child_dest); } child_dest = child_next; @@ -1223,17 +1223,17 @@ YAP_Int traverse_and_count_common_entries(TrNode parent1, TrNode parent2) { do { child1 = *--bucket; while (child1) { - /* parent2 is not a leaf node */ - child2 = trie_node_check(parent2, TrNode_entry(child1)); - if (child2) { - if (IS_LEAF_TRIE_NODE(child1)) - /* child2 is a leaf node */ - count++; - else - /* child1 and child2 are not leaf nodes */ - count += traverse_and_count_common_entries(child1, child2); - } - child1 = TrNode_next(child1); + /* parent2 is not a leaf node */ + child2 = trie_node_check(parent2, TrNode_entry(child1)); + if (child2) { + if (IS_LEAF_TRIE_NODE(child1)) + /* child2 is a leaf node */ + count++; + else + /* child1 and child2 are not leaf nodes */ + count += traverse_and_count_common_entries(child1, child2); + } + child1 = TrNode_next(child1); } } while (bucket != first_bucket); 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)); if (child2) { if (IS_LEAF_TRIE_NODE(child1)) - /* child2 is a leaf node */ - count++; + /* child2 is a leaf node */ + count++; else - /* child1 and child2 are not leaf nodes */ - count += traverse_and_count_common_entries(child1, child2); + /* child1 and child2 are not leaf nodes */ + count += traverse_and_count_common_entries(child1, child2); } child1 = TrNode_next(child1); } @@ -1329,7 +1329,7 @@ void traverse_and_save(TrNode node, FILE *file, int float_block) { do { if (*--bucket) { node = *bucket; - traverse_and_save(node, file, float_block); + traverse_and_save(node, file, float_block); } } while (bucket != first_bucket); return; @@ -1356,23 +1356,23 @@ void traverse_and_save(TrNode node, FILE *file, int float_block) { int index; for (index = 0; index <= CURRENT_INDEX; index++) if (AUXILIARY_TERM_STACK[index] == t) - break; + break; if (index > CURRENT_INDEX) { CURRENT_INDEX = index; if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) - expand_auxiliary_term_stack(); + expand_auxiliary_term_stack(); AUXILIARY_TERM_STACK[CURRENT_INDEX] = 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) */ - fprintf(file, UInt_FORMAT " %d %s " UInt_FORMAT " ", FUNCTOR_SAVE_MARK, index, - YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & t))), - YAP_ArityOfFunctor((YAP_Functor)(~ApplTag & t))); + fprintf(file, UInt_FORMAT " %d %s " UInt_FORMAT " ", FUNCTOR_SAVE_MARK, index, + YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & t))), + YAP_ArityOfFunctor((YAP_Functor)(~ApplTag & t))); } else if (YAP_IsAtomTerm(t)) - fprintf(file, UInt_FORMAT " %d ", ATOM_SAVE_MARK, index); + fprintf(file, UInt_FORMAT " %d ", ATOM_SAVE_MARK, index); 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)) { fprintf(file, "- "); @@ -1415,34 +1415,34 @@ void traverse_and_load(TrNode parent, FILE *file) { int index; n = fscanf(file, "%d", &index); if (index > CURRENT_INDEX) { - char atom[1000]; - if (CURRENT_LOAD_VERSION == 2) { - char *ptr, ch; - ptr = atom; - fgetc(file); /* skip the first empty space */ - while ((ch = fgetc(file))) - *ptr++ = ch; - *ptr = '\0'; - } else if (CURRENT_LOAD_VERSION == 1) { - n = fscanf(file, "%s", atom); - } - CURRENT_INDEX = index; - if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) - expand_auxiliary_term_stack(); - AUXILIARY_TERM_STACK[CURRENT_INDEX] = YAP_MkAtomTerm(YAP_LookupAtom(atom)); + char atom[1000]; + if (CURRENT_LOAD_VERSION == 2) { + char *ptr, ch; + ptr = atom; + fgetc(file); /* skip the first empty space */ + while ((ch = fgetc(file))) + *ptr++ = ch; + *ptr = '\0'; + } else if (CURRENT_LOAD_VERSION == 1) { + n = fscanf(file, "%s", atom); + } + CURRENT_INDEX = index; + if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) + expand_auxiliary_term_stack(); + AUXILIARY_TERM_STACK[CURRENT_INDEX] = YAP_MkAtomTerm(YAP_LookupAtom(atom)); } t = AUXILIARY_TERM_STACK[index]; } else if (t == FUNCTOR_SAVE_MARK) { int index; n = fscanf(file, "%d", &index); if (index > CURRENT_INDEX) { - char atom[1000]; - int arity; - n = fscanf(file, "%s %d", atom, &arity); - CURRENT_INDEX = index; - if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) - expand_auxiliary_term_stack(); - AUXILIARY_TERM_STACK[CURRENT_INDEX] = ApplTag | ((YAP_Term) YAP_MkFunctor(YAP_LookupAtom(atom), arity)); + char atom[1000]; + int arity; + n = fscanf(file, "%s %d", atom, &arity); + CURRENT_INDEX = index; + if (CURRENT_INDEX == CURRENT_AUXILIARY_TERM_STACK_SIZE) + expand_auxiliary_term_stack(); + AUXILIARY_TERM_STACK[CURRENT_INDEX] = ApplTag | ((YAP_Term) YAP_MkFunctor(YAP_LookupAtom(atom), arity)); } t = AUXILIARY_TERM_STACK[index]; } 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) { node = *bucket; traverse_and_print(node, arity, str, str_index, mode); - memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1)); - if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { - /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ - if (str_index > 0 && str[str_index - 1] != '[') - str[str_index - 1] = ','; - /* restore possible PairEndTermTag side-effect */ - if (str[last_pair_mark] == '|') - str[last_pair_mark] = ','; - } + memcpy(arity, current_arity, sizeof(int) * (current_arity[0] + 1)); + if (mode != TRIE_PRINT_FLOAT2 && arity[arity[0]] < 0) { + /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ + if (str_index > 0 && str[str_index - 1] != '[') + str[str_index - 1] = ','; + /* restore possible PairEndTermTag side-effect */ + if (str[last_pair_mark] == '|') + str[last_pair_mark] = ','; + } } } while (bucket != first_bucket); 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) { /* restore possible PairEndEmptyTag/PairEndTermTag/CommaEndTag side-effect */ if (str_index > 0 && str[str_index - 1] != '[') - str[str_index - 1] = ','; + str[str_index - 1] = ','; /* restore possible PairEndTermTag side-effect */ if (str[last_pair_mark] == '|') - str[last_pair_mark] = ','; + str[last_pair_mark] = ','; } free(current_arity); } @@ -1534,13 +1534,13 @@ void traverse_and_print(TrNode node, int *arity, char *str, int str_index, int m arity[0]--; while (arity[0]) { if (arity[arity[0]] == 1) { - str_index += sprintf(& str[str_index], ")"); - arity[0]--; + str_index += sprintf(& str[str_index], ")"); + arity[0]--; } else { - if (arity[arity[0]] > 1) - arity[arity[0]]--; - str_index += sprintf(& str[str_index], ","); - break; + if (arity[arity[0]] > 1) + arity[arity[0]]--; + str_index += sprintf(& str[str_index], ","); + break; } } 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)); while (arity[0]) { if (arity[arity[0]] == 1) { - str_index += sprintf(& str[str_index], ")"); - arity[0]--; + str_index += sprintf(& str[str_index], ")"); + arity[0]--; } else { - if (arity[arity[0]] > 1) - arity[arity[0]]--; - str_index += sprintf(& str[str_index], ","); - break; + if (arity[arity[0]] > 1) + arity[arity[0]]--; + str_index += sprintf(& str[str_index], ","); + break; } } } else if (YAP_IsAtomTerm(t)) { str_index += sprintf(& str[str_index], "%s", YAP_AtomName(YAP_AtomOfTerm(t))); while (arity[0]) { if (arity[arity[0]] == 1) { - str_index += sprintf(& str[str_index], ")"); - arity[0]--; + str_index += sprintf(& str[str_index], ")"); + arity[0]--; } else { - if (arity[arity[0]] > 1) - arity[arity[0]]--; - str_index += sprintf(& str[str_index], ","); - break; + if (arity[arity[0]] > 1) + arity[arity[0]]--; + str_index += sprintf(& str[str_index], ","); + break; } } } else if (YAP_IsIntTerm(t)) { str_index += sprintf(& str[str_index], UInt_FORMAT , YAP_IntOfTerm(t)); while (arity[0]) { if (arity[arity[0]] == 1) { - str_index += sprintf(& str[str_index], ")"); - arity[0]--; + str_index += sprintf(& str[str_index], ")"); + arity[0]--; } else { - if (arity[arity[0]] > 1) - arity[arity[0]]--; - str_index += sprintf(& str[str_index], ","); - break; + if (arity[arity[0]] > 1) + arity[arity[0]]--; + str_index += sprintf(& str[str_index], ","); + break; } } } 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; } else { if (t == PairEndEmptyTag) - str[str_index - 1] = ']'; + str[str_index - 1] = ']'; else if (t == PairEndTermTag) { - str[last_pair_mark] = '|'; - str[str_index - 1] = ']'; + str[last_pair_mark] = '|'; + str[str_index - 1] = ']'; } else /* (t == CommaEndTag) */ - str[str_index - 1] = ')'; + str[str_index - 1] = ')'; arity[0]--; while (arity[0]) { - if (arity[arity[0]] == 1) { - str_index += sprintf(& str[str_index], ")"); - arity[0]--; - } else { - if (arity[arity[0]] > 1) - arity[arity[0]]--; - str_index += sprintf(& str[str_index], ","); - break; - } + if (arity[arity[0]] == 1) { + str_index += sprintf(& str[str_index], ")"); + arity[0]--; + } else { + if (arity[arity[0]] > 1) + arity[arity[0]]--; + str_index += sprintf(& str[str_index], ","); + break; + } } } } else if (ApplTag & t) { diff --git a/misc/LOCALS b/misc/LOCALS index 07b3754d2..5d4e498ac 100755 --- a/misc/LOCALS +++ b/misc/LOCALS @@ -54,6 +54,8 @@ Int DepthArenas =0 int ArithError =FALSE struct pred_entry* LastAssertedPred =NULL +struct pred_entry* TmpPred =NULL +struct pred_entry* LastAssertedPred =NULL char* ScannerStack =NULL struct scanner_extra_alloc* ScannerExtraBlocks =NULL struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid) diff --git a/packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c b/packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c index f0903ef01..e6dfd7ebd 100644 --- a/packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c +++ b/packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c @@ -192,6 +192,8 @@ #include #define VERSION "2.0.0" +int all_loaded_for_deterministic_variables(namedvars varmap, int disp); + typedef struct _parameters { int loadfile; int savedfile; @@ -721,7 +723,7 @@ void myexpand(extmanager MyManager, DdNode *Current) { } } -/* Angelicas Algorithm */ +/* Angelika's Algorithm */ double CalcProbability(extmanager MyManager, DdNode *Current) { DdNode *h, *l; @@ -729,6 +731,7 @@ double CalcProbability(extmanager MyManager, DdNode *Current) { char *curnode; //, *dynvalue; double lvalue, hvalue, tvalue; // density_integral dynvalue_parsed; + if (params.debug) { curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current); fprintf(stderr, "%s\n", curnode); @@ -815,7 +818,7 @@ void PrintNodeQueue(Queue q , extmanager MyManager){ QueueIterator qiter = QueueIteratorNew(q, 1); fprintf(stderr,"Queue %p is [", q); - + while (qiter->currentItem != NULL) { DdNode* val = (DdNode*) qiter->currentItem->element; QueueIteratorAdvance(qiter); diff --git a/packages/ProbLog/simplecudd_lfi/problogmath.h b/packages/ProbLog/simplecudd_lfi/problogmath.h index a547e145b..4ede6b42e 100644 --- a/packages/ProbLog/simplecudd_lfi/problogmath.h +++ b/packages/ProbLog/simplecudd_lfi/problogmath.h @@ -161,6 +161,7 @@ typedef struct _density_integral { double sigmoid(double x, double slope); +double normal(double x, double mu,double sigma); double Phi(double x); double cumulative_normal(double low, double high, double sigma, double mu); double cumulative_normal_dmu(double low, double high,double mu,double sigma); diff --git a/packages/ProbLog/simplecudd_lfi/simplecudd.c b/packages/ProbLog/simplecudd_lfi/simplecudd.c index 4c27369ec..d2e119439 100644 --- a/packages/ProbLog/simplecudd_lfi/simplecudd.c +++ b/packages/ProbLog/simplecudd_lfi/simplecudd.c @@ -188,6 +188,9 @@ #include #include "simplecudd.h" +int my_index_calc(int varstart, DdNode *node); +int all_loaded_for_deterministic_variables(namedvars varmap, int disp); + /* BDD manager initialization */ int _debug = 0; @@ -1717,8 +1720,7 @@ int GetParam(char *inputline, int iParam) { void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd) { char buf, *inputline; - int icur, maxlinesize, iline, index, iloop, ivalue, iQsize, i, inQ, iRoot; - double dvalue; + int icur, maxlinesize, iline, index, iloop, iQsize, i, inQ, iRoot; DdNode **Q, **Q2, *h_node, *l_node, *curnode; hisqueue *his; hisnode *hnode; @@ -1756,10 +1758,10 @@ void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, Dd inQ = 0; 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); - 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 & 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 & 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 & 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)); inQ = 0; switch(inQ) { case 0: diff --git a/pl/consult.yap b/pl/consult.yap index 2e6fa8e51..6b1083342 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -63,7 +63,7 @@ '$convert_for_export'/7, '$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) :- current_module(Mod), Mod \= prolog, - '$current_predicate_no_modules'(Mod,_,Pred), + '$current_predicate'(_,Mod,Pred,_), '$owned_by'(Pred, Mod, FileName). '$owned_by'(T, Mod, FileName) :- @@ -1173,12 +1173,13 @@ unload_file( F0 ) :- % eliminate multi-files; % get rid of file-only predicataes. '$unload_file'( FileName, _F0 ) :- - '$current_predicate_var'(_A,Mod,P), - '$owner_file'(P,Mod,FileName), - \+ '$is_multifile'(P,Mod), - functor( P, Na, Ar), - abolish(Mod:Na/Ar), - fail. + current_module(Mod), + '$current_predicate'(_A,Mod,P,_), + '$owner_file'(P,Mod,FileName), + \+ '$is_multifile'(P,Mod), + functor( P, Na, Ar), + abolish(Mod:Na/Ar), + fail. %next multi-file. '$unload_file'( FileName, _F0 ) :- recorded('$lf_loaded','$lf_loaded'( FileName, _Age, _), R), diff --git a/pl/debug.yap b/pl/debug.yap index 2a9e4f7d6..204c8b761 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -57,18 +57,18 @@ programs: Switches the debugger on. -+ debugging ++ debugging Outputs status information about the debugger which includes the leash mode and the existing spy-points, when the debugger is on. -+ nodebug ++ nodebug 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) :- '$suspy2'(S,F,N,T,M). - '$suspy2'(spy,F,N,T,M) :- + '$suspy2'(spy,F,N,T,M) :- recorded('$spy','$spy'(T,M),_), !, print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,already)). '$suspy2'(spy,F,N,T,M) :- !, - recorda('$spy','$spy'(T,M),_), + recorda('$spy','$spy'(T,M),_), '$set_spy'(T,M), 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), !, erase(R), '$rm_spy'(T,M), @@ -182,17 +182,17 @@ mode and the existing spy-points, when the debugger is on. '$pred_being_spied'(G, M) :- recorded('$spy','$spy'(G,M),_), !. -/** @pred spy( + _P_ ). - +/** +@pred spy( + _P_ ). Sets spy-points on all the predicates represented by - _P_. _P_ can either be a single specification or a list of -specifications. Each one must be of the form _Name/Arity_ -or _Name_. In the last case all predicates with the name - _Name_ will be spied. As in C-Prolog, system predicates and + _P_. _P_ can either be a single specification or a list of +specifications. Each one must be of the form _Name/Arity_ +or _Name_. In the last case all predicates with the name + _Name_ will be spied. As in C-Prolog, system predicates and predicates written in C, cannot be spied. - + */ spy Spec :- '$init_debugger', @@ -208,7 +208,7 @@ predicates written in C, cannot be spied. Removes spy-points from all predicates specified by _P_. The possible forms for _P_ are the same as in `spy P`. - + */ nospy Spec :- '$init_debugger', @@ -218,12 +218,12 @@ The possible forms for _P_ are the same as in `spy P`. '$suspy'(L, nospy, M), fail. nospy _. -/** @pred nospyall +/** @pred nospyall Removes all existing spy-points. - + */ nospyall :- '$init_debugger', @@ -260,12 +260,12 @@ debug :- % -/** @pred trace +/** @pred trace Switches on the debugger and enters tracing mode. - + */ trace :- '$init_debugger', @@ -276,7 +276,7 @@ trace :- print_message(informational,debug(trace)), '$creep'. -/** @pred notrace +/** @pred notrace 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_. @@ -323,13 +323,13 @@ never prompt, same as `off` The initial leashing mode is `full`. -The user may also specify directly the debugger ports -where he wants to be prompted. If the argument for leash +The user may also specify directly the debugger ports +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 -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: -+ if `N/\ 1 =\= 0` prompt on fail ++ if `N/\ 1 =\= 0` prompt on fail + if `N/\ 2 =\= 0` prompt on redo + if `N/\ 4 =\= 0` prompt on exit + 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 box. -In the four port model control is caught at four key points: before -entering the procedure, after exiting the procedure (meaning successful -evaluation of all queries activated by the procedure), after backtracking but -before trying new alternative to the procedure and after failing the +In the four port model control is caught at four key points: before +entering the procedure, after exiting the procedure (meaning successful +evaluation of all queries activated by the procedure), after backtracking but +before trying new alternative to the procedure and after failing the 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, and it includes four or five fields: -+ ++ 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 current call is non-deterministic, that is, it still has alternatives to be tried. If the second character is a `\*`, execution is at a spy-point. If the third character is a `>`, execution has returned either from a skip, a fail or a redo command. -+ ++ The second field is the activation number, and uniquely identifies the activation. The number will start from 1 and will be incremented for each activation found by the debugger. -+ ++ In the third field, the debugger shows the active port. -+ ++ The fourth field is the goal. The goal is written by `write_term/3` on the standard error stream, using the 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 order to make the debugger stop where needed. -There are several commands available, but the user only needs to -remember the help command, which is `h`. This command shows all the +There are several commands available, but the user only needs to +remember the help command, which is `h`. This command shows all the available options, which are: + `c` - creep @@ -551,7 +551,7 @@ kept; useful if skip becomes slow. + `f [ _GoalId_]` - 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 f 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. @@ -620,7 +620,7 @@ more information about `write_depth/2` ( (see Input/Output Control)). + `A` - alternatives - show the list of backtrack points in the current execution. + show the list of backtrack points in the current execution. + `g [ _N_]` @@ -647,7 +647,7 @@ be lost. % Skip Create CP Create CP % FastLeap Stop Ignore % FastIgnore Ignore Ignore - + % flag description initial possible values @@ -669,7 +669,7 @@ be lost. '$swi_current_prolog_flag'(debug, false), !, '$execute_nonstop'(G,Mod). '$spy'([Mod|G]) :- - CP is '$last_choice_pt', + CP is '$last_choice_pt', '$do_spy'(G, Mod, CP, spy). % 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 */ b_getval('$spy_glist',History), /* get goal list */ 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, % while leaving the minimal structure in place. @@ -734,7 +734,7 @@ be lost. Module, error(Event,Context), '$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), _, _, _, _) :- !, throw(Event). '$loop_spy_event'(error('$retry_spy'(G0),_), GoalNumber, G, Module, CalledFromDebugger) :- @@ -773,8 +773,8 @@ be lost. '$continue_debugging'(fail, CalledFromDebugger), fail. -% if we are in -'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :- +% if we are in +'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :- /* the following choice point is where the predicate is called */ b_getval('$spy_glist',[Info|_]), /* get goal list */ Info = info(_,_,_,Retry,Det,false), @@ -805,7 +805,7 @@ be lost. ; true ), - '$continue_debugging'(exit, CalledFromDebugger) + '$continue_debugging'(exit, CalledFromDebugger) ; % make sure we are in system mode when running the debugger. /* backtracking from exit */ @@ -828,7 +828,7 @@ be lost. /* fail port */ fail ). - + '$enter_goal'(GoalNumber, G, Module) :- '$zip'(GoalNumber, G, Module), !. '$enter_goal'(GoalNumber, G, Module) :- @@ -857,10 +857,10 @@ be lost. -> StopPoint < GoalNumber ). - -% + +% '$spycall'(G, M, _, _) :- nb_getval('$debug_jump',true), !, @@ -877,10 +877,10 @@ be lost. '$meta_expansion'(G,M,M,M,G1,[]), '$creep'(G1, M) ; - '$execute'(M:G) + '$execute'(M:G) ). '$spycall'(G, M, _, _) :- - '$tabled_predicate'(G,M), + '$tabled_predicate'(G,M), !, '$continue_debugging_goal'(no, '$execute_nonstop'(G,M)). '$spycall'(G, M, CalledFromDebugger, InRedo) :- @@ -941,7 +941,7 @@ be lost. '$swi_set_prolog_flag'(debug, false), repeat, '$trace_msg'(P,G,Module,L,Deterministic), - ( + ( '$unleashed'(P) -> '$action'(10,P,L,G,Module,Debug), put_code(user_error, 10) @@ -975,7 +975,7 @@ be lost. -> GW = Module:G ; - GW = G + GW = G ), format(user_error,'~a~a~a (~d) ~q:',[Det,CSPY,SLL,L,P0]), '$debugger_write'(user_error,GW). @@ -1086,7 +1086,7 @@ be lost. '$swi_set_prolog_flag'(debug, true), throw(error('$retry_spy'(ScanNumber),[])). '$action'(0's,P,CallNumber,_,_,on) :- !, % 's skip - '$skipeol'(0's), % ' + '$skipeol'(0's), % ' ( (P=call; P=redo) -> nb_setval('$debug_run',CallNumber), nb_setval('$debug_jump',false) @@ -1142,7 +1142,7 @@ be lost. '$execute_dgoal'(G). '$continue_debugging_goal'(_,G) :- '$execute_creep_dgoal'(G). - + '$execute_dgoal'('$execute_nonstop'(G,M)) :- '$execute_nonstop'(G,M). '$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,'A choices g [N] ancestors~n', []), format(user_error,'! g execute goal~n', []). - + '$ilgl'(C) :- print_message(warning, trace_command(C)), print_message(help, trace_help), @@ -1229,7 +1229,7 @@ be lost. NbI is Nb0*10+(C-"0"), get0(user, NC), '$scan_number3'( NC, NbI, Nb). - + '$print_deb_sterm'(G) :- '$get_sterm_list'(L), !, '$deb_get_sterm_in_g'(L,G,A), @@ -1285,7 +1285,7 @@ be lost. recorda('$print_options','$debugger'([max_depth(D)|LN]),_). '$set_deb_depth'(D) :- recorda('$print_options','$debugger'([quoted(true),numbervars(true),portrayed(true),max_depth(D)]),_). - + '$delete_if_there'([], _, []). '$delete_if_there'([T|L], T, LN) :- !, '$delete_if_there'(L, T, LN). @@ -1323,6 +1323,3 @@ be lost. yap_hacks:choicepoint(CP,_,prolog,'$loop_spy2',5,(_;_),_), !, '$debugger_skip_loop_spy2'(CPs,CPs1). '$debugger_skip_loop_spy2'(CPs,CPs). - - - diff --git a/pl/hacks.yap b/pl/hacks.yap index b35ef912c..1a2183187 100644 --- a/pl/hacks.yap +++ b/pl/hacks.yap @@ -222,11 +222,8 @@ beautify_hidden_goal('$call'(G,_CP,?,M),prolog) --> [call(M:G)]. beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) --> [call(M:G0)]. -beautify_hidden_goal('$current_predicate'(M,Na,Ar),prolog) --> - [current_predicate(M,Na/Ar)]. -beautify_hidden_goal('$current_predicate_for_atom'(Name,M,Ar),prolog) --> - { functor(P, Name, Ar) }, - [current_predicate(Name,M:P)]. +beautify_hidden_goal('$current_predicate'(Na,M,S,_),prolog) --> + [current_predicate(Na,M:S)]. beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) --> [listing(Stream,M:Pred)]. diff --git a/pl/listing.yap b/pl/listing.yap index dba2a0a0d..7591d5550 100644 --- a/pl/listing.yap +++ b/pl/listing.yap @@ -23,7 +23,7 @@ :- use_system_module( '$_errors', ['$do_error'/2]). :- use_system_module( '$_preds', ['$clause'/4, - '$current_predicate_no_modules'/3]). + '$current_predicate'/4]). /* listing : Listing clauses in the database @@ -62,7 +62,7 @@ listing :- Mod \= prolog, Mod \= system, \+ '$hidden'( Mod ), - '$current_predicate_no_modules'(Mod,_,Pred), + '$current_predicate'(_,Mod,Pred, _), '$undefined'(Pred, prolog), % skip predicates exported from prolog. functor(Pred,Name,Arity), \+ atom_concat('$', _, Name), diff --git a/pl/modules.yap b/pl/modules.yap index 1a2a2a88e..3a5872e78 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -831,21 +831,25 @@ expand_goal(G, G). '$exit_undefp', fail. +% This predicate should be bidirectional: both +% a consumer and a generator. '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_), - '$continue_imported'(ExportingMod, ExportingModI, G0, G0I), !. + '$continue_imported'(ExportingMod, ExportingModI, G0, G0I). % SWI builtin '$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :- recorded('$dialect',Dialect,_), Dialect \= yap, functor(G, Name, Arity), 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) :- yap_flag(autoload, V), V = true, - '$autoloader_find_predicate'(G,ExportingModI), !, + '$autoloader_find_predicate'(G,ExportingModI), '$continue_imported'(ExportingMod, ExportingModI, G0, G). +% parent module mechanism '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- prolog:'$parent_module'(ImportingMod,ExportingModI), '$continue_imported'(ExportingMod, ExportingModI, G0, G). @@ -1203,7 +1207,8 @@ abolish_module(Mod) :- recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R), fail. abolish_module(Mod) :- - '$current_predicate'(Mod,Na,Ar), + '$current_predicate'(Na,Mod,S,_), + functor(S, Na, Ar), abolish(Mod:Na/Ar), fail. abolish_module(_). diff --git a/pl/preds.yap b/pl/preds.yap index 80e725183..d060c444e 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -71,7 +71,7 @@ and therefore he should try to avoid them whenever possible. unknown/2], ['$assert_static'/5, '$assertz_dynamic'/4, '$clause'/4, - '$current_predicate_no_modules'/3, + '$current_predicate'/4, '$init_preds'/0, '$noprofile'/2, '$public'/2, @@ -788,13 +788,15 @@ abolish(X) :- '$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$abolish_all'(M) :- - '$current_predicate'(M,Na,Ar), + '$current_predicate'(Na, M, S, _), + functor(S, Na, Ar), '$new_abolish'(Na/Ar, M), fail. '$abolish_all'(_). '$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), fail. '$abolish_all_atoms'(_,_). @@ -858,13 +860,15 @@ abolish(X) :- '$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$abolish_all_old'(M) :- - '$current_predicate'(M, Na, Ar), + '$current_predicate'(Na, M, S, _), + functor( S, Na, Ar ), '$abolish'(Na, Ar, M), fail. '$abolish_all_old'(_). '$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), fail. '$abolish_all_atoms_old'(_,_). @@ -1071,7 +1075,8 @@ predicate_property(Pred,Prop) :- ). '$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). '$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :- recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_), @@ -1163,82 +1168,39 @@ predicate_erased_statistics(P,NCls,Sz,ISz) :- /** @pred current_predicate( _A_, _P_) -Defines the relation: _P_ is a currently defined predicate whose -name is the atom _A_. +Defines the relation: _P_ is a currently defined predicate whose name is the atom _A_. */ current_predicate(A,T) :- - var(T), !, % only for the predicate - '$current_module'(M), - '$current_predicate_no_modules'(M,A,T). -current_predicate(A,M:T) :- % module unspecified - var(M), !, - '$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). - + '$ground_module'(T, M, T0), + ( + '$current_predicate'(A, M, T0, _) + ; + '$imported_predicate'(A, M, A/_Arity, T0, _) + ). + /** @pred system_predicate( _A_, _P_) Defines the relation: _P_ is a built-in predicate whose name 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 ) :- - strip_module(P, M, P0), - ( atom(A) -> - ( - atom( M ) -> - ( '$current_system_predicate_for_atom'( M, A, P0 ) - ; - '$imported_system_predicate'( M, A, P0 ) - ) - ; - '$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(A,T) :- + '$ground_module'(T, M, T0), + ( + '$current_predicate'(A, M, T0, Flags) + ; + '$current_predicate'(A, prolog, T0, Flags) + ), + Flags /\ 0x00004000 =\= 0, + \+ '$hidden'(A). - system_predicate(P) :- - '$current_module'(M), - '$system_predicate'(P,M). +/** @pred system_predicate( ?_P_ ) + +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 @@ -1246,65 +1208,32 @@ system_predicate( A, P ) :- _F_ is the predicate indicator for a currently defined user or library predicate. _F_ is of the form _Na/Ar_, where the atom _Na_ is the name of the predicate, and _Ar_ its arity. - - */ current_predicate(F0) :- - '$yap_strip_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) :- !, + '$ground_module'(F0, M, F), ( - '$current_predicate'(M,A,Arity), - '$ifunctor'(T,A,Arity), - '$pred_exists'(T,M) + '$current_predicate'(N, M, S, _), + functor( S, N, Ar), + F = N/Ar ; -% '$current_predicate'(prolog,A,Arity), -% 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) + '$imported_predicate'(_Name, M, F, _S, _) ). -'$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_) 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 -the internal data-base. - - + the internal data-base. */ current_key(A,K) :- - '$current_predicate'(idb,A,Arity), - '$ifunctor'(K,A,Arity). + '$current_predicate'(A,idb,K,_). % do nothing for now. '$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 of the program that is generated at runtime but does not change during the remainder of the program execution. - - - - */ compile_predicates(Ps) :- '$current_module'(Mod), diff --git a/pl/profile.yap b/pl/profile.yap index aa5d4c3a9..65b0cab7b 100644 --- a/pl/profile.yap +++ b/pl/profile.yap @@ -126,8 +126,8 @@ profile_data(P, Parm, Data) :- '$profile_say'(Stats, Parm, Data). '$profile_data_for_var'(Name/Arity, Parm, Data, M) :- - '$current_predicate'(M,Name,Arity), functor(P,Name,Arity), + '$current_predicate'(Name,M,P,_), \+ '$hidden'(Name), % don't show hidden predicates. '$profile_info'(M, P, Stats), '$profile_say'(Stats, Parm, Data). @@ -137,8 +137,7 @@ profile_data(P, Parm, Data) :- profile_reset :- current_module(M), - '$current_predicate'(M,Na,Ar), - functor(P,Na,Ar), + '$current_predicate'(_Na,M,P,_), '$profile_reset'(M, P), fail. profile_reset. diff --git a/pl/protect.yap b/pl/protect.yap index 374cf9e06..f0057894f 100755 --- a/pl/protect.yap +++ b/pl/protect.yap @@ -30,8 +30,7 @@ '$protect'. '$hide_predicates'(Name) :- - '$current_predicate_for_atom'(Name, prolog, Ar), - functor(P, Name, Ar), + '$current_predicate'(Name, prolog, P, _), '$hide_predicate'(P,prolog), fail. '$hide_predicates'(_). diff --git a/pl/signals.yap b/pl/signals.yap index 1fc9b429e..9d798a27d 100644 --- a/pl/signals.yap +++ b/pl/signals.yap @@ -227,7 +227,8 @@ order of dispatch. '$execute_nonstop'(G, M), '$$save_by'(CP2), '$disable_debugging', - (CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ) + (CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ), + '$enable_debugging' ; '$disable_debugging', fail