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

Try to clarify operators

Browse Source 
prolog has priority and cannot be redefined by default.
user is global but may be redefined
others should just plug-in.
This commit is contained in:
Vítor Santos Costa 2016-02-26 17:18:37 +00:00
parent a448e25d8d
commit c25d35356a
6 changed files with 142 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
C/adtdefs.c
View File

@ -562,62 +562,62 @@ Yap_OpPropForModule(Atom a,
return info;
}
OpEntry *
Yap_GetOpProp(Atom a,
op_type type
USES_REGS) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
OpEntry *oinfo = NULL;
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
static OpEntry *
fetchOpWithModule( PropEntry *pp, Term tmod, op_type type )
{
while (!EndOfPAEntr(pp)) {
OpEntry *info = NULL;
if (pp->KindOfPE != OpProperty) {
pp = RepProp(pp->NextOfPE);
continue;
}
info = (OpEntry *)pp;
if (info->OpModule != CurrentModule && info->OpModule != PROLOG_MODULE) {
if (info->OpModule != tmod) {
pp = RepProp(pp->NextOfPE);
continue;
}
if (type == INFIX_OP) {
if (!info->Infix) {
pp = RepProp(pp->NextOfPE);
continue;
return NULL;
}
} else if (type == POSFIX_OP) {
if (!info->Posfix) {
pp = RepProp(pp->NextOfPE);
continue;
return NULL;
}
} else {
if (!info->Prefix) {
pp = RepProp(pp->NextOfPE);
continue;
return NULL;
}
}
/* if it is not the latest module */
if (info->OpModule == PROLOG_MODULE) {
/* cannot commit now */
oinfo = info;
pp = RepProp(pp->NextOfPE);
} else {
READ_LOCK(info->OpRWLock);
READ_UNLOCK(ae->ARWLock);
return info;
}
return info;
}
if (oinfo) {
READ_LOCK(oinfo->OpRWLock);
READ_UNLOCK(ae->ARWLock);
return oinfo;
}
READ_UNLOCK(ae->ARWLock);
return NULL;
}
OpEntry *
Yap_GetOpProp(Atom a,
op_type type,
Term tmod
USES_REGS) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
OpEntry *info;
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
if (( (info = fetchOpWithModule( pp, tmod, type )) != NULL) ||
( (info = fetchOpWithModule( pp, USER_MODULE, type )) != NULL) ||
( (info = fetchOpWithModule( pp, PROLOG_MODULE, type )) != NULL)
) {
LOCK(info->OpRWLock);
return info;
READ_UNLOCK(ae->ARWLock);
}
READ_UNLOCK(ae->ARWLock);
return NULL;
}
inline static Prop GetPredPropByAtomHavingLock(AtomEntry *ae, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */

2
C/modules.c
View File

@ -52,6 +52,7 @@ initMod( AtomEntry *toname, AtomEntry *ae) {
n->KindOfPE = ModProperty;
n->PredForME = NULL;
n->NextME = CurrentModules;
n->ParentForME = CurrentModule;
CurrentModules = n;
n->AtomOfME = ae;
n->OwnerFile = Yap_ConsultingFile( PASS_REGS1);
@ -259,7 +260,6 @@ static Int change_module(USES_REGS1) { /* $change_module(N) */
Term mod = Deref(ARG1);
LookupModule(mod);
CurrentModule = mod;
LOCAL_SourceModule = mod;
return TRUE;
}

113
C/parser.c
View File

@ -164,9 +164,9 @@ typedef struct jmp_buff_struct { sigjmp_buf JmpBuff; } JMPBUFF;
static void GNextToken(CACHE_TYPE1);
static void checkfor(wchar_t, JMPBUFF *CACHE_TYPE);
static Term ParseArgs(Atom, wchar_t, JMPBUFF *, Term CACHE_TYPE);
static Term ParseList(JMPBUFF *CACHE_TYPE);
static Term ParseTerm(int, JMPBUFF *CACHE_TYPE);
static Term ParseArgs(Atom, wchar_t, JMPBUFF *, Term, Term CACHE_TYPE);
static Term ParseList(JMPBUFF *, Term CACHE_TYPE);
static Term ParseTerm(int, JMPBUFF *, Term CACHE_TYPE);
const char *Yap_tokRep(TokEntry *tokptr);
@ -367,16 +367,12 @@ Term Yap_Variables(VarEntry *p, Term l) {
return Variables(p, l PASS_REGS);
}
static int IsPrefixOp(Atom op, int *pptr, int *rpptr USES_REGS) {
static int IsPrefixOp(Atom op, int *pptr, int *rpptr, Term tmod USES_REGS) {
int p;
OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP PASS_REGS);
OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP, tmod PASS_REGS);
if (!opp)
return FALSE;
if (opp->OpModule && opp->OpModule != CurrentModule) {
READ_UNLOCK(opp->OpRWLock);
return FALSE;
}
if ((p = opp->Prefix) != 0) {
READ_UNLOCK(opp->OpRWLock);
*pptr = *rpptr = p &MaskPrio;
@ -389,21 +385,17 @@ static int IsPrefixOp(Atom op, int *pptr, int *rpptr USES_REGS) {
}
}
int Yap_IsPrefixOp(Atom op, int *pptr, int *rpptr) {
int Yap_IsPrefixOp(Atom op, int *pptr, int *rpptr, Term tmod) {
CACHE_REGS
return IsPrefixOp(op, pptr, rpptr PASS_REGS);
return IsPrefixOp(op, pptr, rpptr, tmod PASS_REGS);
}
static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr USES_REGS) {
static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr, Term tmod USES_REGS) {
int p;
OpEntry *opp = Yap_GetOpProp(op, INFIX_OP PASS_REGS);
OpEntry *opp = Yap_GetOpProp(op, INFIX_OP, tmod PASS_REGS);
if (!opp)
return FALSE;
if (opp->OpModule && opp->OpModule != CurrentModule) {
READ_UNLOCK(opp->OpRWLock);
return FALSE;
}
if ((p = opp->Infix) != 0) {
READ_UNLOCK(opp->OpRWLock);
*pptr = *rpptr = *lpptr = p &MaskPrio;
@ -418,21 +410,17 @@ static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr USES_REGS) {
}
}
int Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr) {
int Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr, Term tmod) {
CACHE_REGS
return IsInfixOp(op, pptr, lpptr, rpptr PASS_REGS);
return IsInfixOp(op, pptr, lpptr, rpptr, tmod PASS_REGS);
}
static int IsPosfixOp(Atom op, int *pptr, int *lpptr USES_REGS) {
static int IsPosfixOp(Atom op, int *pptr, int *lpptr, Term tmod USES_REGS) {
int p;
OpEntry *opp = Yap_GetOpProp(op, POSFIX_OP PASS_REGS);
OpEntry *opp = Yap_GetOpProp(op, POSFIX_OP, tmod PASS_REGS);
if (!opp)
return FALSE;
if (opp->OpModule && opp->OpModule != CurrentModule) {
READ_UNLOCK(opp->OpRWLock);
return FALSE;
}
if ((p = opp->Posfix) != 0) {
READ_UNLOCK(opp->OpRWLock);
*pptr = *lpptr = p &MaskPrio;
@ -445,9 +433,9 @@ static int IsPosfixOp(Atom op, int *pptr, int *lpptr USES_REGS) {
}
}
int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr) {
int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr, Term tmod) {
CACHE_REGS
return IsPosfixOp(op, pptr, lpptr PASS_REGS);
return IsPosfixOp(op, pptr, lpptr, tmod PASS_REGS);
}
inline static void GNextToken(USES_REGS1) {
@ -472,9 +460,9 @@ inline static void checkfor(wchar_t c, JMPBUFF *FailBuff USES_REGS) {
#ifdef O_QUASIQUOTATIONS
static int is_quasi_quotation_syntax(Term goal, Atom *pat) {
static int is_quasi_quotation_syntax(Term goal, Term m, Atom *pat) {
CACHE_REGS
Term m = CurrentModule, t;
Term t;
Atom at;
UInt arity;
Functor f;
@ -524,8 +512,8 @@ static int get_quasi_quotation(term_t t, unsigned char **here,
}
#endif /*O_QUASIQUOTATIONS*/
static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff,
Term arg1 USES_REGS) {
static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff,
Term arg1, Term tmod USES_REGS) {
int nargs = 0;
Term *p, t;
Functor func;
@ -562,7 +550,7 @@ static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff,
syntax_msg("line %d: Trail Overflow",LOCAL_tokptr->TokPos);
FAIL;
}
*tp++ = Unsigned(ParseTerm(999, FailBuff PASS_REGS));
*tp++ = Unsigned(ParseTerm(999, FailBuff, tmod PASS_REGS));
ParserAuxSp = (char *)tp;
++nargs;
if (LOCAL_tokptr->Tok != Ord(Ponctuation_tok))
@ -617,14 +605,14 @@ static Term MakeAccessor(Term t, Functor f USES_REGS) {
return Yap_MkApplTerm(f, 2, tf);
}
static Term ParseList(JMPBUFF *FailBuff USES_REGS) {
static Term ParseList(JMPBUFF *FailBuff, Term tmod USES_REGS) {
Term o;
CELL *to_store;
o = AbsPair(HR);
loop:
to_store = HR;
HR += 2;
to_store[0] = ParseTerm(999, FailBuff PASS_REGS);
to_store[0] = ParseTerm(999, FailBuff, tmod PASS_REGS);
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok)) {
if (((int)LOCAL_tokptr->TokInfo) == ',') {
NextToken;
@ -641,7 +629,7 @@ loop:
}
} else if (((int)LOCAL_tokptr->TokInfo) == '|') {
NextToken;
to_store[1] = ParseTerm(999, FailBuff PASS_REGS);
to_store[1] = ParseTerm(999, FailBuff, tmod PASS_REGS);
} else {
to_store[1] = MkAtomTerm(AtomNil);
}
@ -653,7 +641,7 @@ loop:
return (o);
}
static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
static Term ParseTerm(int prio, JMPBUFF *FailBuff, Term tmod USES_REGS) {
/* parse term with priority prio */
Volatile Term t;
Volatile Functor func;
@ -686,7 +674,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
}
if ((LOCAL_tokptr->Tok != Ord(Ponctuation_tok) ||
Unsigned(LOCAL_tokptr->TokInfo) != 'l') &&
IsPrefixOp((Atom)t, &opprio, &oprprio PASS_REGS)) {
IsPrefixOp((Atom)t, &opprio, &oprprio, tmod PASS_REGS)) {
if (LOCAL_tokptr->Tok == Name_tok) {
Atom at = (Atom)LOCAL_tokptr->TokInfo;
#ifndef _MSC_VER
@ -721,7 +709,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos);
FAIL;
}
t = ParseTerm(oprprio, FailBuff PASS_REGS);
t = ParseTerm(oprprio, FailBuff, tmod PASS_REGS);
t = Yap_MkApplTerm(func, 1, &t);
/* check for possible overflow against local stack */
if (HR > ASP - 4096) {
@ -733,7 +721,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
}
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok) &&
Unsigned(LOCAL_tokptr->TokInfo) == 'l')
t = ParseArgs((Atom)t, ')', FailBuff, 0L PASS_REGS);
t = ParseArgs((Atom)t, ')', FailBuff, 0L, tmod PASS_REGS);
else
t = MkAtomTerm((Atom)t);
break;
@ -749,7 +737,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
// we may be operating under a syntax error
yap_error_number oerr = LOCAL_Error_TYPE;
LOCAL_Error_TYPE = YAP_NO_ERROR;
t = Yap_CharsToTDQ(p, CurrentModule, LOCAL_encoding PASS_REGS);
t = Yap_CharsToTDQ(p, tmod, LOCAL_encoding PASS_REGS);
if (!t) {
syntax_msg("line %d: could not convert \"%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo);
FAIL;
@ -764,7 +752,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
// we may be operating under a syntax error
yap_error_number oerr = LOCAL_Error_TYPE;
LOCAL_Error_TYPE = YAP_NO_ERROR;
t = Yap_WCharsToTDQ(p, CurrentModule PASS_REGS);
t = Yap_WCharsToTDQ(p, tmod PASS_REGS);
if (!t) {
syntax_msg("line %d: could not convert \'%S\'",LOCAL_tokptr->TokPos, (wchar_t *)LOCAL_tokptr->TokInfo);
FAIL;
@ -780,7 +768,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
yap_error_number oerr = LOCAL_Error_TYPE;
LOCAL_Error_TYPE = YAP_NO_ERROR;
t = Yap_CharsToTBQ(p, CurrentModule, LOCAL_encoding PASS_REGS);
t = Yap_CharsToTBQ(p, tmod, LOCAL_encoding PASS_REGS);
if (!t) {
syntax_msg("line %d: could not convert \'%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo);
FAIL;
@ -792,7 +780,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
case WBQString_tok: /* build list on the heap */
{
Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo;
t = Yap_WCharsToTBQ(p, CurrentModule PASS_REGS);
t = Yap_WCharsToTBQ(p, tmod PASS_REGS);
// we may be operating under a syntax error
yap_error_number oerr = LOCAL_Error_TYPE;
LOCAL_Error_TYPE = YAP_NO_ERROR;
@ -822,7 +810,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
case '(':
case 'l': /* non solo ( */
NextToken;
t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS);
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS);
checkfor(')', FailBuff PASS_REGS);
break;
case '[':
@ -833,7 +821,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
NextToken;
break;
}
t = ParseList(FailBuff PASS_REGS);
t = ParseList(FailBuff, tmod PASS_REGS);
checkfor(']', FailBuff PASS_REGS);
break;
case '{':
@ -844,7 +832,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
NextToken;
break;
}
t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS);
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS);
t = Yap_MkApplTerm(FunctorBraces, 1, &t);
/* check for possible overflow against local stack */
if (HR > ASP - 4096) {
@ -896,7 +884,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
}
NextToken;
t = ParseTerm(GLOBAL_MaxPriority, FailBuff PASS_REGS);
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, tmod PASS_REGS);
if (LOCAL_tokptr->Tok != QuasiQuotes_tok) {
syntax_msg("expected to find quasi quotes, got \"%s\"", ,
Yap_tokRep(LOCAL_tokptr));
@ -954,7 +942,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
if (LOCAL_tokptr->Tok == Ord(Name_tok) &&
Yap_HasOp((Atom)(LOCAL_tokptr->TokInfo))) {
Atom save_opinfo = opinfo = (Atom)(LOCAL_tokptr->TokInfo);
if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio PASS_REGS) &&
if (IsInfixOp(save_opinfo, &opprio, &oplprio, &oprprio, tmod PASS_REGS) &&
opprio <= prio && oplprio >= curprio) {
/* try parsing as infix operator */
Volatile int oldprio = curprio;
@ -967,7 +955,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
{
Term args[2];
args[0] = t;
args[1] = ParseTerm(oprprio, FailBuff PASS_REGS);
args[1] = ParseTerm(oprprio, FailBuff, tmod PASS_REGS);
t = Yap_MkApplTerm(func, 2, args);
/* check for possible overflow against local stack */
if (HR > ASP - 4096) {
@ -979,7 +967,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
opinfo = save_opinfo; continue;, opinfo = save_opinfo;
curprio = oldprio;)
}
if (IsPosfixOp(opinfo, &opprio, &oplprio PASS_REGS) && opprio <= prio &&
if (IsPosfixOp(opinfo, &opprio, &oplprio , tmod PASS_REGS) && opprio <= prio &&
oplprio >= curprio) {
/* parse as posfix operator */
Functor func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 1);
@ -1005,7 +993,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
Volatile Term args[2];
NextToken;
args[0] = t;
args[1] = ParseTerm(1000, FailBuff PASS_REGS);
args[1] = ParseTerm(1000, FailBuff, tmod PASS_REGS);
t = Yap_MkApplTerm(FunctorComma, 2, args);
/* check for possible overflow against local stack */
if (HR > ASP - 4096) {
@ -1015,12 +1003,12 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
curprio = 1000;
continue;
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '|' &&
IsInfixOp(AtomVBar, &opprio, &oplprio, &oprprio PASS_REGS) &&
IsInfixOp(AtomVBar, &opprio, &oplprio, &oprprio, tmod PASS_REGS) &&
opprio <= prio && oplprio >= curprio) {
Volatile Term args[2];
NextToken;
args[0] = t;
args[1] = ParseTerm(oprprio, FailBuff PASS_REGS);
args[1] = ParseTerm(oprprio, FailBuff, tmod PASS_REGS);
t = Yap_MkApplTerm(FunctorVBar, 2, args);
/* check for possible overflow against local stack */
if (HR > ASP - 4096) {
@ -1030,24 +1018,24 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
curprio = opprio;
continue;
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '(' &&
IsPosfixOp(AtomEmptyBrackets, &opprio, &oplprio PASS_REGS) &&
IsPosfixOp(AtomEmptyBrackets, &opprio, &oplprio, tmod PASS_REGS) &&
opprio <= prio && oplprio >= curprio) {
t = ParseArgs(AtomEmptyBrackets, ')', FailBuff, t PASS_REGS);
t = ParseArgs(AtomEmptyBrackets, ')', FailBuff, t, tmod PASS_REGS);
curprio = opprio;
continue;
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '[' &&
IsPosfixOp(AtomEmptySquareBrackets, &opprio,
&oplprio PASS_REGS) &&
&oplprio, tmod PASS_REGS) &&
opprio <= prio && oplprio >= curprio) {
t = ParseArgs(AtomEmptySquareBrackets, ']', FailBuff, t PASS_REGS);
t = ParseArgs(AtomEmptySquareBrackets, ']', FailBuff, t, tmod PASS_REGS);
t = MakeAccessor(t, FunctorEmptySquareBrackets PASS_REGS);
curprio = opprio;
continue;
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '{' &&
IsPosfixOp(AtomEmptyCurlyBrackets, &opprio,
&oplprio PASS_REGS) &&
&oplprio, tmod PASS_REGS) &&
opprio <= prio && oplprio >= curprio) {
t = ParseArgs(AtomEmptyCurlyBrackets, '}', FailBuff, t PASS_REGS);
t = ParseArgs(AtomEmptyCurlyBrackets, '}', FailBuff, t, tmod PASS_REGS);
t = MakeAccessor(t, FunctorEmptyCurlyBrackets PASS_REGS);
curprio = opprio;
continue;
@ -1062,7 +1050,7 @@ static Term ParseTerm(int prio, JMPBUFF *FailBuff USES_REGS) {
return t;
}
Term Yap_Parse(UInt prio) {
Term Yap_Parse(UInt prio, Term tmod) {
CACHE_REGS
Volatile Term t;
JMPBUFF FailBuff;
@ -1070,7 +1058,7 @@ Term Yap_Parse(UInt prio) {
if (!sigsetjmp(FailBuff.JmpBuff, 0)) {
t = ParseTerm(prio, &FailBuff PASS_REGS);
t = ParseTerm(prio, &FailBuff, tmod PASS_REGS);
#if DEBUG
if (GLOBAL_Option['p' - 'a' + 1]) {
Yap_DebugPutc(stderr, '[');
@ -1083,7 +1071,8 @@ Term Yap_Parse(UInt prio) {
}
#endif
Yap_CloseSlots(sls);
if (LOCAL_tokptr != NULL && LOCAL_tokptr->Tok != Ord(eot_tok)) {
if (LOCAL_Error_TYPE == YAP_NO_ERROR &&
LOCAL_tokptr != NULL && LOCAL_tokptr->Tok != Ord(eot_tok)) {
LOCAL_Error_TYPE = SYNTAX_ERROR;
LOCAL_ErrorMessage = "term does not end on . ";
t = 0;

20
C/stdpreds.c
View File

@ -984,24 +984,27 @@ int Yap_IsOpMaxPrio(Atom at) {
return max;
}
static Int unify_op(OpEntry *op USES_REGS) {
static bool unify_op(OpEntry *op, Term emod USES_REGS) {
Term tmod = op->OpModule;
if (tmod == PROLOG_MODULE)
tmod = TermProlog;
return Yap_unify_constant(ARG2, tmod) &&
Yap_unify_constant(ARG3, MkIntegerTerm(op->Prefix)) &&
if (tmod != PROLOG_MODULE &&
tmod != USER_MODULE &&
tmod != emod &&
(op->Prefix || op->Infix || op->Posfix))
return false;
return 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(USES_REGS1) {
OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5, 1)), *next;
Term emod = Deref(ARG2);
READ_LOCK(op->OpRWLock);
next = op->OpNext;
if (Yap_unify_constant(ARG1, MkAtomTerm(op->OpName)) &&
unify_op(op PASS_REGS)) {
unify_op(op, emod PASS_REGS)) {
READ_UNLOCK(op->OpRWLock);
if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next);
@ -1014,7 +1017,6 @@ static Int cont_current_op(USES_REGS1) {
READ_UNLOCK(op->OpRWLock);
if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next);
B->cp_h = HR;
return FALSE;
} else {
cut_fail();
@ -1034,7 +1036,7 @@ static Int cont_current_atom_op(USES_REGS1) {
READ_LOCK(op->OpRWLock);
next = NextOp(RepOpProp(op->NextOfPE) PASS_REGS);
if (unify_op(op PASS_REGS)) {
if (unify_op(op, CurrentModule PASS_REGS)) {
READ_UNLOCK(op->OpRWLock);
if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next);

6
C/write.c
View File

@ -1007,7 +1007,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
return;
}
}
if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) {
if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp, CurrentModule)) {
Term tright = ArgOfTerm(1, t);
int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) &&
Yap_IsOp(AtomOfTerm(tright));
@ -1035,7 +1035,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
((atom == AtomEmptyBrackets || atom == AtomEmptyCurlyBrackets ||
atom == AtomEmptySquareBrackets) &&
Yap_IsListTerm(ArgOfTerm(1, t)))) &&
Yap_IsPosfixOp(atom, &op, &lp)) {
Yap_IsPosfixOp(atom, &op, &lp, CurrentModule)) {
Term tleft = ArgOfTerm(1, t);
int bracket_left, offset;
@ -1087,7 +1087,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
wrclose_bracket(wglb, TRUE);
}
} else if (!wglb->Ignore_ops && Arity == 2 &&
Yap_IsInfixOp(atom, &op, &lp, &rp)) {
Yap_IsInfixOp(atom, &op, &lp, &rp, CurrentModule)) {
Term tleft = ArgOfTerm(1, t);
Term tright = ArgOfTerm(2, t);
int bracket_left =

151
pl/utils.yap
View File

@ -48,37 +48,45 @@ a postfix operator.
*/
op(P,T,V) :-
'$check_op'(P,T,V,op(P,T,V)),
'$op'(P, T, V).
'$yap_strip_module'(V, M, N),
'$check_top_op'(P,T,N,M,op(P,T,V)).
% just check the operator declarations for correctness.
'$check_op'(P,T,Op,G) :-
'$check_top_op'(P,T,Op,_M,G) :-
( var(P) ; var(T); var(Op)), !,
'$do_error'(instantiation_error,G).
'$check_op'(P,_,_,G) :-
'$check_top_op'(P,_,_,_,G) :-
\+ integer(P), !,
'$do_error'(type_error(integer,P),G).
'$check_op'(P,_,_,G) :-
'$check_top_op'(P,_,_,_,G) :-
P < 0, !,
'$do_error'(domain_error(operator_priority,P),G).
'$check_op'(_,T,_,G) :-
'$check_top_op'(_,T,_,_,G) :-
\+ atom(T), !,
'$do_error'(type_error(atom,T),G).
'$check_op'(_,T,_,G) :-
'$check_top_op'(_,T,_,_,G) :-
\+ '$associativity'(T), !,
'$do_error'(domain_error(operator_specifier,T),G).
'$check_op'(P,T,V,G) :-
'$check_module_for_op'(V, G, NV),
'$check_top_op'(P, T, NV, G).
'$check_top_op'(_, _, [], _) :- !.
'$check_top_op'(P, T, [Op|NV], G) :- !,
'$check_ops'(P, T, Op.NV, G).
'$check_top_op'(P, T, V, G) :-
atom(V), !,
'$check_op_name'(P, T, V, G).
'$check_top_op'(_P, _T, V, G) :-
'$do_error'(type_error(atom,V),G).
'$check_top_op'(P, T, M:Op, _M, G) :- !,
'$vsc_strip_module'(M:Op, M1, Op1),
(
atom(M1)
->
'$check_top_op'(P, T, Op1, M1, G)
;
'$do_error'(type_error(atom,Op),G)
).
'$check_top_op'(P, T, [Op|NV], M, G) :- !,
'$check_top_op'(P, T, Op, M, G),
(NV = []
->
true
;
'$check_top_op'(P, T, NV, M, G)
).
'$check_top_op'(P, T, V, M, G) :-
'$check_op_name'(P, T, V, M, G),
'$opdec'(P, T, V, M).
'$associativity'(xfx).
'$associativity'(xfy).
@ -89,43 +97,16 @@ a postfix operator.
'$associativity'(fx).
'$associativity'(fy).
'$check_module_for_op'(MOp, G, _) :-
var(MOp), !,
'$do_error'(instantiation_error,G).
'$check_module_for_op'(M:_V, G, _) :-
var(M), !,
'$do_error'(instantiation_error,G).
'$check_module_for_op'(M:V, G, NV) :-
atom(M), !,
'$check_module_for_op'(V, G, NV).
'$check_module_for_op'(M:_V, G, _) :- !,
'$do_error'(type_error(atom,M),G).
'$check_module_for_op'(V, _G, V).
'$check_ops'(_P, _T, [], _G) :- !.
'$check_ops'(P, T, [Op|NV], G) :- !,
(
var(NV)
->
'$do_error'(instantiation_error,G)
;
'$check_module_for_op'(Op, G, NOp),
'$check_op_name'(P, T, NOp, G),
'$check_ops'(P, T, NV, G)
).
'$check_ops'(_P, _T, Ops, G) :-
'$do_error'(type_error(list,Ops),G).
'$check_op_name'(_,_,V,G) :-
'$check_op_name'(_,_,V,_,G) :-
var(V), !,
'$do_error'(instantiation_error,G).
'$check_op_name'(_,_,',',G) :- !,
'$check_op_name'(_,_,',',_,G) :- !,
'$do_error'(permission_error(modify,operator,','),G).
'$check_op_name'(_,_,'[]',G) :- T \= yf, T\= xf, !,
'$check_op_name'(_,_,'[]',_,G) :- T \= yf, T\= xf, !,
'$do_error'(permission_error(create,operator,'[]'),G).
'$check_op_name'(_,_,'{}',G) :- T \= yf, T\= xf, !,
'$check_op_name'(_,_,'{}',_,G) :- T \= yf, T\= xf, !,
'$do_error'(permission_error(create,operator,'{}'),G).
'$check_op_name'(P,T,'|',G) :-
'$check_op_name'(P,T,'|',_,G) :-
(
integer(P),
P < 1001, P > 0
@ -133,77 +114,31 @@ a postfix operator.
atom_codes(T,[_,_])
), !,
'$do_error'(permission_error(create,operator,'|'),G).
'$check_op_name'(_,_,V,_) :-
atom(V), !.
'$check_op_name'(_,_,A,G) :-
'$check_op_name'(P,T,A,M,_G) :-
atom(A), !,
'$opdec'( P, T, A, M).
'$check_op_name'(_,_,A,_,G) :-
'$do_error'(type_error(atom,A),G).
'$op'(P, T, ML) :-
strip_module(ML, M, [A|As]), !,
'$opl'(P, T, M, [A|As]).
'$op'(P, T, A) :-
'$op2'(P,T,A).
'$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), !,
'$opdec'(P,T,A,prolog).
'$op2'(P,T,A) :-
strip_module(A,M,N),
'$opdec'(P,T,N,M).
/** @pred current_op( _P_, _T_, _F_) is iso
Defines the relation: _P_ is a currently defined operator of type
_T_ and precedence _P_.
b*c _T_ and precedence _P_. Returns only operators defined in current module.
*/
current_op(X,Y,V) :- var(V), !,
'$current_module'(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) :-
'$current_module'(M),
'$do_current_op'(X,Y,Z,M).
current_op(X,Y,V) :-
'$yap_strip_module'(V,M,O),
'$do_current_op'(X, Y, O, M).
'$current_opm'(X,Y,Z,M) :-
nonvar(Y),
\+ '$associativity'(Y),
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
'$current_opm'(X,Y,Z,M) :-
var(Z), !,
'$do_current_op'(X,Y,Z,M).
'$current_opm'(X,Y,M:Z,_) :- !,
'$current_opm'(X,Y,Z,M).
'$current_opm'(X,Y,Z,M) :-
'$do_current_op'(X,Y,Z,M).
'$do_current_op'(X,Y,Z,M) :-
'$do_current_op'(X,Y,Z, M) :-
nonvar(Y),
\+ '$associativity'(Y),
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
'$do_current_op'(X,Y,Z,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 ),
'$current_op'(Z, M, Prefix, Infix, Posfix),
(
'$get_prefix'(Prefix, X, Y)
;