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

58
C/adtdefs.c
View File

@ -562,60 +562,60 @@ Yap_OpPropForModule(Atom a,
return info; return info;
} }
OpEntry * static OpEntry *
Yap_GetOpProp(Atom a, fetchOpWithModule( PropEntry *pp, Term tmod, op_type type )
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);
while (!EndOfPAEntr(pp)) { while (!EndOfPAEntr(pp)) {
OpEntry *info = NULL; OpEntry *info = NULL;
if (pp->KindOfPE != OpProperty) { if (pp->KindOfPE != OpProperty) {
pp = RepProp(pp->NextOfPE); pp = RepProp(pp->NextOfPE);
continue; continue;
} }
info = (OpEntry *)pp; info = (OpEntry *)pp;
if (info->OpModule != CurrentModule && info->OpModule != PROLOG_MODULE) { if (info->OpModule != tmod) {
pp = RepProp(pp->NextOfPE); pp = RepProp(pp->NextOfPE);
continue; continue;
} }
if (type == INFIX_OP) { if (type == INFIX_OP) {
if (!info->Infix) { if (!info->Infix) {
pp = RepProp(pp->NextOfPE); return NULL;
continue;
} }
} else if (type == POSFIX_OP) { } else if (type == POSFIX_OP) {
if (!info->Posfix) { if (!info->Posfix) {
pp = RepProp(pp->NextOfPE); return NULL;
continue;
} }
} else { } else {
if (!info->Prefix) { if (!info->Prefix) {
pp = RepProp(pp->NextOfPE); return NULL;
continue;
} }
} }
/* 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;
} }
} return NULL;
if (oinfo) { }
READ_LOCK(oinfo->OpRWLock);
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 oinfo;
} }
READ_UNLOCK(ae->ARWLock); READ_UNLOCK(ae->ARWLock);
return NULL; return NULL;
} }

2
C/modules.c
View File

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

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

18
C/stdpreds.c
View File

@ -984,24 +984,27 @@ int Yap_IsOpMaxPrio(Atom at) {
return max; return max;
} }
static Int unify_op(OpEntry *op USES_REGS) { static bool unify_op(OpEntry *op, Term emod USES_REGS) {
Term tmod = op->OpModule; Term tmod = op->OpModule;
if (tmod == PROLOG_MODULE) if (tmod != PROLOG_MODULE &&
tmod = TermProlog; tmod != USER_MODULE &&
return Yap_unify_constant(ARG2, tmod) && tmod != emod &&
Yap_unify_constant(ARG3, MkIntegerTerm(op->Prefix)) && (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(ARG4, MkIntegerTerm(op->Infix)) &&
Yap_unify_constant(ARG5, MkIntegerTerm(op->Posfix)); Yap_unify_constant(ARG5, MkIntegerTerm(op->Posfix));
} }
static Int cont_current_op(USES_REGS1) { static Int cont_current_op(USES_REGS1) {
OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5, 1)), *next; OpEntry *op = (OpEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(5, 1)), *next;
Term emod = Deref(ARG2);
READ_LOCK(op->OpRWLock); READ_LOCK(op->OpRWLock);
next = op->OpNext; next = op->OpNext;
if (Yap_unify_constant(ARG1, MkAtomTerm(op->OpName)) && if (Yap_unify_constant(ARG1, MkAtomTerm(op->OpName)) &&
unify_op(op PASS_REGS)) { unify_op(op, emod PASS_REGS)) {
READ_UNLOCK(op->OpRWLock); READ_UNLOCK(op->OpRWLock);
if (next) { if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)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); READ_UNLOCK(op->OpRWLock);
if (next) { if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next); EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)next);
B->cp_h = HR;
return FALSE; return FALSE;
} else { } else {
cut_fail(); cut_fail();
@ -1034,7 +1036,7 @@ static Int cont_current_atom_op(USES_REGS1) {
READ_LOCK(op->OpRWLock); READ_LOCK(op->OpRWLock);
next = NextOp(RepOpProp(op->NextOfPE) PASS_REGS); next = NextOp(RepOpProp(op->NextOfPE) PASS_REGS);
if (unify_op(op PASS_REGS)) { if (unify_op(op, CurrentModule PASS_REGS)) {
READ_UNLOCK(op->OpRWLock); READ_UNLOCK(op->OpRWLock);
if (next) { if (next) {
EXTRA_CBACK_ARG(5, 1) = (CELL)MkIntegerTerm((CELL)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; 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); Term tright = ArgOfTerm(1, t);
int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) && int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) &&
Yap_IsOp(AtomOfTerm(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 == AtomEmptyBrackets || atom == AtomEmptyCurlyBrackets ||
atom == AtomEmptySquareBrackets) && atom == AtomEmptySquareBrackets) &&
Yap_IsListTerm(ArgOfTerm(1, t)))) && Yap_IsListTerm(ArgOfTerm(1, t)))) &&
Yap_IsPosfixOp(atom, &op, &lp)) { Yap_IsPosfixOp(atom, &op, &lp, CurrentModule)) {
Term tleft = ArgOfTerm(1, t); Term tleft = ArgOfTerm(1, t);
int bracket_left, offset; int bracket_left, offset;
@ -1087,7 +1087,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
wrclose_bracket(wglb, TRUE); wrclose_bracket(wglb, TRUE);
} }
} else if (!wglb->Ignore_ops && Arity == 2 && } 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 tleft = ArgOfTerm(1, t);
Term tright = ArgOfTerm(2, t); Term tright = ArgOfTerm(2, t);
int bracket_left = int bracket_left =

149
pl/utils.yap
View File

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