From c25d35356ad813b29b13bb5f45afd24ba6750c47 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Fri, 26 Feb 2016 17:18:37 +0000 Subject: [PATCH] Try to clarify operators prolog has priority and cannot be redefined by default. user is global but may be redefined others should just plug-in. --- C/adtdefs.c | 66 +++++++++++----------- C/modules.c | 2 +- C/parser.c | 113 +++++++++++++++++--------------------- C/stdpreds.c | 20 ++++--- C/write.c | 6 +- pl/utils.yap | 151 +++++++++++++++------------------------------------ 6 files changed, 142 insertions(+), 216 deletions(-) diff --git a/C/adtdefs.c b/C/adtdefs.c index c38d1cd15..8fb4ad869 100755 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -562,62 +562,62 @@ Yap_OpPropForModule(Atom a, return info; } -OpEntry * -Yap_GetOpProp(Atom a, - op_type type - USES_REGS) { /* look property list of atom a for kind */ - AtomEntry *ae = RepAtom(a); - PropEntry *pp; - OpEntry *oinfo = NULL; - - READ_LOCK(ae->ARWLock); - pp = RepProp(ae->PropsOfAE); +static OpEntry * +fetchOpWithModule( PropEntry *pp, Term tmod, op_type type ) +{ while (!EndOfPAEntr(pp)) { OpEntry *info = NULL; + if (pp->KindOfPE != OpProperty) { pp = RepProp(pp->NextOfPE); continue; } info = (OpEntry *)pp; - if (info->OpModule != CurrentModule && info->OpModule != PROLOG_MODULE) { + if (info->OpModule != tmod) { pp = RepProp(pp->NextOfPE); continue; } if (type == INFIX_OP) { if (!info->Infix) { - pp = RepProp(pp->NextOfPE); - continue; + return NULL; } } else if (type == POSFIX_OP) { if (!info->Posfix) { - pp = RepProp(pp->NextOfPE); - continue; + return NULL; } } else { if (!info->Prefix) { - pp = RepProp(pp->NextOfPE); - continue; + return NULL; } } - /* if it is not the latest module */ - if (info->OpModule == PROLOG_MODULE) { - /* cannot commit now */ - oinfo = info; - pp = RepProp(pp->NextOfPE); - } else { - READ_LOCK(info->OpRWLock); - READ_UNLOCK(ae->ARWLock); - return info; - } + return info; } - if (oinfo) { - READ_LOCK(oinfo->OpRWLock); - READ_UNLOCK(ae->ARWLock); - return oinfo; - } - READ_UNLOCK(ae->ARWLock); return NULL; } + +OpEntry * +Yap_GetOpProp(Atom a, + op_type type, + Term tmod + USES_REGS) { /* look property list of atom a for kind */ + AtomEntry *ae = RepAtom(a); + PropEntry *pp; + OpEntry *info; + + READ_LOCK(ae->ARWLock); + pp = RepProp(ae->PropsOfAE); + if (( (info = fetchOpWithModule( pp, tmod, type )) != NULL) || + ( (info = fetchOpWithModule( pp, USER_MODULE, type )) != NULL) || + ( (info = fetchOpWithModule( pp, PROLOG_MODULE, type )) != NULL) + ) { + LOCK(info->OpRWLock); + return info; + READ_UNLOCK(ae->ARWLock); + } + READ_UNLOCK(ae->ARWLock); + + return NULL; +} inline static Prop GetPredPropByAtomHavingLock(AtomEntry *ae, Term cur_mod) /* get predicate entry for ap/arity; create it if neccessary. */ diff --git a/C/modules.c b/C/modules.c index e3575fe25..ad3b26808 100644 --- a/C/modules.c +++ b/C/modules.c @@ -52,6 +52,7 @@ initMod( AtomEntry *toname, AtomEntry *ae) { n->KindOfPE = ModProperty; n->PredForME = NULL; n->NextME = CurrentModules; + n->ParentForME = CurrentModule; CurrentModules = n; n->AtomOfME = ae; n->OwnerFile = Yap_ConsultingFile( PASS_REGS1); @@ -259,7 +260,6 @@ static Int change_module(USES_REGS1) { /* $change_module(N) */ Term mod = Deref(ARG1); LookupModule(mod); CurrentModule = mod; - LOCAL_SourceModule = mod; return TRUE; } diff --git a/C/parser.c b/C/parser.c index b4f76eaef..77c0e20a1 100755 --- a/C/parser.c +++ b/C/parser.c @@ -164,9 +164,9 @@ typedef struct jmp_buff_struct { sigjmp_buf JmpBuff; } JMPBUFF; static void GNextToken(CACHE_TYPE1); static void checkfor(wchar_t, JMPBUFF *CACHE_TYPE); -static Term ParseArgs(Atom, wchar_t, JMPBUFF *, Term CACHE_TYPE); -static Term ParseList(JMPBUFF *CACHE_TYPE); -static Term ParseTerm(int, JMPBUFF *CACHE_TYPE); +static Term ParseArgs(Atom, wchar_t, JMPBUFF *, Term, Term CACHE_TYPE); +static Term ParseList(JMPBUFF *, Term CACHE_TYPE); +static Term ParseTerm(int, JMPBUFF *, Term CACHE_TYPE); const char *Yap_tokRep(TokEntry *tokptr); @@ -367,16 +367,12 @@ Term Yap_Variables(VarEntry *p, Term l) { return Variables(p, l PASS_REGS); } -static int IsPrefixOp(Atom op, int *pptr, int *rpptr USES_REGS) { +static int IsPrefixOp(Atom op, int *pptr, int *rpptr, Term tmod USES_REGS) { int p; - OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP PASS_REGS); + OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP, tmod PASS_REGS); if (!opp) return FALSE; - if (opp->OpModule && opp->OpModule != CurrentModule) { - READ_UNLOCK(opp->OpRWLock); - return FALSE; - } if ((p = opp->Prefix) != 0) { READ_UNLOCK(opp->OpRWLock); *pptr = *rpptr = p &MaskPrio; @@ -389,21 +385,17 @@ static int IsPrefixOp(Atom op, int *pptr, int *rpptr USES_REGS) { } } -int Yap_IsPrefixOp(Atom op, int *pptr, int *rpptr) { +int Yap_IsPrefixOp(Atom op, int *pptr, int *rpptr, Term tmod) { CACHE_REGS - return IsPrefixOp(op, pptr, rpptr PASS_REGS); + return IsPrefixOp(op, pptr, rpptr, tmod PASS_REGS); } -static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr USES_REGS) { +static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr, Term tmod USES_REGS) { int p; - OpEntry *opp = Yap_GetOpProp(op, INFIX_OP PASS_REGS); + OpEntry *opp = Yap_GetOpProp(op, INFIX_OP, tmod PASS_REGS); if (!opp) return FALSE; - if (opp->OpModule && opp->OpModule != CurrentModule) { - READ_UNLOCK(opp->OpRWLock); - return FALSE; - } if ((p = opp->Infix) != 0) { READ_UNLOCK(opp->OpRWLock); *pptr = *rpptr = *lpptr = p &MaskPrio; @@ -418,21 +410,17 @@ static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr USES_REGS) { } } -int Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr) { +int Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr, Term tmod) { CACHE_REGS - return IsInfixOp(op, pptr, lpptr, rpptr PASS_REGS); + return IsInfixOp(op, pptr, lpptr, rpptr, tmod PASS_REGS); } -static int IsPosfixOp(Atom op, int *pptr, int *lpptr USES_REGS) { +static int IsPosfixOp(Atom op, int *pptr, int *lpptr, Term tmod USES_REGS) { int p; - OpEntry *opp = Yap_GetOpProp(op, POSFIX_OP PASS_REGS); + OpEntry *opp = Yap_GetOpProp(op, POSFIX_OP, tmod PASS_REGS); if (!opp) return FALSE; - if (opp->OpModule && opp->OpModule != CurrentModule) { - READ_UNLOCK(opp->OpRWLock); - return FALSE; - } if ((p = opp->Posfix) != 0) { READ_UNLOCK(opp->OpRWLock); *pptr = *lpptr = p &MaskPrio; @@ -445,9 +433,9 @@ static int IsPosfixOp(Atom op, int *pptr, int *lpptr USES_REGS) { } } -int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr) { +int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr, Term tmod) { CACHE_REGS - return IsPosfixOp(op, pptr, lpptr PASS_REGS); + return IsPosfixOp(op, pptr, lpptr, tmod PASS_REGS); } inline static void GNextToken(USES_REGS1) { @@ -472,9 +460,9 @@ inline static void checkfor(wchar_t c, JMPBUFF *FailBuff USES_REGS) { #ifdef O_QUASIQUOTATIONS -static int is_quasi_quotation_syntax(Term goal, Atom *pat) { +static int is_quasi_quotation_syntax(Term goal, Term m, Atom *pat) { CACHE_REGS - Term m = CurrentModule, t; + Term t; Atom at; UInt arity; Functor f; @@ -524,8 +512,8 @@ static int get_quasi_quotation(term_t t, unsigned char **here, } #endif /*O_QUASIQUOTATIONS*/ -static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff, - Term arg1 USES_REGS) { +static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff, + Term arg1, Term tmod USES_REGS) { int nargs = 0; Term *p, t; Functor func; @@ -562,7 +550,7 @@ static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff, syntax_msg("line %d: Trail Overflow",LOCAL_tokptr->TokPos); FAIL; } - *tp++ = Unsigned(ParseTerm(999, FailBuff PASS_REGS)); + *tp++ = Unsigned(ParseTerm(999, FailBuff, tmod PASS_REGS)); ParserAuxSp = (char *)tp; ++nargs; if (LOCAL_tokptr->Tok != Ord(Ponctuation_tok)) @@ -617,14 +605,14 @@ static Term MakeAccessor(Term t, Functor f USES_REGS) { return Yap_MkApplTerm(f, 2, tf); } -static Term ParseList(JMPBUFF *FailBuff USES_REGS) { +static Term ParseList(JMPBUFF *FailBuff, Term tmod USES_REGS) { Term o; CELL *to_store; o = AbsPair(HR); loop: to_store = HR; HR += 2; - to_store[0] = ParseTerm(999, FailBuff PASS_REGS); + to_store[0] = ParseTerm(999, FailBuff, tmod PASS_REGS); if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok)) { if (((int)LOCAL_tokptr->TokInfo) == ',') { NextToken; @@ -641,7 +629,7 @@ loop: } } else if (((int)LOCAL_tokptr->TokInfo) == '|') { NextToken; - to_store[1] = ParseTerm(999, FailBuff PASS_REGS); + to_store[1] = ParseTerm(999, FailBuff, tmod PASS_REGS); } else { to_store[1] = MkAtomTerm(AtomNil); } @@ -653,7 +641,7 @@ loop: return (o); } -static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { +static Term ParseTerm(int prio, JMPBUFF *FailBuff, Term tmod USES_REGS) { /* parse term with priority prio */ Volatile Term t; Volatile Functor func; @@ -686,7 +674,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { } if ((LOCAL_tokptr->Tok != Ord(Ponctuation_tok) || Unsigned(LOCAL_tokptr->TokInfo) != 'l') && - IsPrefixOp((Atom)t, &opprio, &oprprio PASS_REGS)) { + IsPrefixOp((Atom)t, &opprio, &oprprio, tmod PASS_REGS)) { if (LOCAL_tokptr->Tok == Name_tok) { Atom at = (Atom)LOCAL_tokptr->TokInfo; #ifndef _MSC_VER @@ -721,7 +709,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos); FAIL; } - t = ParseTerm(oprprio, FailBuff PASS_REGS); + t = ParseTerm(oprprio, FailBuff, tmod PASS_REGS); t = Yap_MkApplTerm(func, 1, &t); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { @@ -733,7 +721,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { } if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok) && Unsigned(LOCAL_tokptr->TokInfo) == 'l') - t = ParseArgs((Atom)t, ')', FailBuff, 0L PASS_REGS); + t = ParseArgs((Atom)t, ')', FailBuff, 0L, tmod PASS_REGS); else t = MkAtomTerm((Atom)t); break; @@ -749,7 +737,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { // we may be operating under a syntax error yap_error_number oerr = LOCAL_Error_TYPE; LOCAL_Error_TYPE = YAP_NO_ERROR; - t = Yap_CharsToTDQ(p, CurrentModule, LOCAL_encoding PASS_REGS); + t = Yap_CharsToTDQ(p, tmod, LOCAL_encoding PASS_REGS); if (!t) { syntax_msg("line %d: could not convert \"%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo); FAIL; @@ -764,7 +752,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { // we may be operating under a syntax error yap_error_number oerr = LOCAL_Error_TYPE; LOCAL_Error_TYPE = YAP_NO_ERROR; - t = Yap_WCharsToTDQ(p, CurrentModule PASS_REGS); + t = Yap_WCharsToTDQ(p, tmod PASS_REGS); if (!t) { syntax_msg("line %d: could not convert \'%S\'",LOCAL_tokptr->TokPos, (wchar_t *)LOCAL_tokptr->TokInfo); FAIL; @@ -780,7 +768,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { yap_error_number oerr = LOCAL_Error_TYPE; LOCAL_Error_TYPE = YAP_NO_ERROR; - t = Yap_CharsToTBQ(p, CurrentModule, LOCAL_encoding PASS_REGS); + t = Yap_CharsToTBQ(p, tmod, LOCAL_encoding PASS_REGS); if (!t) { syntax_msg("line %d: could not convert \'%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo); FAIL; @@ -792,7 +780,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { case WBQString_tok: /* build list on the heap */ { Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo; - t = Yap_WCharsToTBQ(p, CurrentModule PASS_REGS); + t = Yap_WCharsToTBQ(p, tmod PASS_REGS); // we may be operating under a syntax error yap_error_number oerr = LOCAL_Error_TYPE; LOCAL_Error_TYPE = YAP_NO_ERROR; @@ -822,7 +810,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { case '(': case 'l': /* non solo ( */ NextToken; - t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS); + t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS); checkfor(')', FailBuff PASS_REGS); break; case '[': @@ -833,7 +821,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { NextToken; break; } - t = ParseList(FailBuff PASS_REGS); + t = ParseList(FailBuff, tmod PASS_REGS); checkfor(']', FailBuff PASS_REGS); break; case '{': @@ -844,7 +832,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { NextToken; break; } - t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS); + t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS); t = Yap_MkApplTerm(FunctorBraces, 1, &t); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { @@ -896,7 +884,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { } NextToken; - t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS); + t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS); if (LOCAL_tokptr->Tok != QuasiQuotes_tok) { syntax_msg("expected to find quasi quotes, got \"%s\"", , Yap_tokRep(LOCAL_tokptr)); @@ -954,7 +942,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { if (LOCAL_tokptr->Tok == Ord(Name_tok) && Yap_HasOp((Atom)(LOCAL_tokptr->TokInfo))) { Atom save_opinfo = opinfo = (Atom)(LOCAL_tokptr->TokInfo); - if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio PASS_REGS) && + if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio, tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { /* try parsing as infix operator */ Volatile int oldprio = curprio; @@ -967,7 +955,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { { Term args[2]; args[0] = t; - args[1] = ParseTerm(oprprio, FailBuff PASS_REGS); + args[1] = ParseTerm(oprprio, FailBuff, tmod PASS_REGS); t = Yap_MkApplTerm(func, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { @@ -979,7 +967,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { opinfo = save_opinfo; continue;, opinfo = save_opinfo; curprio = oldprio;) } - if (IsPosfixOp(opinfo, &opprio, &oplprio PASS_REGS) && opprio <= prio && + if (IsPosfixOp(opinfo, &opprio, &oplprio , tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { /* parse as posfix operator */ Functor func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 1); @@ -1005,7 +993,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { Volatile Term args[2]; NextToken; args[0] = t; - args[1] = ParseTerm(1000, FailBuff PASS_REGS); + args[1] = ParseTerm(1000, FailBuff, tmod PASS_REGS); t = Yap_MkApplTerm(FunctorComma, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { @@ -1015,12 +1003,12 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { curprio = 1000; continue; } else if (Unsigned(LOCAL_tokptr->TokInfo) == '|' && - IsInfixOp(AtomVBar, &opprio, &oplprio, &oprprio PASS_REGS) && + IsInfixOp(AtomVBar, &opprio, &oplprio, &oprprio, tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { Volatile Term args[2]; NextToken; args[0] = t; - args[1] = ParseTerm(oprprio, FailBuff PASS_REGS); + args[1] = ParseTerm(oprprio, FailBuff, tmod PASS_REGS); t = Yap_MkApplTerm(FunctorVBar, 2, args); /* check for possible overflow against local stack */ if (HR > ASP - 4096) { @@ -1030,24 +1018,24 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { curprio = opprio; continue; } else if (Unsigned(LOCAL_tokptr->TokInfo) == '(' && - IsPosfixOp(AtomEmptyBrackets, &opprio, &oplprio PASS_REGS) && + IsPosfixOp(AtomEmptyBrackets, &opprio, &oplprio, tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { - t = ParseArgs(AtomEmptyBrackets, ')', FailBuff, t PASS_REGS); + t = ParseArgs(AtomEmptyBrackets, ')', FailBuff, t, tmod PASS_REGS); curprio = opprio; continue; } else if (Unsigned(LOCAL_tokptr->TokInfo) == '[' && IsPosfixOp(AtomEmptySquareBrackets, &opprio, - &oplprio PASS_REGS) && + &oplprio, tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { - t = ParseArgs(AtomEmptySquareBrackets, ']', FailBuff, t PASS_REGS); + t = ParseArgs(AtomEmptySquareBrackets, ']', FailBuff, t, tmod PASS_REGS); t = MakeAccessor(t, FunctorEmptySquareBrackets PASS_REGS); curprio = opprio; continue; } else if (Unsigned(LOCAL_tokptr->TokInfo) == '{' && IsPosfixOp(AtomEmptyCurlyBrackets, &opprio, - &oplprio PASS_REGS) && + &oplprio, tmod PASS_REGS) && opprio <= prio && oplprio >= curprio) { - t = ParseArgs(AtomEmptyCurlyBrackets, '}', FailBuff, t PASS_REGS); + t = ParseArgs(AtomEmptyCurlyBrackets, '}', FailBuff, t, tmod PASS_REGS); t = MakeAccessor(t, FunctorEmptyCurlyBrackets PASS_REGS); curprio = opprio; continue; @@ -1062,7 +1050,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) { return t; } -Term Yap_Parse(UInt prio) { +Term Yap_Parse(UInt prio, Term tmod) { CACHE_REGS Volatile Term t; JMPBUFF FailBuff; @@ -1070,7 +1058,7 @@ Term Yap_Parse(UInt prio) { if (!sigsetjmp(FailBuff.JmpBuff, 0)) { - t = ParseTerm(prio, &FailBuff PASS_REGS); + t = ParseTerm(prio, &FailBuff, tmod PASS_REGS); #if DEBUG if (GLOBAL_Option['p' - 'a' + 1]) { Yap_DebugPutc(stderr, '['); @@ -1083,7 +1071,8 @@ Term Yap_Parse(UInt prio) { } #endif Yap_CloseSlots(sls); - if (LOCAL_tokptr != NULL && LOCAL_tokptr->Tok != Ord(eot_tok)) { + if (LOCAL_Error_TYPE == YAP_NO_ERROR && + LOCAL_tokptr != NULL && LOCAL_tokptr->Tok != Ord(eot_tok)) { LOCAL_Error_TYPE = SYNTAX_ERROR; LOCAL_ErrorMessage = "term does not end on . "; t = 0; diff --git a/C/stdpreds.c b/C/stdpreds.c index f67130843..863a77a68 100755 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -984,24 +984,27 @@ int Yap_IsOpMaxPrio(Atom at) { return max; } -static Int unify_op(OpEntry *op USES_REGS) { +static bool unify_op(OpEntry *op, Term emod 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)) && + if (tmod != PROLOG_MODULE && + tmod != USER_MODULE && + tmod != emod && + (op->Prefix || op->Infix || op->Posfix)) + return false; + return 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; - + Term emod = Deref(ARG2); + READ_LOCK(op->OpRWLock); next = op->OpNext; if (Yap_unify_constant(ARG1, MkAtomTerm(op->OpName)) && - unify_op(op PASS_REGS)) { + unify_op(op, emod PASS_REGS)) { READ_UNLOCK(op->OpRWLock); if (next) { EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); @@ -1014,7 +1017,6 @@ static Int cont_current_op(USES_REGS1) { READ_UNLOCK(op->OpRWLock); if (next) { EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); - B->cp_h = HR; return FALSE; } else { cut_fail(); @@ -1034,7 +1036,7 @@ static Int cont_current_atom_op(USES_REGS1) { READ_LOCK(op->OpRWLock); next = NextOp(RepOpProp(op->NextOfPE) PASS_REGS); - if (unify_op(op PASS_REGS)) { + if (unify_op(op, CurrentModule PASS_REGS)) { READ_UNLOCK(op->OpRWLock); if (next) { EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); diff --git a/C/write.c b/C/write.c index 89ba06d03..a986600ee 100644 --- a/C/write.c +++ b/C/write.c @@ -1007,7 +1007,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, return; } } - if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) { + if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp, CurrentModule)) { Term tright = ArgOfTerm(1, t); int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) && Yap_IsOp(AtomOfTerm(tright)); @@ -1035,7 +1035,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, ((atom == AtomEmptyBrackets || atom == AtomEmptyCurlyBrackets || atom == AtomEmptySquareBrackets) && Yap_IsListTerm(ArgOfTerm(1, t)))) && - Yap_IsPosfixOp(atom, &op, &lp)) { + Yap_IsPosfixOp(atom, &op, &lp, CurrentModule)) { Term tleft = ArgOfTerm(1, t); int bracket_left, offset; @@ -1087,7 +1087,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg, wrclose_bracket(wglb, TRUE); } } else if (!wglb->Ignore_ops && Arity == 2 && - Yap_IsInfixOp(atom, &op, &lp, &rp)) { + Yap_IsInfixOp(atom, &op, &lp, &rp, CurrentModule)) { Term tleft = ArgOfTerm(1, t); Term tright = ArgOfTerm(2, t); int bracket_left = diff --git a/pl/utils.yap b/pl/utils.yap index 800d63438..e1a2c2eb3 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -48,37 +48,45 @@ a postfix operator. */ op(P,T,V) :- - '$check_op'(P,T,V,op(P,T,V)), - '$op'(P, T, V). + '$yap_strip_module'(V, M, N), + '$check_top_op'(P,T,N,M,op(P,T,V)). % just check the operator declarations for correctness. -'$check_op'(P,T,Op,G) :- +'$check_top_op'(P,T,Op,_M,G) :- ( var(P) ; var(T); var(Op)), !, '$do_error'(instantiation_error,G). -'$check_op'(P,_,_,G) :- +'$check_top_op'(P,_,_,_,G) :- \+ integer(P), !, '$do_error'(type_error(integer,P),G). -'$check_op'(P,_,_,G) :- +'$check_top_op'(P,_,_,_,G) :- P < 0, !, '$do_error'(domain_error(operator_priority,P),G). -'$check_op'(_,T,_,G) :- +'$check_top_op'(_,T,_,_,G) :- \+ atom(T), !, '$do_error'(type_error(atom,T),G). -'$check_op'(_,T,_,G) :- +'$check_top_op'(_,T,_,_,G) :- \+ '$associativity'(T), !, '$do_error'(domain_error(operator_specifier,T),G). -'$check_op'(P,T,V,G) :- - '$check_module_for_op'(V, G, NV), - '$check_top_op'(P, T, NV, G). - -'$check_top_op'(_, _, [], _) :- !. -'$check_top_op'(P, T, [Op|NV], G) :- !, - '$check_ops'(P, T, Op.NV, G). -'$check_top_op'(P, T, V, G) :- - atom(V), !, - '$check_op_name'(P, T, V, G). -'$check_top_op'(_P, _T, V, G) :- - '$do_error'(type_error(atom,V),G). +'$check_top_op'(P, T, M:Op, _M, G) :- !, + '$vsc_strip_module'(M:Op, M1, Op1), + ( + atom(M1) + -> + '$check_top_op'(P, T, Op1, M1, G) + ; + '$do_error'(type_error(atom,Op),G) + ). +'$check_top_op'(P, T, [Op|NV], M, G) :- !, + '$check_top_op'(P, T, Op, M, G), + (NV = [] + -> + true + ; + '$check_top_op'(P, T, NV, M, G) + ). +'$check_top_op'(P, T, V, M, G) :- + '$check_op_name'(P, T, V, M, G), + '$opdec'(P, T, V, M). '$associativity'(xfx). '$associativity'(xfy). @@ -89,43 +97,16 @@ a postfix operator. '$associativity'(fx). '$associativity'(fy). -'$check_module_for_op'(MOp, G, _) :- - var(MOp), !, - '$do_error'(instantiation_error,G). -'$check_module_for_op'(M:_V, G, _) :- - var(M), !, - '$do_error'(instantiation_error,G). -'$check_module_for_op'(M:V, G, NV) :- - atom(M), !, - '$check_module_for_op'(V, G, NV). -'$check_module_for_op'(M:_V, G, _) :- !, - '$do_error'(type_error(atom,M),G). -'$check_module_for_op'(V, _G, V). - -'$check_ops'(_P, _T, [], _G) :- !. -'$check_ops'(P, T, [Op|NV], G) :- !, - ( - var(NV) - -> - '$do_error'(instantiation_error,G) - ; - '$check_module_for_op'(Op, G, NOp), - '$check_op_name'(P, T, NOp, G), - '$check_ops'(P, T, NV, G) - ). -'$check_ops'(_P, _T, Ops, G) :- - '$do_error'(type_error(list,Ops),G). - -'$check_op_name'(_,_,V,G) :- +'$check_op_name'(_,_,V,_,G) :- var(V), !, '$do_error'(instantiation_error,G). - '$check_op_name'(_,_,',',G) :- !, + '$check_op_name'(_,_,',',_,G) :- !, '$do_error'(permission_error(modify,operator,','),G). -'$check_op_name'(_,_,'[]',G) :- T \= yf, T\= xf, !, +'$check_op_name'(_,_,'[]',_,G) :- T \= yf, T\= xf, !, '$do_error'(permission_error(create,operator,'[]'),G). -'$check_op_name'(_,_,'{}',G) :- T \= yf, T\= xf, !, +'$check_op_name'(_,_,'{}',_,G) :- T \= yf, T\= xf, !, '$do_error'(permission_error(create,operator,'{}'),G). -'$check_op_name'(P,T,'|',G) :- +'$check_op_name'(P,T,'|',_,G) :- ( integer(P), P < 1001, P > 0 @@ -133,77 +114,31 @@ a postfix operator. atom_codes(T,[_,_]) ), !, '$do_error'(permission_error(create,operator,'|'),G). -'$check_op_name'(_,_,V,_) :- - atom(V), !. -'$check_op_name'(_,_,A,G) :- +'$check_op_name'(P,T,A,M,_G) :- + atom(A), !, + '$opdec'( P, T, A, M). +'$check_op_name'(_,_,A,_,G) :- '$do_error'(type_error(atom,A),G). - -'$op'(P, T, ML) :- - strip_module(ML, M, [A|As]), !, - '$opl'(P, T, M, [A|As]). -'$op'(P, T, A) :- - '$op2'(P,T,A). - -'$opl'(_P, _T, _, []). -'$opl'(P, T, M, [A|As]) :- - '$op2'(P, T, M:A), - '$opl'(P, T, M, As). - -'$op2'(P,T,A) :- - atom(A), !, - '$opdec'(P,T,A,prolog). -'$op2'(P,T,A) :- - strip_module(A,M,N), - '$opdec'(P,T,N,M). + /** @pred current_op( _P_, _T_, _F_) is iso Defines the relation: _P_ is a currently defined operator of type - _T_ and precedence _P_. +b*c _T_ and precedence _P_. Returns only operators defined in current module. */ -current_op(X,Y,V) :- var(V), !, - '$current_module'(M), - '$do_current_op'(X,Y,V,M). -current_op(X,Y,M:Z) :- !, - '$current_opm'(X,Y,Z,M). -current_op(X,Y,Z) :- - '$current_module'(M), - '$do_current_op'(X,Y,Z,M). +current_op(X,Y,V) :- + '$yap_strip_module'(V,M,O), + '$do_current_op'(X, Y, O, M). - -'$current_opm'(X,Y,Z,M) :- - nonvar(Y), - \+ '$associativity'(Y), - '$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)). -'$current_opm'(X,Y,Z,M) :- - var(Z), !, - '$do_current_op'(X,Y,Z,M). -'$current_opm'(X,Y,M:Z,_) :- !, - '$current_opm'(X,Y,Z,M). -'$current_opm'(X,Y,Z,M) :- - '$do_current_op'(X,Y,Z,M). - -'$do_current_op'(X,Y,Z,M) :- +'$do_current_op'(X,Y,Z, M) :- nonvar(Y), \+ '$associativity'(Y), '$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)). '$do_current_op'(X,Y,Z,M) :- - atom(Z), !, - '$current_atom_op'(Z, M1, Prefix, Infix, Posfix), - ( M1 = prolog -> true ; M1 = M ), - ( - '$get_prefix'(Prefix, X, Y) - ; - '$get_infix'(Infix, X, Y) - ; - '$get_posfix'(Posfix, X, Y) - ). -'$do_current_op'(X,Y,Z,M) :- - '$current_op'(Z, M1, Prefix, Infix, Posfix), - ( M1 = prolog -> true ; M1 = M ), + '$current_op'(Z, M, Prefix, Infix, Posfix), ( '$get_prefix'(Prefix, X, Y) ;