fix current_op/3 by walking over the chain of ops or properties and moving complex code to Prolog (obs from Paulo Moura).

C/stdpreds.c

@@ -313,6 +313,8 @@ STD_PROTO(static Int cont_current_predicate_for_atom, (void));
 STD_PROTO(static OpEntry *NextOp, (OpEntry *));
 STD_PROTO(static Int init_current_op, (void));
 STD_PROTO(static Int cont_current_op, (void));
+STD_PROTO(static Int init_current_atom_op, (void));
+STD_PROTO(static Int cont_current_atom_op, (void));
 #ifdef DEBUG
 STD_PROTO(static Int p_debug, (void));
 #endif
@@ -2872,147 +2874,95 @@ NextOp(OpEntry *pp)
   return (pp);
 }
 
+static Int
+unify_op(OpEntry         *op)
+{
+  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));
+}
 
 static Int 
 cont_current_op(void)
 {
-  int             prio;
+  OpEntry         *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5,1)), *next;
-  Atom            a = AtomOfTerm(EXTRA_CBACK_ARG(4,1));
+  
-  Int             fix = IntOfTerm(EXTRA_CBACK_ARG(4,3));
+  READ_LOCK(op->OpRWLock);
-  Term            TType;
+  next = op->OpNext;
-  Term            tmod;
+  if (Yap_unify_constant(ARG1,MkAtomTerm(op->OpName)) &&
-  OpEntry        *pp = NIL;
+      unify_op(op)) {
-    /* fix hp gcc bug */
+    if (next) {
-  AtomEntry *at = RepAtom(a);
+      EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
-
+      return TRUE;
-  if (fix > 3) {
+    } else {
-    /* starting from an atom */
-    a = AtomOfTerm(Deref(ARG3));
-    READ_LOCK(RepAtom(a)->ARWLock);
-    if (EndOfPAEntr(pp = NextOp(RepOpProp(RepAtom(a)->PropsOfAE)))) {
-      READ_UNLOCK(RepAtom(a)->ARWLock);
-      cut_fail();
-    }
-    READ_LOCK(pp->OpRWLock);
-    READ_UNLOCK(RepAtom(a)->ARWLock);
-    if (fix == 4 && pp->Prefix == 0)
-      fix = 5;
-    if (fix == 5 && pp->Posfix == 0)
-      fix = 6;
-    if (fix == 6 && pp->Infix == 0)
-      cut_fail();
-    TType = MkAtomTerm(Yap_GetOp(pp, &prio, (int) (fix - 4)));
-    fix++;
-    if (fix == 5 && pp->Posfix == 0)
-      fix = 6;
-    if (fix == 6 && pp->Infix == 0)
-      fix = 7;
-    if (pp->OpModule == PROLOG_MODULE)
-      tmod = TermProlog;
-    else
-      tmod = pp->OpModule; 
-    READ_UNLOCK(pp->OpRWLock);
-    EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(fix);
-    if (fix < 7)
-      return (Yap_unify_constant(ARG1, MkIntTerm(prio))
-	      && Yap_unify_constant(ARG2, TType)
-	      && Yap_unify_constant(ARG4, tmod));
-    if (Yap_unify_constant(ARG1, MkIntTerm(prio))
-	&& Yap_unify_constant(ARG2, TType)
-	&& Yap_unify_constant(ARG4, tmod))
       cut_succeed();
-    else
+    }
-      cut_fail();
+  } else {
-  }
+    if (next) {
-  pp = NextOp(RepOpProp(at->PropsOfAE));
+      EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
-  if (fix == 3) {
+      return FALSE;
-    if (pp->OpNext) {
-      pp = pp->OpNext;
     } else {
       cut_fail();
     }
-    fix = 0;
-    EXTRA_CBACK_ARG(4,1) = (CELL) MkAtomTerm(at=RepAtom(a=pp->OpName));
   }
-  READ_LOCK(pp->OpRWLock);
-  if (fix == 0 && pp->Prefix == 0)
-    fix = 1;
-  if (fix == 1 && pp->Posfix == 0)
-    fix = 2;
-  TType = MkAtomTerm(Yap_GetOp(pp, &prio, (int) fix));
-  fix++;
-  if (fix == 1 && pp->Posfix == 0)
-    fix = 2;
-  if (fix == 2 && pp->Infix == 0)
-    fix = 3;
-    if (pp->OpModule == PROLOG_MODULE)
-      tmod = TermProlog;
-    else
-      tmod = pp->OpModule;
-  READ_UNLOCK(pp->OpRWLock);
-  EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(fix);
-  return  (Yap_unify_constant(ARG1, MkIntTerm(prio)) &&
-	  Yap_unify_constant(ARG2, TType) &&
-	  Yap_unify_constant(ARG3, MkAtomTerm(a)) &&
-	  Yap_unify_constant(ARG4, tmod));
 }
 
 static Int 
 init_current_op(void)
 {				/* current_op(-Precedence,-Type,-Atom)		 */
-  Int             i = 0;
+  EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)OpList);
-  Atom            a;
-  Term            tprio = Deref(ARG1);
-  Term            topsec = Deref(ARG2);
-  Term            top = Deref(ARG3);
-
-  if (!IsVarTerm(tprio)) {
-    Int prio;
-    if (!IsIntTerm(tprio)) {
-      Yap_Error(DOMAIN_ERROR_OPERATOR_PRIORITY,tprio,"current_op/3");
-      return(FALSE);
-    }
-    prio = IntOfTerm(tprio);
-    if (prio < 1 || prio > 1200) {
-      Yap_Error(DOMAIN_ERROR_OPERATOR_PRIORITY,tprio,"current_op/3");
-      return(FALSE);
-    }
-  }
-  if (!IsVarTerm(topsec)) {
-    char *opsec;
-    if (!IsAtomTerm(topsec)) {
-      Yap_Error(DOMAIN_ERROR_OPERATOR_SPECIFIER,topsec,"current_op/3");
-      return(FALSE);
-    }
-    opsec = RepAtom(AtomOfTerm(topsec))->StrOfAE;
-    if (!Yap_IsOpType(opsec)) {
-      Yap_Error(DOMAIN_ERROR_OPERATOR_SPECIFIER,topsec,"current_op/3");
-      return(FALSE);
-    }
-  }
-  if (!IsVarTerm(top)) {
-    if (!IsAtomTerm(top)) {
-      Yap_Error(TYPE_ERROR_ATOM,top,"current_op/3");
-      return(FALSE);
-    }
-    a = AtomOfTerm(top);
-  } else {
-    if (OpList)
-      a = OpList->OpName;
-    else
-      cut_fail();
-  }
-  EXTRA_CBACK_ARG(4,1) = (CELL) MkAtomTerm(a);
-  EXTRA_CBACK_ARG(4,2) = (CELL) MkIntTerm(i);
-  if (IsVarTerm(top))
-    EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(0);
-  else if (IsAtomTerm(top))
-    EXTRA_CBACK_ARG(4,3) = (CELL) MkIntTerm(4);
-  else
-    cut_fail();
   return cont_current_op();
 }
 
+static Int 
+cont_current_atom_op(void)
+{
+  OpEntry         *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5,1)), *next;
+  
+  READ_LOCK(op->OpRWLock);
+  next = NextOp(RepOpProp(op->NextOfPE));
+  if (unify_op(op)) {
+    if (next) {
+      EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
+      return TRUE;
+    } else {
+      cut_succeed();
+    }
+  } else {
+    if (next) {
+      EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
+      return FALSE;
+    } else {
+      cut_fail();
+    }
+  }
+}
+
+static Int 
+init_current_atom_op(void)
+{				/* 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");
+    cut_fail();
+  }
+  ae = RepAtom(AtomOfTerm(t));
+  if (EndOfPAEntr((ope = NextOp(RepOpProp(ae->PropsOfAE))))) {
+    cut_fail();
+  }
+  EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((Int)ope);
+  return cont_current_atom_op();
+}
+
 #ifdef DEBUG
 static Int 
 p_debug()
@@ -3952,7 +3902,9 @@ Yap_InitBackCPreds(void)
 		SafePredFlag|SyncPredFlag|HiddenPredFlag);
   Yap_InitCPredBack("$current_predicate_for_atom", 3, 1, init_current_predicate_for_atom, cont_current_predicate_for_atom,
 		SafePredFlag|SyncPredFlag|HiddenPredFlag);
-  Yap_InitCPredBack("$current_op", 4, 3, init_current_op, cont_current_op,
+  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);
 #ifdef BEAM
   Yap_InitCPredBack("eam", 1, 0, start_eam, cont_eam,

pl/utils.yap

@@ -107,8 +107,7 @@ op(P,T,V) :-
 
 current_op(X,Y,V) :- var(V), !,
 	'$current_module'(M),
-	V = M:Z,
+	'$do_current_op'(X,Y,V,M).
-	'$do_current_op'(X,Y,Z,M).
 current_op(X,Y,M:Z) :- !,
 	'$current_opm'(X,Y,Z,M).
 current_op(X,Y,Z) :-
@@ -125,8 +124,64 @@ current_op(X,Y,Z) :-
 	'$do_current_op'(X,Y,Z,M).
 
 '$do_current_op'(X,Y,Z,M) :-
-	'$current_op'(X,Y,Z,M1),
+	atom(Z), !,
-	( M1 = prolog -> true ; M1 = M ).
+	'$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 ),
+	(
+	 '$get_prefix'(Prefix, X, Y)
+	;
+	 '$get_infix'(Infix, X, Y)
+	;
+	 '$get_posfix'(Posfix, X, Y)
+	).
+
+'$get_prefix'(Prefix, X, Y) :-
+	Prefix > 0,
+	X is Prefix /\ 0xfff,
+	(
+         0x2000 /\ Prefix =:= 0x2000
+        ->
+         Y = fx
+        ;
+         Y = fy
+        ).
+
+'$get_infix'(Infix, X, Y) :-
+	Infix > 0,
+	X is Infix  /\ 0xfff,
+	(
+         0x3000 /\ Infix =:= 0x3000
+        ->
+         Y = xfx
+	;
+         0x1000 /\ Infix =:= 0x1000
+        ->
+         Y = xfy
+        ;
+         Y = yfx
+        ).
+
+'$get_posfix'(Posfix, X, Y) :-
+	Posfix > 0,
+	X is Posfix /\ 0xfff,
+	(
+         0x1000 /\ Posfix =:= 0x1000
+        ->
+         Y = xf
+	;
+         Y = yf
+        ).
+
 
 %%% Operating System utilities