support for module based operators.

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 ||
+	 ( pp->KindOfPE != OpProperty))
-	   (((OpEntry *)pp)->OpModule &&
-	    ((OpEntry *)pp)->OpModule != CurrentModule)))
     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
+  } else {
-    return (OpEntry *)pp;
+    READ_LOCK(info->OpRWLock);
+    READ_UNLOCK(ae->ARWLock);
+    return info;
+  }
 }
 
 

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 {

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((Atom)t, &opprio, &oprprio)
-	&& IsPrefixOp(opinfo, &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)))) {
+	&& Yap_HasOp((Atom)(Yap_tokptr->TokInfo))) {
-      OpEntry *save_opinfo = opinfo;
+      Atom save_opinfo = opinfo = (Atom)(Yap_tokptr->TokInfo);
-      if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio) 
+      if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio) 
 	  && opprio <= prio && oplprio >= curprio) {
 	/* try parsing as infix operator */
 	Volatile int oldprio = curprio;

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 Yap_IsPrefixOp(at, &op, &rp);
-  return(opinfo && Yap_IsPrefixOp(opinfo, &op, &rp) );
 }
 
 static int RightOpToProtect(Atom at, int p)
 {
   int op, lp;
-  OpEntry            *opinfo = Yap_GetOpProp(at);
+  return Yap_IsPosfixOp(at, &op, &lp);
-  return(opinfo && Yap_IsPosfixOp(opinfo, &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,
+	Arity == 1 &&  Yap_IsPrefixOp(atom, &op, &rp)
-					   &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);

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

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 *));
+OpEntry   *STD_PROTO(Yap_GetOpProp,(Atom, op_type));
-int	STD_PROTO(Yap_IsPosfixOp,(OpEntry *,int *,int *));
+
+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

packages/chr

@@ -1 +1 @@
-Subproject commit e071f01c1d9015e6d3fabc73092a6e902541485a
+Subproject commit f6a79007615bf46dc79712c41d61289834f28ba3

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

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

pl/modules.yap

@@ -534,7 +534,6 @@ source_module(Mod) :-
 	clause(:,?,?),
 	compile(:),
 	consult(:),
-	current_op(?,?,:),
 	current_predicate(:),
 	current_predicate(?,:),
 	depth_bound_call(:,+),

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) ->
+	  atom(M) ->
-	 '$do_error'(instantiation_error,G)
+	  '$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, _, []).
-'$opl'(P, T, [A|As]) :-
+'$opl'(P, T, M, [A|As]) :-
-	'$op2'(P, T, A),
+	'$op2'(P, T, M:A),
-	'$opl'(P, T, As).
+	'$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,M).
-	'$opdec'(P,T,N,NM).
 
 current_op(X,Y,V) :- var(V), !,
 	'$current_module'(M),