diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Vitor Santos Costa 2009-11-25 00:38:47 +00:00
parent ccaab728af
commit 50d720a9c6
2 changed files with 136 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

202
C/stdpreds.c
View File

@ -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;
Atom a = AtomOfTerm(EXTRA_CBACK_ARG(4,1));
Int fix = IntOfTerm(EXTRA_CBACK_ARG(4,3));
Term TType;
Term tmod;
OpEntry *pp = NIL;
/* fix hp gcc bug */
AtomEntry *at = RepAtom(a);
if (fix > 3) {
/* 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))
OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5,1)), *next;
READ_LOCK(op->OpRWLock);
next = op->OpNext;
if (Yap_unify_constant(ARG1,MkAtomTerm(op->OpName)) &&
unify_op(op)) {
if (next) {
EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
return TRUE;
} else {
cut_succeed();
else
cut_fail();
}
pp = NextOp(RepOpProp(at->PropsOfAE));
if (fix == 3) {
if (pp->OpNext) {
pp = pp->OpNext;
}
} else {
if (next) {
EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)next);
return FALSE;
} 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;
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();
EXTRA_CBACK_ARG(5,1) = (CELL) MkIntegerTerm((CELL)OpList);
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,

63
pl/utils.yap
View File

@ -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,Z,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) :-
@ -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),
( M1 = prolog -> true ; M1 = 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 ),
(
'$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