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

support for module based operators.

This commit is contained in:
Vitor Santos Costa 2009-11-20 00:33:14 +00:00
parent a2927c4a72
commit ffe1dfdfff
11 changed files with 133 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
C/adtdefs.c
View File

@ -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;
}
}

8
C/init.c
View File

@ -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 {

41
C/parser.c
View File

@ -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;

16
C/write.c
View File

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

2
H/Yapproto.h
View File

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

16
H/Yatom.h
View File

@ -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

2
packages/chr

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

2
pl/control.yap
View File

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

3
pl/directives.yap
View File

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

1
pl/modules.yap
View File

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

34
pl/utils.yap
View File

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