diff --git a/C/adtdefs.c b/C/adtdefs.c index 97a43ba73..cc695710e 100644 --- a/C/adtdefs.c +++ b/C/adtdefs.c @@ -413,7 +413,24 @@ Yap_GetAProp(Atom a, PropFlags kind) } OpEntry * -Yap_GetOpProp(Atom a) +Yap_GetOpPropForAModuleHavingALock(Atom a, Term mod) +{ /* look property list of atom a for kind */ + AtomEntry *ae = RepAtom(a); + PropEntry *pp; + + pp = RepProp(ae->PropsOfAE); + while (!EndOfPAEntr(pp) && + (pp->KindOfPE != OpProperty || + ((OpEntry *)pp)->OpModule != mod)) + pp = RepProp(pp->NextOfPE); + if (EndOfPAEntr(pp)) { + return NULL; + } + return (OpEntry *)pp; +} + +int +Yap_HasOp(Atom a) { /* look property list of atom a for kind */ AtomEntry *ae = RepAtom(a); PropEntry *pp; @@ -421,15 +438,55 @@ Yap_GetOpProp(Atom a) READ_LOCK(ae->ARWLock); pp = RepProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && - ( pp->KindOfPE != OpProperty || - (((OpEntry *)pp)->OpModule && - ((OpEntry *)pp)->OpModule != CurrentModule))) + ( pp->KindOfPE != OpProperty)) pp = RepProp(pp->NextOfPE); - READ_UNLOCK(ae->ARWLock); - if (EndOfPAEntr(pp)) + if (EndOfPAEntr(pp)) { + return FALSE; + } else { + return TRUE; + } +} + +OpEntry * +Yap_GetOpProp(Atom a, op_type type) +{ /* look property list of atom a for kind */ + AtomEntry *ae = RepAtom(a); + PropEntry *pp; + OpEntry *info = NULL; + + READ_LOCK(ae->ARWLock); + pp = RepProp(ae->PropsOfAE); + while (!EndOfPAEntr(pp) && + ( pp->KindOfPE != OpProperty || + ((OpEntry *)pp)->OpModule != CurrentModule)) + pp = RepProp(pp->NextOfPE); + if ((info = (OpEntry *)pp)) { + if ((type == INFIX_OP && !info->Infix) || + (type == POSFIX_OP && !info->Posfix) || + (type == PREFIX_OP && !info->Prefix)) + pp = RepProp(NIL); + } + if (EndOfPAEntr(pp)) { + pp = RepProp(ae->PropsOfAE); + while (!EndOfPAEntr(pp) && + ( pp->KindOfPE != OpProperty || + ((OpEntry *)pp)->OpModule != PROLOG_MODULE)) + pp = RepProp(pp->NextOfPE); + if ((info = (OpEntry *)pp)) { + if ((type == INFIX_OP && !info->Infix) || + (type == POSFIX_OP && !info->Posfix) || + (type == PREFIX_OP && !info->Prefix)) + pp = RepProp(NIL); + } + } + if (!info) { + READ_UNLOCK(ae->ARWLock); return NULL; - else - return (OpEntry *)pp; + } else { + READ_LOCK(info->OpRWLock); + READ_UNLOCK(ae->ARWLock); + return info; + } } diff --git a/C/init.c b/C/init.c index 9211c1e69..247e8ab88 100644 --- a/C/init.c +++ b/C/init.c @@ -229,6 +229,8 @@ OpDec(int p, char *type, Atom a, Term m) AtomEntry *ae = RepAtom(a); OpEntry *info; + if (m == TermProlog) + m = PROLOG_MODULE; for (i = 1; i <= 7; ++i) if (strcmp(type, optypes[i]) == 0) break; @@ -243,7 +245,7 @@ OpDec(int p, char *type, Atom a, Term m) p |= DcrrpFlag; } WRITE_LOCK(ae->ARWLock); - info = RepOpProp(Yap_GetAPropHavingLock(ae, OpProperty)); + info = Yap_GetOpPropForAModuleHavingALock(ae, m); if (EndOfPAEntr(info)) { info = (OpEntry *) Yap_AllocAtomSpace(sizeof(OpEntry)); info->KindOfPE = Ord(OpProperty); @@ -269,7 +271,7 @@ OpDec(int p, char *type, Atom a, Term m) /* ISO dictates */ WRITE_UNLOCK(info->OpRWLock); Yap_Error(PERMISSION_ERROR_CREATE_OPERATOR,MkAtomTerm(a),"op/3"); - return(FALSE); + return FALSE; } info->Infix = p; } else if (i <= 5) { @@ -278,7 +280,7 @@ OpDec(int p, char *type, Atom a, Term m) /* ISO dictates */ WRITE_UNLOCK(info->OpRWLock); Yap_Error(PERMISSION_ERROR_CREATE_OPERATOR,MkAtomTerm(a),"op/3"); - return(FALSE); + return FALSE; } info->Posfix = p; } else { diff --git a/C/parser.c b/C/parser.c index 92b3878d8..62ebd43cd 100644 --- a/C/parser.c +++ b/C/parser.c @@ -198,11 +198,13 @@ Yap_VarNames(VarEntry *p,Term l) } static int -IsPrefixOp(OpEntry *opp,int *pptr, int *rpptr) +IsPrefixOp(Atom op,int *pptr, int *rpptr) { int p; - READ_LOCK(opp->OpRWLock); + OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP); + if (!opp) + return FALSE; if (opp->OpModule && opp->OpModule != CurrentModule) return FALSE; @@ -219,17 +221,19 @@ IsPrefixOp(OpEntry *opp,int *pptr, int *rpptr) } int -Yap_IsPrefixOp(OpEntry *opinfo,int *pptr, int *rpptr) +Yap_IsPrefixOp(Atom op,int *pptr, int *rpptr) { - return IsPrefixOp(opinfo,pptr,rpptr); + return IsPrefixOp(op,pptr,rpptr); } static int -IsInfixOp(OpEntry *opp, int *pptr, int *lpptr, int *rpptr) +IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr) { int p; - READ_LOCK(opp->OpRWLock); + OpEntry *opp = Yap_GetOpProp(op, INFIX_OP); + if (!opp) + return FALSE; if (opp->OpModule && opp->OpModule != CurrentModule) return FALSE; @@ -248,17 +252,19 @@ IsInfixOp(OpEntry *opp, int *pptr, int *lpptr, int *rpptr) } int -Yap_IsInfixOp(OpEntry *opinfo, int *pptr, int *lpptr, int *rpptr) +Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr) { - return IsInfixOp(opinfo, pptr, lpptr, rpptr); + return IsInfixOp(op, pptr, lpptr, rpptr); } static int -IsPosfixOp(OpEntry *opp, int *pptr, int *lpptr) +IsPosfixOp(Atom op, int *pptr, int *lpptr) { int p; - READ_LOCK(opp->OpRWLock); + OpEntry *opp = Yap_GetOpProp(op, INFIX_OP); + if (!opp) + return FALSE; if (opp->OpModule && opp->OpModule != CurrentModule) return FALSE; @@ -275,9 +281,9 @@ IsPosfixOp(OpEntry *opp, int *pptr, int *lpptr) } int -Yap_IsPosfixOp(OpEntry *opinfo, int *pptr, int *lpptr) +Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr) { - return IsPosfixOp(opinfo, pptr, lpptr); + return IsPosfixOp(op, pptr, lpptr); } inline static void @@ -418,11 +424,11 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff) { /* parse term with priority prio */ - Volatile OpEntry *opinfo; Volatile Term t; Volatile Functor func; Volatile VarEntry *varinfo; Volatile int curprio = 0, opprio, oplprio, oprprio; + Volatile Atom opinfo; switch (Yap_tokptr->Tok) { case Name_tok: @@ -430,8 +436,7 @@ ParseTerm(int prio, JMPBUFF *FailBuff) NextToken; if ((Yap_tokptr->Tok != Ord(Ponctuation_tok) || Unsigned(Yap_tokptr->TokInfo) != 'l') - && (opinfo = Yap_GetOpProp((Atom) t)) - && IsPrefixOp(opinfo, &opprio, &oprprio) + && IsPrefixOp((Atom)t, &opprio, &oprprio) ) { /* special rules apply for +1, -2.3, etc... */ if (Yap_tokptr->Tok == Number_tok) { @@ -615,9 +620,9 @@ ParseTerm(int prio, JMPBUFF *FailBuff) /* main loop to parse infix and posfix operators starts here */ while (TRUE) { if (Yap_tokptr->Tok == Ord(Name_tok) - && (opinfo = Yap_GetOpProp((Atom)(Yap_tokptr->TokInfo)))) { - OpEntry *save_opinfo = opinfo; - if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio) + && Yap_HasOp((Atom)(Yap_tokptr->TokInfo))) { + Atom save_opinfo = opinfo = (Atom)(Yap_tokptr->TokInfo); + if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio) && opprio <= prio && oplprio >= curprio) { /* try parsing as infix operator */ Volatile int oldprio = curprio; diff --git a/C/write.c b/C/write.c index 55b5bd347..9d7a35127 100644 --- a/C/write.c +++ b/C/write.c @@ -217,15 +217,13 @@ legalAtom(unsigned char *s) /* Is this a legal atom ? */ static int LeftOpToProtect(Atom at, int p) { int op, rp; - OpEntry *opinfo = Yap_GetOpProp(at); - return(opinfo && Yap_IsPrefixOp(opinfo, &op, &rp) ); + return Yap_IsPrefixOp(at, &op, &rp); } static int RightOpToProtect(Atom at, int p) { int op, lp; - OpEntry *opinfo = Yap_GetOpProp(at); - return(opinfo && Yap_IsPosfixOp(opinfo, &op, &lp) ); + return Yap_IsPosfixOp(at, &op, &lp); } static wtype @@ -612,7 +610,6 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str Functor functor = FunctorOfTerm(t); int Arity; Atom atom; - OpEntry *opinfo; int op, lp, rp; if (IsExtensionFunctor(functor)) { @@ -689,7 +686,6 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str } Arity = ArityOfFunctor(functor); atom = NameOfFunctor(functor); - opinfo = Yap_GetOpProp(atom); #ifdef SFUNC if (Arity == SFArity) { int argno = 1; @@ -744,8 +740,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str return; } if (!wglb->Ignore_ops && - Arity == 1 && opinfo && Yap_IsPrefixOp(opinfo, &op, - &rp) + Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp) #ifdef DO_NOT_WRITE_PLUS_AND_MINUS_AS_PREFIX && /* never write '+' and '-' as infix @@ -782,7 +777,8 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str lastw = separator; } } else if (!wglb->Ignore_ops && - Arity == 1 && opinfo && Yap_IsPosfixOp(opinfo, &op, &lp)) { + Arity == 1 && + Yap_IsPosfixOp(atom, &op, &lp)) { Term tleft = ArgOfTerm(1, t); long sl = 0; int bracket_left = @@ -820,7 +816,7 @@ writeTerm(Term t, int p, int depth, int rinfixarg, struct write_globs *wglb, str lastw = separator; } } else if (!wglb->Ignore_ops && - Arity == 2 && opinfo && Yap_IsInfixOp(opinfo, &op, &lp, + Arity == 2 && Yap_IsInfixOp(atom, &op, &lp, &rp) ) { Term tleft = ArgOfTerm(1, t); Term tright = ArgOfTerm(2, t); diff --git a/H/Yapproto.h b/H/Yapproto.h index 2041f5541..0bb713331 100644 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -27,6 +27,8 @@ int STD_PROTO(Yap_absmiEND,(void)); Term STD_PROTO(Yap_ArrayToList,(Term *,int)); int STD_PROTO(Yap_GetName,(char *,UInt,Term)); Term STD_PROTO(Yap_GetValue,(Atom)); +int STD_PROTO(Yap_HasOp,(Atom)); +struct operator_entry *STD_PROTO(Yap_GetOpPropForAModuleHavingALock,(AtomEntry *, Term)); Atom STD_PROTO(Yap_LookupAtom,(char *)); Atom STD_PROTO(Yap_LookupMaybeWideAtom,(wchar_t *)); Atom STD_PROTO(Yap_FullLookupAtom,(char *)); diff --git a/H/Yatom.h b/H/Yatom.h index eeda5db04..69b45b06b 100644 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -480,11 +480,19 @@ IsOpProperty (int flags) return (PropFlags) ((flags == OpProperty)); } -OpEntry *STD_PROTO(Yap_GetOpProp,(Atom)); +typedef enum +{ + INFIX_OP = 0, + POSFIX_OP = 1, + PREFIX_OP = 2 +} op_type; -int STD_PROTO(Yap_IsPrefixOp,(OpEntry *,int *,int *)); -int STD_PROTO(Yap_IsInfixOp,(OpEntry *,int *,int *,int *)); -int STD_PROTO(Yap_IsPosfixOp,(OpEntry *,int *,int *)); + +OpEntry *STD_PROTO(Yap_GetOpProp,(Atom, op_type)); + +int STD_PROTO(Yap_IsPrefixOp,(Atom,int *,int *)); +int STD_PROTO(Yap_IsInfixOp,(Atom,int *,int *,int *)); +int STD_PROTO(Yap_IsPosfixOp,(Atom,int *,int *)); /* defines related to operator specifications */ #define MaskPrio 0x0fff diff --git a/packages/chr b/packages/chr index e071f01c1..f6a790076 160000 --- a/packages/chr +++ b/packages/chr @@ -1 +1 @@ -Subproject commit e071f01c1d9015e6d3fabc73092a6e902541485a +Subproject commit f6a79007615bf46dc79712c41d61289834f28ba3 diff --git a/pl/control.yap b/pl/control.yap index d7d5e3259..32e995eff 100644 --- a/pl/control.yap +++ b/pl/control.yap @@ -235,7 +235,7 @@ garbage_collect_atoms :- '$good_character_code'(X) :- var(X), !. '$good_character_code'(X) :- integer(X), X > -2, X < 256. -initialization :- +(initialization) :- '$initialisation_goals'. prolog_initialization(G) :- var(G), !, diff --git a/pl/directives.yap b/pl/directives.yap index ff6dc435e..e377c769e 100644 --- a/pl/directives.yap +++ b/pl/directives.yap @@ -106,7 +106,8 @@ '$exec_directive'(thread_local(P), _, M) :- '$thread_local'(P, M). '$exec_directive'(op(P,OPSEC,OP), _, _) :- - op(P,OPSEC,OP). + '$current_module'(M), + op(P,OPSEC,M:OP). '$exec_directive'(set_prolog_flag(F,V), _, _) :- set_prolog_flag(F,V). '$exec_directive'(ensure_loaded(Fs), _, M) :- diff --git a/pl/modules.yap b/pl/modules.yap index b255f2f38..1aa9674c2 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -534,7 +534,6 @@ source_module(Mod) :- clause(:,?,?), compile(:), consult(:), - current_op(?,?,:), current_predicate(:), current_predicate(?,:), depth_bound_call(:,+), diff --git a/pl/utils.yap b/pl/utils.yap index 7ae4d467f..409942b04 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -57,9 +57,12 @@ op(P,T,V) :- '$associativity'(fx). '$associativity'(fy). - '$check_op_name'(V,_) :- +'$check_op_name'(V,G) :- + var(V), !, + '$do_error'(instantiation_error,G). +'$check_op_name'(V,_) :- atom(V), !. - '$check_op_name'(M:A, G) :- +'$check_op_name'(M:A, G) :- ( var(M) -> '$do_error'(instantiation_error,G) @@ -67,13 +70,10 @@ op(P,T,V) :- var(A) -> '$do_error'(instantiation_error,G) ; - \+ atom(A) -> - '$do_error'(instantiation_error,G) + atom(M) -> + '$check_op_name'(A, G) ; - \+ atom(M) -> '$do_error'(instantiation_error,G) - ; - true ). '$check_op_name'([A|As], G) :- '$check_op_name'(A, G), @@ -85,27 +85,25 @@ op(P,T,V) :- '$check_op_names'(As, G). +'$op'(P, T, M:[A|As]) :- !, + '$current_module'(M), + '$opl'(P, T, M, [A|As]). '$op'(P, T, [A|As]) :- !, - '$opl'(P, T, [A|As]). + '$opl'(P, T, M, [A|As]). '$op'(P, T, A) :- '$op2'(P,T,A). -'$opl'(P, T, []). -'$opl'(P, T, [A|As]) :- - '$op2'(P, T, A), - '$opl'(P, T, As). +'$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), - prolog_load_context(module, Mod), Mod \= user, !, - '$opdec'(P,T,A,Mod). '$op2'(P,T,A) :- atom(A), !, '$opdec'(P,T,A,prolog). '$op2'(P,T,A) :- strip_module(A,M,N), - (M = user -> NM = prolog ; NM = M), - '$opdec'(P,T,N,NM). + '$opdec'(P,T,N,M). current_op(X,Y,V) :- var(V), !, '$current_module'(M),