/************************************************************************* * * * YAP Prolog * * * * Yap Prolog was developed at NCCUP - Universidade do Porto * * * * Copyright L.Damas, V.S.Costa and Universidade do Porto 2015- * * * ************************************************************************** * * * File: flags.c * * Last rev: * * mods: * * comments: abstract machine definitions * * * *************************************************************************/ /** @file flags.c @ingroup Flags @{ */ // this is where we define flags #define INIT_FLAGS 1 #include "Yap.h" static bool ro( Term inp ); static bool nat( Term inp ); static bool isatom( Term inp ); static bool boolean( Term inp ); //static bool string( Term inp ); //static bool list_atom( Term inp ); static bool list_option( Term inp ); static bool argv( Term inp ); static bool os_argv( Term inp ); static bool agc_threshold( Term inp ); static bool gc_margin( Term inp ); static bool executable( Term inp ); static bool sys_thread_id(Term inp); static bool mkprompt(Term inp); static bool synerr(Term inp); static bool indexer(Term inp); static bool getenc(Term inp); static bool typein( Term inp ); static bool dqf( Term t2 ); static void newFlag( Term fl, Term val ); static Int current_prolog_flag(USES_REGS1); static Int set_prolog_flag(USES_REGS1); #include "Yatom.h" #include "yapio.h" #include "eval.h" #define YAP_FLAG( ID, NAME, WRITABLE, DEF, INIT, HELPER ) { NAME, WRITABLE, DEF, INIT, HELPER } #define GZERO_FLAG { NULL, false, NULL, NULL, NULL } #define LZERO_FLAG { NULL, false, NULL, NULL, NULL } static flag_info global_flags_setup[] = { #include "YapGFlagInfo.h" GZERO_FLAG }; static flag_info local_flags_setup[] = { #include "YapLFlagInfo.h" LZERO_FLAG }; static bool indexer( Term inp ) { if (inp == TermOff || inp == TermSingle|| inp == TermCompact|| inp == TermMulti|| inp == TermOn|| inp == TermMax ) return true; if (IsAtomTerm(inp)) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, inp, "set_prolog_flag index in {off,single,compact,multi,on,max}"); return false; } Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag in {dec10,error,fail,quiet}"); return false; } static bool dqf1( ModEntry *new, Term t2 USES_REGS ) { new->flags &= ~(DBLQ_CHARS|DBLQ_CODES|DBLQ_ATOM|DBLQ_STRING); if (IsAtomTerm(t2) ) { if (t2 == TermString) { new->flags |= DBLQ_STRING; return true; } else if (t2 == TermAtom) { new->flags |= DBLQ_ATOM; return true; } else if (t2 == TermCodes) { new->flags |= DBLQ_CODES; return true; } else if (t2 == TermChars) { new->flags |= DBLQ_CHARS; return true; } /* bad argument, but still an atom */ Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "bad option %s for backquoted string flag, use one string, arom, codes or chars", RepAtom(AtomOfTerm(t2))->StrOfAE); return false; } else { Yap_Error(TYPE_ERROR_ATOM, t2, "set_prolog_flag(double_quotes, %s), should be {string,atom,codes,chars}", RepAtom(AtomOfTerm(t2))->StrOfAE); return false; } } static bool dqf( Term t2 ) { CACHE_REGS ModEntry *new = Yap_GetModuleEntry(CurrentModule); return dqf1( new, t2 PASS_REGS); } static bool bqf1( ModEntry *new, Term t2 USES_REGS ) { new->flags &= ~(BCKQ_CHARS|BCKQ_CODES|BCKQ_ATOM|BCKQ_STRING); if (IsAtomTerm(t2)) { if (t2 == TermString) { new->flags |= BCKQ_STRING; return true; } else if (t2 == TermAtom) { new->flags |= BCKQ_ATOM; return true; } else if (t2 == TermCodes) { new->flags |= BCKQ_CODES; return true; } else if (t2 == TermChars) { new->flags |= BCKQ_CHARS; return true; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "bad option %s for backquoted string flag, use one string, arom, codes or chars", RepAtom(AtomOfTerm(t2))->StrOfAE); return false; } else { Yap_Error(TYPE_ERROR_ATOM, t2, "flag %s is not module-scoped", RepAtom(AtomOfTerm(t2))->StrOfAE); return false; } } static bool isaccess( Term inp ) { if (inp == TermReadWrite || inp == TermReadOnly ) return true; if (IsAtomTerm(inp)) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, inp, "set_prolog_flag access in {read_write,read_only}"); return false; } Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag access in {read_write,read_only}"); return false; } static bool isground( Term inp ) { return Yap_IsGroundTerm( inp ); } static bool flagscope( Term inp ) { if (inp == TermGlobal || inp == TermThread || inp == TermModule) return true; if (IsAtomTerm(inp)) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, inp, "set_prolog_flag access in {global,module,thread}"); return false; } Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag access in {global,module,thread}"); return false; } static bool mkprompt( Term inp ) { CACHE_REGS if (IsVarTerm(inp)) { return Yap_unify( inp, MkAtomTerm( Yap_LookupAtom( LOCAL_Prompt )) ); } if (!IsAtomTerm(inp) ) { Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag"); return false; } strncpy( LOCAL_Prompt, (const char *)RepAtom( AtomOfTerm( inp ) )->StrOfAE, MAX_PROMPT ); return true; } static bool getenc( Term inp ) { CACHE_REGS if (IsVarTerm(inp)) { return Yap_unify( inp, MkAtomTerm( Yap_LookupAtom( enc_name(LOCAL_encoding) )) ); } if (!IsAtomTerm(inp) ) { Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag"); return false; } enc_id( ( char *)RepAtom( AtomOfTerm( inp ) )->StrOfAE ); return true; } /* static bool enablerl( Term inp ) { CACHE_REGS if (IsVarTerm(inp)) { return Yap_unify( inp, MkAtomTerm( Yap_LookupAtom( enc_name(LOCAL_encoding) )) ); } if (!IsAtomTerm(inp) ) { Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag"); return false; } enc_id( RepAtom( AtomOfTerm( inp ) )->StrOfAE ); return true; } */ static bool typein( Term inp ) { CACHE_REGS if (IsVarTerm(inp)) { Term tin = CurrentModule; if (tin == PROLOG_MODULE) tin = TermProlog; return Yap_unify( inp, tin ); } if (!IsAtomTerm(inp) ) { Yap_Error(TYPE_ERROR_ATOM, inp, "set_prolog_flag"); return false; } CurrentModule = inp; if (inp == TermProlog) CurrentModule = PROLOG_MODULE; return true; } #if 0 static Int p_has_yap_or(USES_REGS1) { #ifdef YAPOR return (TRUE); #else return (FALSE); #endif } static Int p_has_eam(USES_REGS1) { #ifdef BEAM return (TRUE); #else return (FALSE); #endif } static Int p_has_jit(USES_REGS1) { #ifdef HAS_JIT return (TRUE); #else return (FALSE); #endif } static bool tabling( Term inp ) { 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); } yap_flags[TA BLING_MODE_FLAG] = 0; } 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); } SetMode_Batched(yap_flags[TABLING_MODE_FLAG]); } 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); } SetMode_Local(yap_flags[TABLING_MODE_FLAG]); } 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); } SetMode_ExecAnswers(yap_flags[TABLING_MODE_FLAG]); } 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); } SetMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG]); } 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); } SetMode_LocalTrie(yap_flags[TABLING_MODE_FLAG]); } 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); } SetMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG]); } else if (value == 7) { /* CoInductive */ tab_ent_ptr tab_ent = GLOBAL_root_tab_ent; while (tab_ent) { SetMode_CoInductive(TabEnt_mode(tab_ent)); tab_ent = TabEnt_next(tab_ent); } SetMode_CoInductive(yap_flags[TABLING_MODE_FLAG]); } } static bool string( Term inp ) { if (IsVarTerm(inp)) { Yap_Error(INSTANTIATION_ERROR, inp, "set_prolog_flag in \"...\""); return false; } if (IsStringTerm( inp )) return true; Term inp0 = inp; if (IsPairTerm(inp)) { Term hd = HeadOfTerm(inp); if (IsAtomTerm(hd)) { do { Term hd = HeadOfTerm(inp); if (!IsAtomTerm(hd)) { Yap_Error(TYPE_ERROR_TEXT, inp0, "set_prolog_flag in \"...\""); return false; } } while (IsPairTerm( inp ) ); } else if (IsIntTerm(hd)) { do { Term hd = HeadOfTerm(inp); if (!IsIntTerm(hd)) { Yap_Error(TYPE_ERROR_TEXT, inp0, "set_prolog_flag in \"...\""); return false; } if (IntOfTerm(hd) < 0) { Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, inp0, "set_prolog_flag in 0..."); return false; } } while (IsPairTerm( inp ) ); } else { Yap_Error(TYPE_ERROR_TEXT, inp0, "set_prolog_flag in \"...\""); return false; } } if ( inp != TermNil ) { Yap_Error(TYPE_ERROR_TEXT, inp0, "set_prolog_flag in \"...\""); return false; } return true; } static bool list_atom( Term inp ) { if (IsVarTerm(inp)) { Yap_Error(INSTANTIATION_ERROR, inp, "set_prolog_flag in \"...\""); return false; } Term inp0 = inp; if (IsPairTerm(inp)) { Term hd = HeadOfTerm(inp); do { if (!IsAtomTerm(hd)) { Yap_Error(TYPE_ERROR_ATOM, inp0, "set_prolog_flag in \"...\""); return false; } } while (IsPairTerm( inp ) ); } if ( inp != TermNil ) { Yap_Error(TYPE_ERROR_LIST, inp0, "set_prolog_flag in [...]"); return false; } return true; } #endif static bool list_option( Term inp ) { if (IsVarTerm(inp)) { Yap_Error(INSTANTIATION_ERROR, inp, "set_prolog_flag in \"...\""); return false; } Term inp0 = inp; if (IsPairTerm(inp)) { do { Term hd = HeadOfTerm(inp); inp = TailOfTerm(inp); if (IsAtomTerm(hd)) { continue; } if(IsApplTerm(hd)) { Functor f = FunctorOfTerm(hd); if (!IsExtensionFunctor(f) && ArityOfFunctor(f) == 1 && Yap_IsGroundTerm(hd)) { continue; } if (!Yap_IsGroundTerm(hd)) Yap_Error(INSTANTIATION_ERROR, hd, "set_prolog_flag in \"...\""); return false; } } while (IsPairTerm( inp ) ); if ( inp == TermNil ) { return true; } Yap_Error(TYPE_ERROR_LIST, inp0, "set_prolog_flag in [...]"); return false; } else /* lone option */ { if (IsAtomTerm(inp)) { return true; } else if(IsApplTerm(inp)) { Functor f = FunctorOfTerm(inp); if (!IsExtensionFunctor(f) && ArityOfFunctor(f) == 1 && Yap_IsGroundTerm(ArgOfTerm(1, inp))) { return true; } } } return false; } static bool agc_threshold( Term t ) { t = Deref(t); if (IsVarTerm(t)) { CACHE_REGS return Yap_unify(t, MkIntegerTerm(GLOBAL_AGcThreshold)); } else if (!IsIntegerTerm(t)) { Yap_Error(TYPE_ERROR_INTEGER,t,"prolog_flag/2 agc_margin"); return FALSE; } else { Int i = IntegerOfTerm(t); if (i<0) { Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,t,"prolog_flag/2 agc_margin"); return FALSE; } else { GLOBAL_AGcThreshold = i; return TRUE; } } } static bool gc_margin( Term t ) { t = Deref(t); if (IsVarTerm(t)) { return Yap_unify(t, Yap_GetValue(AtomGcMargin)); } else if (!IsIntegerTerm(t)) { Yap_Error(TYPE_ERROR_INTEGER,t,"prolog_flag/2 agc_margin"); return FALSE; } else { Int i = IntegerOfTerm(t); if (i<0) { Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,t,"prolog_flag/2 gc_margin"); return FALSE; } else { CACHE_REGS Yap_PutValue(AtomGcMargin, MkIntegerTerm( i )); return TRUE; } } } static Term mk_argc_list(USES_REGS1) { int i = 1; Term t = TermNil; while (i < GLOBAL_argc) { char *arg = GLOBAL_argv[i]; /* check for -L -- */ if (arg[0] == '-' && arg[1] == 'L') { arg += 2; while (*arg != '\0' && (*arg == ' ' || *arg == '\t')) 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; } } 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); } return (t); } i++; } return (t); } static Term mk_os_argc_list(USES_REGS1) { int i = 0; Term t = TermNil; for (i = 0; i < GLOBAL_argc; i++) { char *arg = GLOBAL_argv[i]; t = MkPairTerm(MkAtomTerm(Yap_LookupAtom(arg)), t); } return (t); } static bool argv(Term inp) { CACHE_REGS Term t = mk_argc_list(PASS_REGS1); if (IsAtomOrIntTerm(t)) GLOBAL_Flags[ARGV_FLAG].at = t; else { GLOBAL_Flags[ARGV_FLAG].DBT = Yap_StoreTermInDB(t, 2); } return false; } static bool os_argv(Term inp) { CACHE_REGS Term t = mk_os_argc_list(PASS_REGS1); if (IsAtomOrIntTerm(t)) GLOBAL_Flags[OS_ARGV_FLAG].at = t; else { GLOBAL_Flags[OS_ARGV_FLAG].DBT = Yap_StoreTermInDB(t, 2); } return false; } static FlagEntry * GetFlagProp(Atom a ) { /* look property list of atom a for kind */ AtomEntry *ae = RepAtom(a); FlagEntry *pp; READ_LOCK(ae->ARWLock); pp = RepFlagProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != FlagProperty) pp = RepFlagProp(pp->NextOfPE); READ_UNLOCK(ae->ARWLock); return pp; } static void initFlag(flag_info *f, int fnum, bool global) { Atom name = Yap_LookupAtom( f->name ); AtomEntry *ae = RepAtom(name); WRITE_LOCK(ae->ARWLock); FlagEntry * fprop = RepFlagProp(Yap_GetAPropHavingLock( name, FlagProperty ) ); if (fprop == NULL) { fprop = (FlagEntry *) Yap_AllocAtomSpace(sizeof(FlagEntry)); if (fprop == NULL) { WRITE_UNLOCK(ae->ARWLock); Yap_Error(RESOURCE_ERROR_HEAP,TermNil,"not enough space for new Flag %s", ae->StrOfAE); return; } fprop->KindOfPE = FlagProperty; fprop->FlagOfVE = fnum; fprop->rw = f->writable; fprop->global = global; fprop->type = f->def; fprop->helper = f->helper; AddPropToAtom(ae, AbsFlagProp(fprop)); } WRITE_UNLOCK(ae->ARWLock); } static bool executable(Term inp) { CACHE_REGS if (GLOBAL_argv && GLOBAL_argv[0]) Yap_TrueFileName(GLOBAL_argv[0], LOCAL_FileNameBuf, FALSE); else strncpy(LOCAL_FileNameBuf, Yap_FindExecutable(), YAP_FILENAME_MAX - 1); return Yap_unify(MkAtomTerm(Yap_LookupAtom(LOCAL_FileNameBuf)), inp); } static bool sys_thread_id(Term inp) { CACHE_REGS int pid; #ifdef HAVE_GETTID_SYSCALL pid = syscall(__NR_gettid); #elif defined(HAVE_GETTID_MACRO) pid = gettid(); #elif defined(__WINDOWS__) pid = GetCurrentThreadId(); #else pid = 0; #endif return Yap_unify(MkIntegerTerm(pid), inp); } static bool setYapFlagInModule( Term tflag, Term t2, Term mod ) { CACHE_REGS FlagEntry *fv; ModEntry *new = Yap_GetModuleEntry(mod); if (!new) return false; fv = GetFlagProp( AtomOfTerm( tflag ) ); if (!fv && !fv->global) { Yap_Error(DOMAIN_ERROR_PROLOG_FLAG, tflag, "trying to set unknown module flag"); return false; } if (mod == USER_MODULE && !setYapFlag( tflag, t2) ) return false; // module specific stuff now if (fv->FlagOfVE == UNKNOWN_FLAG) { if (t2 == TermError) { new->flags &= ~(UNKNOWN_FAIL|UNKNOWN_WARNING); new->flags |= (UNKNOWN_ERROR); return true; } else if (t2 == TermFail) { new->flags &= ~(UNKNOWN_ERROR|UNKNOWN_WARNING); new->flags |= (UNKNOWN_FAIL); return true; } else if (t2 == TermWarning) { new->flags &= ~(UNKNOWN_ERROR|UNKNOWN_FAIL); new->flags |= (UNKNOWN_WARNING); return true; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "bad option %s for unknown flag, use one of error, fail or warning.", RepAtom(AtomOfTerm(tflag))->StrOfAE); return false; } else if (fv->FlagOfVE == DOUBLE_QUOTES_FLAG) { return dqf1( new, t2 PASS_REGS ); } else if (fv->FlagOfVE == CHARACTER_ESCAPES_FLAG) { if (t2 == TermTrue) { new->flags |= M_CHARESCAPE; return true; } else if (t2 == TermFalse) { new->flags &= ~(M_CHARESCAPE); return true; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, t2, "bad option %s for character_escapes flag, use true or false", RepAtom(AtomOfTerm(tflag))->StrOfAE); return false; } else if (fv->FlagOfVE == BACKQUOTED_STRING_FLAG) { return bqf1( new, t2 PASS_REGS );; } // bad key? return false; } static Term getYapFlagInModule( Term tflag, Term mod ) { FlagEntry *fv; ModEntry *new = Yap_GetModuleEntry(mod); if (!mod) return false; fv = GetFlagProp( AtomOfTerm( tflag ) ); if (!fv && !fv->global) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, tflag, "trying to set unknown flag"); return 0L; } // module specific stuff now if (fv->FlagOfVE == UNKNOWN_FLAG) { if (new->flags & UNKNOWN_ERROR) return TermError; if (new->flags & UNKNOWN_WARNING) return TermWarning; return TermFail; } else if (fv->FlagOfVE == CHARACTER_ESCAPES_FLAG) { if (new->flags & M_CHARESCAPE) return TermTrue; } else if (fv->FlagOfVE == BACKQUOTED_STRING_FLAG) { if (new->flags & BCKQ_CHARS) return TermChars; if (new->flags & BCKQ_CODES) return TermCodes; if (new->flags & BCKQ_ATOM) return TermAtom; return TermString; } else if (fv->FlagOfVE == DOUBLE_QUOTES_FLAG) { if (new->flags & DBLQ_CHARS) return TermChars; if (new->flags & DBLQ_CODES) return TermCodes; if (new->flags & DBLQ_ATOM) return TermAtom; return TermString; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, tflag, "flag %s is not module-scoped", RepAtom(AtomOfTerm(tflag))->StrOfAE); return 0L; } static Int cont_yap_flag( USES_REGS1) { int i = IntOfTerm (EXTRA_CBACK_ARG (2, 1)); int gmax = GLOBAL_flagCount; int lmax = LOCAL_flagCount; Term tflag = Deref(ARG1); EXTRA_CBACK_ARG (2, 1) = MkIntTerm (i+1); if (IsApplTerm( tflag ) && FunctorOfTerm(tflag) == FunctorModule) { Term modt = CurrentModule; tflag = Yap_StripModule( tflag, &modt ); while (i != gmax && i != UNKNOWN_FLAG && i != CHARACTER_ESCAPES_FLAG && i != BACKQUOTED_STRING_FLAG) i++; if (i == gmax) cut_fail(); EXTRA_CBACK_ARG (2, 1) = MkIntTerm (i+1); { Term lab = MkAtomTerm( Yap_LookupAtom( global_flags_setup[i].name ) ) ; Term val = Deref(ARG2); if (! Yap_unify(tflag, lab) ) return false; if (IsVarTerm(val)) { Term oval = getYapFlagInModule( lab, modt ); if (oval == 0) return false; return Yap_unify( oval, val ); } else { return setYapFlagInModule( tflag, val, modt ); } } return false; } if (i >= gmax ) { Yap_unify( ARG1, MkAtomTerm( Yap_LookupAtom(local_flags_setup[i-gmax].name ) ) ); if (i == gmax+lmax-1) do_cut(0); } else { Yap_unify( ARG1, MkAtomTerm( Yap_LookupAtom( global_flags_setup[i].name ) ) ); } Term flag = getYapFlag( Deref(ARG1) ); return Yap_unify( flag, ARG2 ); } static Int yap_flag(USES_REGS1) { Term tflag = Deref(ARG1); if (IsVarTerm( tflag ) ) { EXTRA_CBACK_ARG (2, 1) = MkIntTerm (0); return cont_yap_flag( PASS_REGS1 ); } if (IsApplTerm( tflag ) && FunctorOfTerm(tflag) == FunctorModule) { Term modt; tflag = Yap_StripModule( tflag, &modt ); if (IsVarTerm(tflag)) { EXTRA_CBACK_ARG (2, 1) = MkIntTerm (0); return cont_yap_flag( PASS_REGS1 ); } do_cut( 0 ); if (!isatom(tflag)) return false; if (!isatom(modt)) return false; if (IsVarTerm(Deref(ARG2))) { Term flag = getYapFlagInModule( tflag, modt ); if (flag == 0) return false; return Yap_unify( flag, ARG2 ); } else { return setYapFlagInModule( tflag, Deref(ARG2), modt ); } } do_cut( 0 ); if (IsVarTerm(Deref(ARG2))) { Term flag = getYapFlag( Deref(ARG1) ); if (flag == 0) return false; return Yap_unify( flag, ARG2 ); } return set_prolog_flag( PASS_REGS1 ); } static Int cont_prolog_flag(USES_REGS1) { int i = IntOfTerm (EXTRA_CBACK_ARG (3, 1)); while (i < GLOBAL_flagCount+LOCAL_flagCount) { int gmax = GLOBAL_flagCount; int lmax = LOCAL_flagCount; Term flag, f; if (i >= gmax+lmax) { cut_fail(); } else if (i >= gmax) { Yap_unify( ARG1, ( f = MkAtomTerm( Yap_LookupAtom(local_flags_setup[i-gmax].name ) ) )); } else { Yap_unify( ARG1, (f = MkAtomTerm( Yap_LookupAtom( global_flags_setup[i].name ) ) ) ); } EXTRA_CBACK_ARG (3, 1) = MkIntTerm (++i); flag = getYapFlag( f ); if (! Yap_unify( f, ARG2 ) ) return false; return setYapFlag( f, Deref(ARG3) ); } cut_fail(); } /** @pred prolog_flag(? _Flag_,- _OldValue_,+ _NewValue_) Obtain the value for a YAP Prolog flag and then set it to a new value. Equivalent to first calling current_prolog_flag/2 with the second argument _OldValue_ unbound and then calling set_prolog_flag/2 with the third argument _NewValue_. */ static Int prolog_flag(USES_REGS1) { if (IsVarTerm( Deref(ARG1) ) ) { EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0); return cont_prolog_flag( PASS_REGS1 ); } do_cut( 0 ); if (IsVarTerm( Deref(ARG2) ) ) { Term flag = getYapFlag( Deref(ARG1) ); if (flag == 0) return false; return Yap_unify( flag, ARG2 ) ; } return setYapFlag( Deref(ARG1), Deref(ARG3) ); } /** @pred current_prolog_flag(? _Flag_,- _Value_) is iso Obtain the value for a YAP Prolog flag. Equivalent to calling yap_flag/2 with the second argument unbound, and unifying the returned second argument with _Value_. */ static Int current_prolog_flag( USES_REGS1 ) { Term tflag = Deref(ARG1); Term tout = 0; FlagEntry *fv; flag_term *tarr; if (IsVarTerm(tflag)) { EXTRA_CBACK_ARG (2, 1) = MkIntTerm (0); return cont_yap_flag( PASS_REGS1 ); } do_cut( 0 ); if (!IsAtomTerm(tflag)) { Yap_Error(TYPE_ERROR_ATOM, tflag, "current_prolog_flag/3"); return (FALSE); } fv = GetFlagProp( AtomOfTerm( tflag ) ); if (!fv) { // should itself depend on a flag return FALSE; } if (fv->global) tarr = GLOBAL_Flags; else tarr = LOCAL_Flags; tout = tarr[fv->FlagOfVE].at; if (IsVarTerm(tout)) tout = Yap_FetchTermFromDB(tarr[fv->FlagOfVE].DBT); return (Yap_unify(ARG2, tout)); } void Yap_setModuleFlags(ModEntry *new, ModEntry *cme) { CACHE_REGS Atom at = new->AtomOfME; if (at == AtomProlog || CurrentModule == PROLOG_MODULE) { new->flags = M_SYSTEM | UNKNOWN_ERROR |M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING; if (at == AtomUser) new->flags = UNKNOWN_ERROR |M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING; } else if (cme && cme->flags && cme != new) { new->flags = cme->flags; } else { new->flags = ( UNKNOWN_ERROR | M_CHARESCAPE | DBLQ_CODES | BCKQ_STRING ); } //printf("cme=%s new=%s flags=%x\n",cme,at->StrOfAE,new->flags); } bool setYapFlag( Term tflag, Term t2 ) { FlagEntry *fv; flag_term *tarr; if (IsVarTerm(tflag)) { Yap_Error(INSTANTIATION_ERROR, tflag, "yap_flag/2"); return (FALSE); } if (IsApplTerm( tflag ) && FunctorOfTerm(tflag) == FunctorModule) { Term modt; tflag = Yap_StripModule( tflag, &modt ); if (!isatom(tflag)) return false; if (!isatom(modt)) return false; return setYapFlagInModule( tflag, t2, modt ); } if (!IsAtomTerm(tflag)) { Yap_Error(TYPE_ERROR_ATOM, tflag, "yap_flag/2"); return (FALSE); } fv = GetFlagProp( AtomOfTerm( tflag ) ); if (!fv) { Term fl = GLOBAL_Flags[USER_FLAGS_FLAG].at; if (fl == TermSilent) { CACHE_REGS Term t2 = Deref(ARG2); newFlag( tflag, t2); } else if (fl == TermWarning) { Yap_Warning("Flag %s does not exist", RepAtom(AtomOfTerm(fl))->StrOfAE); } else { Yap_Error(DOMAIN_ERROR_PROLOG_FLAG, fl, "trying to set unknown flag ~s", AtomName(AtomOfTerm(fl))); } return FALSE; } if (fv->global) tarr = GLOBAL_Flags; else { CACHE_REGS tarr = LOCAL_Flags; } if (!(fv->type(t2))) return false; if (fv->helper && !(fv->helper(t2))) return false; Term tout = tarr[fv->FlagOfVE].at; if (IsVarTerm(tout)) Yap_PopTermFromDB( tarr[fv->FlagOfVE].DBT ); if (IsAtomOrIntTerm(t2)) tarr[fv->FlagOfVE].at = t2; else { tarr[fv->FlagOfVE].DBT = Yap_StoreTermInDB(t2, 2); } return true; } Term getYapFlag( Term tflag ) { FlagEntry *fv; flag_term *tarr; if (IsVarTerm(tflag)) { Yap_Error(INSTANTIATION_ERROR, tflag, "yap_flag/2"); return (FALSE); } if (IsApplTerm( tflag ) && FunctorOfTerm(tflag) == FunctorModule) { Term modt; tflag = Yap_StripModule( tflag, &modt ); if (!isatom(tflag)) return false; if (!isatom(modt)) return false; return getYapFlagInModule( tflag, modt ); } if (!IsAtomTerm(tflag)) { Yap_Error(TYPE_ERROR_ATOM, tflag, "yap_flag/2"); return (FALSE); } fv = GetFlagProp( AtomOfTerm( tflag ) ); if (!fv) { Term fl = GLOBAL_Flags[USER_FLAGS_FLAG].at; if (fl == TermSilent) { return false; } else if (fl == TermWarning) { Yap_Warning("Flag ~s does not exist", RepAtom(AtomOfTerm(fl))->StrOfAE); } else { Yap_Error(DOMAIN_ERROR_PROLOG_FLAG, fl, "trying to read unknown flag %s", RepAtom(AtomOfTerm(fl))->StrOfAE); } return FALSE; } if (fv->global) tarr = GLOBAL_Flags; else { CACHE_REGS tarr = LOCAL_Flags; } Term tout = tarr[fv->FlagOfVE].at; if (IsVarTerm(tout)) return Yap_FetchTermFromDB( tarr[fv->FlagOfVE].DBT ); else return tout; } /** @pred set_prolog_flag(+ _Flag_,+ _Value_) is iso Set the value for YAP Prolog flag `Flag`. Equivalent to calling yap_flag/2 with both arguments bound. */ static Int set_prolog_flag(USES_REGS1) { Term tflag = Deref(ARG1), t2 = Deref(ARG2); return setYapFlag( tflag, t2 ); } /** @pred source After executing this goal, YAP keeps information on the source of the predicates that will be consulted. This enables the use of [listing/0](@ref listing), `listing/1` and [clause/2](@ref clause) for those clauses. The same as `source_mode(_,on)` or as declaring all newly defined static procedures as `public`. */ static Int source(USES_REGS1) { setBooleanGlobalPrologFlag(SOURCE_FLAG, true); return true; } /** @pred no_source The opposite to `source`. The same as `source_mode(_,off)`. */ static Int no_source(USES_REGS1) { setBooleanGlobalPrologFlag(SOURCE_FLAG, false); return true; } /** @pred source_mode(- _O_,+ _N_) The state of source mode can either be on or off. When the source mode is on, all clauses are kept both as compiled code and in a "hidden" database. _O_ is unified with the previous state and the mode is set according to _N_. */ static Int source_mode( USES_REGS1 ) { Term targ; bool current = trueGlobalPrologFlag(SOURCE_FLAG); if (current && !Yap_unify_constant( ARG1, TermTrue ) ) return false; if (!current && !Yap_unify_constant( ARG1, TermFalse) ) return false; targ = Deref(ARG2); setYapFlag( TermSource, ARG2 ); return true; } static bool setInitialValue( bool bootstrap, flag_func f, const char *s,flag_term *tarr ) { errno = 0; if (f == boolean) { if (!bootstrap) { return 0; } if (!strcmp(s, "true")) { tarr->at = TermTrue; return true; } if (!strcmp(s, "false")) { tarr->at = TermFalse; return true; } if (!strcmp(s, "on")) { tarr->at = TermTrue; return true; } if (!strcmp(s, "off")) { tarr->at = TermFalse; return true; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, TermNil, "~s should be either true (on) or false (off)", s); return false; } else if (f == nat) { if (!bootstrap) { return 0; } UInt r = strtoul(s, NULL, 10); Term t; if (errno) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, TermNil, "~s should be a positive integer)", s); return false; } CACHE_REGS t= MkIntegerTerm(r); if (IsIntTerm(t)) tarr->at = t; else { tarr->DBT = Yap_StoreTermInDB(t, 2); } return true; } else if (f == at2n) { if (!bootstrap) { return 0; } if (!strcmp(s, "INT_MAX")) { tarr->at = MkIntTerm(Int_MAX); return true; } if (!strcmp(s, "MAX_THREADS")) { tarr->at = MkIntTerm(MAX_THREADS); return true; } if (!strcmp(s, "MAX_WORKERS")) { tarr->at = MkIntTerm(MAX_WORKERS); return true; } if (!strcmp(s, "INT_MIN")) { tarr->at = MkIntTerm(Int_MIN); return true; } if (!strcmp(s, "YAP_NUMERIC_VERSION")) { tarr->at = MkIntTerm(atol(YAP_NUMERIC_VERSION)); return true; } if (!strcmp(s, "YAP_NUMERIC_VERSION")) { tarr->at = MkIntTerm(atol(YAP_NUMERIC_VERSION)); return true; } Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, TermNil, "~s should be either true (on) or false (off)", s); return false; } else if (f == isatom) { if (!bootstrap) { return false; } Atom r = Yap_LookupAtom(s); if (errno) { Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, TermNil, "~s should be a positive integer)", s); tarr->at = TermNil; } tarr->at = MkAtomTerm( r ); return true; } else { Term t0; if (bootstrap) { return false; } CACHE_REGS t0 = Yap_StringToTerm(s, strlen(s)+1, &LOCAL_encoding, 1200, NULL); if (!t0) return false; if (IsAtomTerm(t0) || IsIntTerm(t0)) { // do yourself flags if (t0 == MkAtomTerm(AtomQuery)) { f(TermNil); } else { tarr->at = t0; } } else { tarr->DBT = Yap_StoreTermInDB(t0, 2); } return true; } } #define PROLOG_FLAG_PROPERTY_DEFS() \ PAR( "access", isaccess, PROLOG_FLAG_PROPERTY_ACCESS, "read_write" ), \ PAR( "type", isground, PROLOG_FLAG_PROPERTY_TYPE, "term" ), \ PAR( "scope", flagscope, PROLOG_FLAG_PROPERTY_SCOPE, "global" ), \ PAR( "keep", boolean, PROLOG_FLAG_PROPERTY_KEEP, "false" ), \ PAR( NULL, ok, PROLOG_FLAG_PROPERTY_END, 0 ) #define PAR(x,y,z,w) z typedef enum prolog_flag_property_enum_choices { PROLOG_FLAG_PROPERTY_DEFS() } prolog_flag_property_choices_t; #undef PAR #define PAR(x,y,z, w) { x , y, z, w } static const param2_t prolog_flag_property_defs[] = { PROLOG_FLAG_PROPERTY_DEFS() }; #undef PAR static Int do_prolog_flag_property (Term tflag, Term opts USES_REGS) { /* Init current_prolog_flag */ FlagEntry *fv; xarg *args; prolog_flag_property_choices_t i; bool rc = true; args = Yap_ArgList2ToVector ( opts, prolog_flag_property_defs, PROLOG_FLAG_PROPERTY_END ); if (args == NULL) { return FALSE; } if (!IsAtomTerm(tflag)) { if (IsApplTerm( tflag ) && FunctorOfTerm(tflag) == FunctorModule) { Term modt = CurrentModule; tflag = Yap_YapStripModule( tflag, &modt ); } else { Yap_Error(TYPE_ERROR_ATOM, tflag, "yap_flag/2"); return (FALSE); } } fv = GetFlagProp( AtomOfTerm( tflag ) ); for (i=0; i < PROLOG_FLAG_PROPERTY_END; i ++) { if (args[i].used) { switch (i) { case PROLOG_FLAG_PROPERTY_ACCESS: if (fv->rw) rc = rc && Yap_unify(TermReadWrite, args[PROLOG_FLAG_PROPERTY_ACCESS].tvalue); else rc = rc && Yap_unify(TermReadOnly, args[PROLOG_FLAG_PROPERTY_ACCESS].tvalue); break; case PROLOG_FLAG_PROPERTY_TYPE: if (fv->type == boolean) rc = rc && Yap_unify(TermBoolean, args[PROLOG_FLAG_PROPERTY_TYPE].tvalue); else if (fv->type == isatom) rc = rc && Yap_unify(TermAtom, args[PROLOG_FLAG_PROPERTY_TYPE].tvalue); else if (fv->type == nat) rc = rc && Yap_unify(TermInteger, args[PROLOG_FLAG_PROPERTY_TYPE].tvalue); else if (fv->type == isfloat) rc = rc && Yap_unify(TermFloat, args[PROLOG_FLAG_PROPERTY_TYPE].tvalue); else rc = rc && Yap_unify(TermTerm, args[PROLOG_FLAG_PROPERTY_TYPE].tvalue); break; case PROLOG_FLAG_PROPERTY_KEEP: rc = rc && false; break; case PROLOG_FLAG_PROPERTY_SCOPE: if (fv->global) { if (fv->FlagOfVE == UNKNOWN_FLAG || fv->FlagOfVE == CHARACTER_ESCAPES_FLAG || fv->FlagOfVE == BACKQUOTED_STRING_FLAG) Yap_unify(TermModule, args[PROLOG_FLAG_PROPERTY_SCOPE].tvalue); rc = rc && Yap_unify(TermGlobal, args[PROLOG_FLAG_PROPERTY_SCOPE].tvalue); } else rc = rc && Yap_unify(TermThread, args[PROLOG_FLAG_PROPERTY_SCOPE].tvalue); break; case PROLOG_FLAG_PROPERTY_END: /* break; */ Yap_Error(DOMAIN_ERROR_PROLOG_FLAG, opts, "Flag not supported by YAP"); } } } // UNLOCK(GLOBAL_Prolog_Flag[sno].prolog_flaglock); return rc; } static Int cont_prolog_flag_property (USES_REGS1) { /* current_prolog_flag */ int i = IntOfTerm (EXTRA_CBACK_ARG (2, 1)); while (i < GLOBAL_flagCount+LOCAL_flagCount) { int gmax = GLOBAL_flagCount; int lmax = LOCAL_flagCount; Term lab; if (i >= gmax+lmax) { cut_fail(); } else if (i >= gmax) { lab = MkAtomTerm( Yap_LookupAtom( local_flags_setup[i-gmax].name ) ) ; } else { if (i == UNKNOWN_FLAG || i == CHARACTER_ESCAPES_FLAG || i == BACKQUOTED_STRING_FLAG) { Term labs[2]; labs[0] = MkVarTerm(); labs[1] = MkAtomTerm( Yap_LookupAtom( global_flags_setup[i].name ) ) ; lab = Yap_MkApplTerm(FunctorModule, 2, labs); } else { lab = MkAtomTerm( Yap_LookupAtom( global_flags_setup[i].name ) ) ; } } EXTRA_CBACK_ARG (2, 1) = MkIntTerm (++i); Yap_unify(ARG1, lab); return do_prolog_flag_property(lab, Deref(ARG2) PASS_REGS); } cut_fail(); } /** @pred prolog_flag_property(+ _Flag_,+ _Prooperties_) Report a property for a YAP Prolog flag. _Properties_ include * `type(+_Type_)` with _Type_ one of `boolean`, `integer`, `float`, `atom` and `term` (that is, any ground term) * `access(+_Access_)` with _Access_ one of `read_only` or `read_write` * `scope(+_Scope_) the flag aplies to a `thread`, to a `module`, or is `global` to the system. */ static Int prolog_flag_property (USES_REGS1) { /* Init current_prolog_flag */ Term t1 = Deref(ARG1); /* make valgrind happy by always filling in memory */ EXTRA_CBACK_ARG (2, 1) = MkIntTerm (0); if (IsVarTerm(t1)) { return (cont_prolog_flag_property (PASS_REGS1)); } else { if (IsApplTerm( t1 ) && FunctorOfTerm(t1) == FunctorModule) { Term modt; t1 = Yap_StripModule( t1, &modt ); if (IsAtomTerm( modt )) { Int rc; rc = cont_prolog_flag_property( PASS_REGS1 ); return rc; } } else if (IsAtomTerm(t1)) { do_cut(0); return do_prolog_flag_property( t1, Deref(ARG2) PASS_REGS); } else { Yap_Error(TYPE_ERROR_ATOM, t1, "prolog_flag_property/2"); } } return false; } static void newFlag( Term fl, Term val ) { flag_info f; int i = GLOBAL_flagCount; GLOBAL_flagCount ++; f.name = (char *)RepAtom(AtomOfTerm(fl))->StrOfAE; f.writable = true; f.helper = 0; f.def = ok; initFlag(&f, i , true); if (IsAtomOrIntTerm(val)) { GLOBAL_Flags[i].at = val; } else { GLOBAL_Flags[i].DBT = Yap_StoreTermInDB(val, 2); } } static Int do_create_prolog_flag( USES_REGS1 ) { FlagEntry *fv; xarg *args; prolog_flag_property_choices_t i; Term tflag = Deref(ARG1), tval = Deref(ARG2), opts = Deref(ARG3); args = Yap_ArgList2ToVector ( opts, prolog_flag_property_defs, PROLOG_FLAG_PROPERTY_END ); if (args == NULL) { return FALSE; } fv = GetFlagProp( AtomOfTerm( tflag ) ); if (fv) { if (args[PROLOG_FLAG_PROPERTY_KEEP].used && args[PROLOG_FLAG_PROPERTY_KEEP].tvalue == TermTrue) return true; } else { newFlag( tflag, tval ); fv = GetFlagProp( AtomOfTerm( tflag ) ); } for (i=0; i < PROLOG_FLAG_PROPERTY_END; i ++) { if (args[i].used) { switch (i) { case PROLOG_FLAG_PROPERTY_KEEP: break; case PROLOG_FLAG_PROPERTY_ACCESS: if (args[PROLOG_FLAG_PROPERTY_ACCESS].tvalue == TermReadWrite) fv->rw = true; else fv->rw = false; break; case PROLOG_FLAG_PROPERTY_TYPE: { Term ttype = args[PROLOG_FLAG_PROPERTY_TYPE].tvalue; if (ttype == TermBoolean) fv->type = boolean; else if (ttype == TermInteger) fv->type = isatom; else if (ttype == TermFloat) fv->type = isfloat; else fv->type = isground; } break; case PROLOG_FLAG_PROPERTY_SCOPE: return false; case PROLOG_FLAG_PROPERTY_END: break; } } } //UNLOCK(GLOBAL_Prolog_Flag[sno].prolog_flaglock); return true; } /** * Init System Prolog flags. This is done in two phases: * early on, it takes care of the atomic flags that are required by other modules; * later, it looks at flags that are structured terms * * @param bootstrap: wether this is done before stack initialization, or afterwards. * Complex terms can only be built in the second step. */ void Yap_InitFlags( bool bootstrap) { CACHE_REGS tr_fr_ptr tr0 = TR; flag_info *f = global_flags_setup; GLOBAL_flagCount = 0; if (bootstrap) { GLOBAL_Flags = (union flagTerm *)Yap_AllocCodeSpace(sizeof(union flagTerm)*(2*sizeof(global_flags_setup)/sizeof(flag_info))); } while (f->name != NULL) { bool itf = setInitialValue( bootstrap, f->def, f->init, GLOBAL_Flags+GLOBAL_flagCount ); if (itf) { initFlag( f, GLOBAL_flagCount, true); } GLOBAL_flagCount ++; f++; } LOCAL_flagCount = 0; int nflags = sizeof(local_flags_setup)/sizeof(flag_info); if (bootstrap) LOCAL_Flags = (union flagTerm *)Yap_AllocCodeSpace(sizeof(union flagTerm)*nflags); f = local_flags_setup; while (f->name != NULL) { bool itf = setInitialValue( bootstrap, f->def, f->init, LOCAL_Flags+LOCAL_flagCount ); // Term itf = Yap_StringToTerm(f->init, strlen(f->init)+1, LOCAL_encoding, 1200, &tp); if (itf) { initFlag( f, LOCAL_flagCount, false); } LOCAL_flagCount ++; f++; } if (!bootstrap) { Yap_InitCPredBack("current_prolog_flag", 2, 1, current_prolog_flag, cont_yap_flag, 0); TR = tr0; /** @pred prolog_flag(? _Flag_,- _Value__) Obtain the value for a YAP Prolog flag, same as current_prolog_flag/2_. */ Yap_InitCPredBack("prolog_flag", 3, 1, prolog_flag, cont_yap_flag, 0); Yap_InitCPredBack("prolog_flag", 2, 1, prolog_flag, cont_yap_flag, 0); Yap_InitCPred("set_prolog_flag", 2, set_prolog_flag, SyncPredFlag); Yap_InitCPred("$create_prolog_flag", 3, do_create_prolog_flag, SyncPredFlag); Yap_InitCPredBack("yap_flag", 2, 1, yap_flag,cont_yap_flag, 0); Yap_InitCPredBack("prolog_flag_property", 2, 1, prolog_flag_property,cont_prolog_flag_property, 0); Yap_InitCPred("source", 0, source,SyncPredFlag); Yap_InitCPred("no_source", 0, no_source,SyncPredFlag); Yap_InitCPred("source_mode", 2, source_mode, SyncPredFlag); } } /* Accessing and changing the flags for a predicate */