1105 lines
33 KiB
C
Executable File
1105 lines
33 KiB
C
Executable File
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: parser.c *
|
|
* Last rev: *
|
|
* mods: *
|
|
* comments: Prolog's parser *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
#endif
|
|
|
|
/**
|
|
|
|
@defgroup YAPSyntax YAP Syntax
|
|
@ingroup YAPProgramming
|
|
@{
|
|
|
|
We will describe the syntax of YAP at two levels. We first will
|
|
describe the syntax for Prolog terms. In a second level we describe
|
|
the \a tokens from which Prolog \a terms are
|
|
built.
|
|
|
|
@defgroup Formal_Syntax Syntax of Terms
|
|
@ingroup Syntax
|
|
@{
|
|
|
|
Below, we describe the syntax of YAP terms from the different
|
|
classes of tokens defined above. The formalism used will be <em>BNF</em>,
|
|
extended where necessary with attributes denoting integer precedence or
|
|
operator type.
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
term
|
|
----> subterm(1200) end_of_term_marker
|
|
|
|
subterm(N) ----> term(M) [M <= N]
|
|
|
|
term(N) ----> op(N, fx) subterm(N-1)
|
|
| op(N, fy) subterm(N)
|
|
| subterm(N-1) op(N, xfx) subterm(N-1)
|
|
| subterm(N-1) op(N, xfy) subterm(N)
|
|
| subterm(N) op(N, yfx) subterm(N-1)
|
|
| subterm(N-1) op(N, xf)
|
|
| subterm(N) op(N, yf)
|
|
|
|
term(0) ----> atom '(' arguments ')'
|
|
| '(' subterm(1200) ')'
|
|
| '{' subterm(1200) '}'
|
|
| list
|
|
| string
|
|
| number
|
|
| atom
|
|
| variable
|
|
|
|
arguments ----> subterm(999)
|
|
| subterm(999) ',' arguments
|
|
|
|
list ----> '[]'
|
|
| '[' list_expr ']'
|
|
|
|
list_expr ----> subterm(999)
|
|
| subterm(999) list_tail
|
|
|
|
list_tail ----> ',' list_expr
|
|
| ',..' subterm(999)
|
|
| '|' subterm(999)
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
Notes:
|
|
|
|
+ \a op(N,T) denotes an atom which has been previously declared with type
|
|
\a T and base precedence \a N.
|
|
|
|
+ Since ',' is itself a pre-declared operator with type \a xfy and
|
|
precedence 1000, is \a subterm starts with a '(', \a op must be
|
|
followed by a space to avoid ambiguity with the case of a functor
|
|
followed by arguments, e.g.:
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
+ (a,b) [the same as '+'(','(a,b)) of arity one]
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
versus
|
|
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
+(a,b) [the same as '+'(a,b) of arity two]
|
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
+
|
|
In the first rule for term(0) no blank space should exist between
|
|
\a atom and '('.
|
|
|
|
+
|
|
Each term to be read by the YAP parser must end with a single
|
|
dot, followed by a blank (in the sense mentioned in the previous
|
|
paragraph). When a name consisting of a single dot could be taken for
|
|
the end of term marker, the ambiguity should be avoided by surrounding the
|
|
dot with single quotes.
|
|
|
|
@}
|
|
|
|
*/
|
|
|
|
/*
|
|
* Description:
|
|
*
|
|
* parser: produces a prolog term from an array of tokens
|
|
*
|
|
* parser usage: the parser takes its input from an array of token descriptions
|
|
* addressed by the global variable 'tokptr' and produces a Term as result. A
|
|
* macro 'NextToken' should be defined in 'yap.h' for advancing 'tokptr' from
|
|
* one token to the next. In the distributed version this macro also updates
|
|
* a variable named 'toktide' for keeping track of how far the parser went
|
|
* before failling with a syntax error. The parser should be invoked with
|
|
* 'tokptr' pointing to the first token. The last token should have type
|
|
* 'eot_tok'. The parser return either a Term. Syntactic errors are signaled
|
|
* by a return value 0. The parser builds new terms on the 'global stack' and
|
|
* also uses an auxiliary stack pointed to by 'AuxSp'. In the distributed
|
|
* version this auxiliary stack is assumed to grow downwards. This
|
|
* assumption, however, is only relevant to routine 'ParseArgs', and to the
|
|
* variable toktide. conclusion: set tokptr pointing to first token set AuxSp
|
|
* Call Parse
|
|
*
|
|
* VSC: Working whithout known bugs in 87/4/6
|
|
*
|
|
* LD: -I or +I evaluated by parser 87/4/28
|
|
*
|
|
* LD: parser extended 87/4/28
|
|
*
|
|
*/
|
|
|
|
#include "Yap.h"
|
|
#include "Yatom.h"
|
|
#include "YapHeap.h"
|
|
#include "YapText.h"
|
|
#include "yapio.h"
|
|
#include "eval.h"
|
|
/* stuff we want to use in standard YAP code */
|
|
#include "iopreds.h"
|
|
#if HAVE_STRING_H
|
|
#include <string.h>
|
|
#endif
|
|
#if HAVE_STDARG_H
|
|
#include <stdarg.h>
|
|
#endif
|
|
|
|
#ifdef __STDC__XXX
|
|
#define Volatile volatile
|
|
#else
|
|
#define Volatile
|
|
#endif
|
|
|
|
/* weak backtraking mechanism based on long_jump */
|
|
|
|
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, Term CACHE_TYPE);
|
|
static Term ParseList(JMPBUFF *, Term CACHE_TYPE);
|
|
static Term ParseTerm(int, JMPBUFF *, Term CACHE_TYPE);
|
|
|
|
const char *Yap_tokRep(TokEntry *tokptr);
|
|
|
|
static void syntax_msg(const char *msg, ...) {
|
|
CACHE_REGS
|
|
va_list ap;
|
|
|
|
if (LOCAL_toktide == LOCAL_tokptr) {
|
|
char out[YAP_FILENAME_MAX];
|
|
va_start(ap, msg);
|
|
vsnprintf(out, YAP_FILENAME_MAX - 1, msg, ap);
|
|
LOCAL_Error_Term = MkStringTerm( out );
|
|
LOCAL_Error_TYPE = SYNTAX_ERROR;
|
|
va_end(ap);
|
|
}
|
|
}
|
|
|
|
#define TRY(S, P) \
|
|
{ \
|
|
Volatile JMPBUFF *saveenv, newenv; \
|
|
Volatile TokEntry *saveT = LOCAL_tokptr; \
|
|
Volatile CELL *saveH = HR; \
|
|
Volatile int savecurprio = curprio; \
|
|
saveenv = FailBuff; \
|
|
if (!sigsetjmp(newenv.JmpBuff, 0)) { \
|
|
FailBuff = &newenv; \
|
|
S; \
|
|
FailBuff = saveenv; \
|
|
P; \
|
|
} else { \
|
|
FailBuff = saveenv; \
|
|
HR = saveH; \
|
|
curprio = savecurprio; \
|
|
LOCAL_tokptr = saveT; \
|
|
} \
|
|
}
|
|
|
|
#define TRY3(S, P, F) \
|
|
{ \
|
|
Volatile JMPBUFF *saveenv, newenv; \
|
|
Volatile TokEntry *saveT = LOCAL_tokptr; \
|
|
Volatile CELL *saveH = HR; \
|
|
saveenv = FailBuff; \
|
|
if (!sigsetjmp(newenv.JmpBuff, 0)) { \
|
|
FailBuff = &newenv; \
|
|
S; \
|
|
FailBuff = saveenv; \
|
|
P; \
|
|
} else { \
|
|
FailBuff = saveenv; \
|
|
HR = saveH; \
|
|
LOCAL_tokptr = saveT; \
|
|
F \
|
|
} \
|
|
}
|
|
|
|
#define FAIL siglongjmp(FailBuff->JmpBuff, 1)
|
|
|
|
VarEntry *
|
|
Yap_LookupVar(const char *var) /* lookup variable in variables table */
|
|
{
|
|
CACHE_REGS
|
|
VarEntry *p;
|
|
|
|
#if DEBUG
|
|
if (GLOBAL_Option[4])
|
|
fprintf(stderr, "[LookupVar %s]", var);
|
|
#endif
|
|
if (var[0] != '_' || var[1] != '\0') {
|
|
VarEntry **op = &LOCAL_VarTable;
|
|
UInt hv;
|
|
|
|
p = LOCAL_VarTable;
|
|
hv = HashFunction((unsigned char *)var) % AtomHashTableSize;
|
|
while (p != NULL) {
|
|
CELL hpv = p->hv;
|
|
if (hv == hpv) {
|
|
Int scmp;
|
|
if ((scmp = strcmp(var, p->VarRep)) == 0) {
|
|
p->refs++;
|
|
return (p);
|
|
} else if (scmp < 0) {
|
|
op = &(p->VarLeft);
|
|
p = p->VarLeft;
|
|
} else {
|
|
op = &(p->VarRight);
|
|
p = p->VarRight;
|
|
}
|
|
} else if (hv < hpv) {
|
|
op = &(p->VarLeft);
|
|
p = p->VarLeft;
|
|
} else {
|
|
op = &(p->VarRight);
|
|
p = p->VarRight;
|
|
}
|
|
}
|
|
p = (VarEntry *)Yap_AllocScannerMemory(strlen(var) + sizeof(VarEntry));
|
|
*op = p;
|
|
p->VarLeft = p->VarRight = NULL;
|
|
p->hv = hv;
|
|
p->refs = 1L;
|
|
strcpy(p->VarRep, var);
|
|
} else {
|
|
/* anon var */
|
|
p = (VarEntry *)Yap_AllocScannerMemory(sizeof(VarEntry) + 2);
|
|
p->VarLeft = LOCAL_AnonVarTable;
|
|
LOCAL_AnonVarTable = p;
|
|
p->VarRight = NULL;
|
|
p->refs = 0L;
|
|
p->hv = 1L;
|
|
p->VarRep[0] = '_';
|
|
p->VarRep[1] = '\0';
|
|
}
|
|
p->VarAdr = TermNil;
|
|
return (p);
|
|
}
|
|
|
|
static Term VarNames(VarEntry *p, Term l USES_REGS) {
|
|
if (p != NULL) {
|
|
if (strcmp(p->VarRep, "_") != 0) {
|
|
Term t[2];
|
|
Term o;
|
|
|
|
t[0] = MkAtomTerm(Yap_LookupAtom(p->VarRep));
|
|
if (!IsVarTerm(p->VarAdr))
|
|
p->VarAdr = MkVarTerm();
|
|
t[1] = p->VarAdr;
|
|
o = Yap_MkApplTerm(FunctorEq, 2, t);
|
|
o = MkPairTerm(o, VarNames(p->VarRight,
|
|
VarNames(p->VarLeft, l PASS_REGS) PASS_REGS));
|
|
if (HR > ASP - 4096) {
|
|
save_machine_regs();
|
|
siglongjmp(LOCAL_IOBotch, 1);
|
|
}
|
|
return (o);
|
|
} else {
|
|
return VarNames(p->VarRight, VarNames(p->VarLeft, l PASS_REGS) PASS_REGS);
|
|
}
|
|
} else {
|
|
return (l);
|
|
}
|
|
}
|
|
|
|
Term Yap_VarNames(VarEntry *p, Term l) {
|
|
CACHE_REGS
|
|
return VarNames(p, l PASS_REGS);
|
|
}
|
|
|
|
static Term Singletons(VarEntry *p, Term l USES_REGS) {
|
|
if (p != NULL) {
|
|
if (p->VarRep[0] != '_' && p->refs == 1) {
|
|
Term t[2];
|
|
Term o;
|
|
|
|
t[0] = MkAtomTerm(Yap_LookupAtom(p->VarRep));
|
|
t[1] = p->VarAdr;
|
|
o = Yap_MkApplTerm(FunctorEq, 2, t);
|
|
o = MkPairTerm(o,
|
|
Singletons(p->VarRight,
|
|
Singletons(p->VarLeft, l PASS_REGS) PASS_REGS));
|
|
if (HR > ASP - 4096) {
|
|
save_machine_regs();
|
|
siglongjmp(LOCAL_IOBotch, 1);
|
|
}
|
|
return (o);
|
|
} else {
|
|
return Singletons(p->VarRight,
|
|
Singletons(p->VarLeft, l PASS_REGS) PASS_REGS);
|
|
}
|
|
} else {
|
|
return (l);
|
|
}
|
|
}
|
|
|
|
Term Yap_Singletons(VarEntry *p, Term l) {
|
|
CACHE_REGS
|
|
return Singletons(p, l PASS_REGS);
|
|
}
|
|
|
|
static Term Variables(VarEntry *p, Term l USES_REGS) {
|
|
if (p != NULL) {
|
|
Term o;
|
|
o = MkPairTerm(
|
|
p->VarAdr,
|
|
Variables(p->VarRight, Variables(p->VarLeft, l PASS_REGS) PASS_REGS));
|
|
if (HR > ASP - 4096) {
|
|
save_machine_regs();
|
|
siglongjmp(LOCAL_IOBotch, 1);
|
|
}
|
|
return (o);
|
|
} else {
|
|
return (l);
|
|
}
|
|
}
|
|
|
|
Term Yap_Variables(VarEntry *p, Term l) {
|
|
CACHE_REGS
|
|
return Variables(p, l PASS_REGS);
|
|
}
|
|
|
|
static int IsPrefixOp(Atom op, int *pptr, int *rpptr, Term cmod USES_REGS) {
|
|
int p;
|
|
|
|
OpEntry *opp = Yap_GetOpProp(op, PREFIX_OP, cmod PASS_REGS);
|
|
if (!opp)
|
|
return FALSE;
|
|
if (opp->OpModule && opp->OpModule != cmod) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return FALSE;
|
|
}
|
|
if ((p = opp->Prefix) != 0) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
*pptr = *rpptr = p &MaskPrio;
|
|
if (p & DcrrpFlag)
|
|
--*rpptr;
|
|
return TRUE;
|
|
} else {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return FALSE;
|
|
}
|
|
}
|
|
|
|
int Yap_IsPrefixOp(Atom op, int *pptr, int *rpptr) {
|
|
CACHE_REGS
|
|
return IsPrefixOp(op, pptr, rpptr, CurrentModule PASS_REGS);
|
|
}
|
|
|
|
static int IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr, Term cmod USES_REGS) {
|
|
int p;
|
|
|
|
OpEntry *opp = Yap_GetOpProp(op, INFIX_OP, cmod PASS_REGS);
|
|
if (!opp)
|
|
return FALSE;
|
|
if (opp->OpModule && opp->OpModule != cmod) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return FALSE;
|
|
}
|
|
if ((p = opp->Infix) != 0) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
*pptr = *rpptr = *lpptr = p &MaskPrio;
|
|
if (p & DcrrpFlag)
|
|
--*rpptr;
|
|
if (p & DcrlpFlag)
|
|
--*lpptr;
|
|
return TRUE;
|
|
} else {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return FALSE;
|
|
}
|
|
}
|
|
|
|
int Yap_IsInfixOp(Atom op, int *pptr, int *lpptr, int *rpptr) {
|
|
CACHE_REGS
|
|
return IsInfixOp(op, pptr, lpptr, rpptr, CurrentModule PASS_REGS);
|
|
}
|
|
|
|
static int IsPosfixOp(Atom op, int *pptr, int *lpptr, Term cmod USES_REGS) {
|
|
int p;
|
|
|
|
OpEntry *opp = Yap_GetOpProp(op, POSFIX_OP, cmod PASS_REGS);
|
|
if (!opp)
|
|
return FALSE;
|
|
if (opp->OpModule && opp->OpModule != cmod) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return FALSE;
|
|
}
|
|
if ((p = opp->Posfix) != 0) {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
*pptr = *lpptr = p &MaskPrio;
|
|
if (p & DcrlpFlag)
|
|
--*lpptr;
|
|
return (TRUE);
|
|
} else {
|
|
READ_UNLOCK(opp->OpRWLock);
|
|
return (FALSE);
|
|
}
|
|
}
|
|
|
|
int Yap_IsPosfixOp(Atom op, int *pptr, int *lpptr) {
|
|
CACHE_REGS
|
|
return IsPosfixOp(op, pptr, lpptr, CurrentModule PASS_REGS);
|
|
}
|
|
|
|
inline static void GNextToken(USES_REGS1) {
|
|
if (LOCAL_tokptr->Tok == Ord(eot_tok))
|
|
return;
|
|
if (LOCAL_tokptr == LOCAL_toktide) {
|
|
LOCAL_toktide = LOCAL_tokptr = LOCAL_tokptr->TokNext;
|
|
} else
|
|
LOCAL_tokptr = LOCAL_tokptr->TokNext;
|
|
}
|
|
|
|
inline static void checkfor(wchar_t c, JMPBUFF *FailBuff USES_REGS) {
|
|
if (LOCAL_tokptr->Tok != Ord(Ponctuation_tok) ||
|
|
LOCAL_tokptr->TokInfo != (Term)c) {
|
|
char s[1024];
|
|
strncpy(s, Yap_tokRep(LOCAL_tokptr), 1023);
|
|
syntax_msg("line %d: expected to find \'%c\', found %s", LOCAL_tokptr->TokPos, c, s);
|
|
FAIL;
|
|
}
|
|
NextToken;
|
|
}
|
|
|
|
#ifdef O_QUASIQUOTATIONS
|
|
|
|
static int is_quasi_quotation_syntax(Term goal, Atom *pat, Term cmod) {
|
|
CACHE_REGS
|
|
Term m = cmod, t;
|
|
Atom at;
|
|
UInt arity;
|
|
Functor f;
|
|
|
|
t = Yap_StripModule(goal, &m);
|
|
f = FunctorOfTerm(t);
|
|
*pat = at = NameOfFunctor(f);
|
|
arity = ArityOfFunctor(f);
|
|
if (arity > 0)
|
|
return TRUE;
|
|
return FALSE;
|
|
}
|
|
|
|
static int get_quasi_quotation(term_t t, unsigned char **here,
|
|
unsigned char *ein) {
|
|
unsigned char *in, *start = *here;
|
|
|
|
for (in = start; in <= ein; in++) {
|
|
if (in[0] == '}' && in[-1] == '|') {
|
|
*here = in + 1; /* after } */
|
|
in--; /* Before | */
|
|
|
|
if (LOCAL_quasi_quotations) /* option; must return strings */
|
|
{
|
|
PL_chars_t txt;
|
|
int rc;
|
|
|
|
txt.text.t = (char *)start;
|
|
txt.length = in - start;
|
|
txt.storage = PL_CHARS_HEAP;
|
|
txt.encoding = ENC_UTF8;
|
|
txt.canonical = FALSE;
|
|
|
|
rc = PL_unify_text(t, 0, &txt, PL_CODE_LIST);
|
|
PL_free_text(&txt);
|
|
|
|
return rc;
|
|
} else {
|
|
return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_dquasi_quotation3,
|
|
PL_POINTER, LOCAL, PL_INTPTR, (intptr_t)(start),
|
|
PL_INTPTR, (intptr_t)(in - start));
|
|
}
|
|
}
|
|
}
|
|
|
|
return FALSE; // errorWarning("end_of_file_in_quasi_quotation", 0, _PL_rd);
|
|
}
|
|
#endif /*O_QUASIQUOTATIONS*/
|
|
|
|
static Term ParseArgs(Atom a, wchar_t close, JMPBUFF *FailBuff,
|
|
Term arg1, Term cmod USES_REGS) {
|
|
int nargs = 0;
|
|
Term *p, t;
|
|
Functor func;
|
|
#ifdef SFUNC
|
|
SFEntry *pe = (SFEntry *)Yap_GetAProp(a, SFProperty);
|
|
#endif
|
|
|
|
NextToken;
|
|
p = (Term *)ParserAuxSp;
|
|
if (arg1) {
|
|
*p = arg1;
|
|
nargs++;
|
|
ParserAuxSp = (char *)(p + 1);
|
|
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok) &&
|
|
LOCAL_tokptr->TokInfo == close) {
|
|
|
|
func = Yap_MkFunctor(a, 1);
|
|
if (func == NULL) {
|
|
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos );
|
|
FAIL;
|
|
}
|
|
t = Yap_MkApplTerm(func, nargs, p);
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos );
|
|
return TermNil;
|
|
}
|
|
NextToken;
|
|
return t;
|
|
}
|
|
}
|
|
while (1) {
|
|
Term *tp = (Term *)ParserAuxSp;
|
|
if (ParserAuxSp + 1 > LOCAL_TrailTop) {
|
|
syntax_msg("line %d: Trail Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
*tp++ = Unsigned(ParseTerm(999, FailBuff, cmod PASS_REGS));
|
|
ParserAuxSp = (char *)tp;
|
|
++nargs;
|
|
if (LOCAL_tokptr->Tok != Ord(Ponctuation_tok))
|
|
break;
|
|
if (((int)LOCAL_tokptr->TokInfo) != ',')
|
|
break;
|
|
NextToken;
|
|
}
|
|
ParserAuxSp = (char *)p;
|
|
/*
|
|
* Needed because the arguments for the functor are placed in reverse
|
|
* order
|
|
*/
|
|
if (HR > ASP - (nargs + 1)) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
func = Yap_MkFunctor(a, nargs);
|
|
if (func == NULL) {
|
|
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
#ifdef SFUNC
|
|
if (pe)
|
|
t = MkSFTerm(Yap_MkFunctor(a, SFArity), nargs, p, pe->NilValue);
|
|
else
|
|
t = Yap_MkApplTerm(Yap_MkFunctor(a, nargs), nargs, p);
|
|
#else
|
|
if (a == AtomDBref && nargs == 2)
|
|
t = MkDBRefTerm((DBRef)IntegerOfTerm(p[0]));
|
|
else
|
|
t = Yap_MkApplTerm(func, nargs, p);
|
|
#endif
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
return TermNil;
|
|
}
|
|
/* check for possible overflow against local stack */
|
|
checkfor(close, FailBuff PASS_REGS);
|
|
return t;
|
|
}
|
|
|
|
static Term MakeAccessor(Term t, Functor f USES_REGS) {
|
|
UInt arity = ArityOfFunctor(FunctorOfTerm(t)), i;
|
|
Term tf[2], tl = TermNil;
|
|
|
|
tf[1] = ArgOfTerm(1, t);
|
|
for (i = arity; i > 1; i--) {
|
|
tl = MkPairTerm(ArgOfTerm(i, t), tl);
|
|
}
|
|
tf[0] = tl;
|
|
return Yap_MkApplTerm(f, 2, tf);
|
|
}
|
|
|
|
static Term ParseList(JMPBUFF *FailBuff, Term cmod USES_REGS) {
|
|
Term o;
|
|
CELL *to_store;
|
|
o = AbsPair(HR);
|
|
loop:
|
|
to_store = HR;
|
|
HR += 2;
|
|
to_store[0] = ParseTerm(999, FailBuff, cmod PASS_REGS);
|
|
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok)) {
|
|
if (((int)LOCAL_tokptr->TokInfo) == ',') {
|
|
NextToken;
|
|
{
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
to_store[1] = TermNil;
|
|
syntax_msg("line %d: Stack Overflow" ,LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
} else {
|
|
to_store[1] = AbsPair(HR);
|
|
goto loop;
|
|
}
|
|
}
|
|
} else if (((int)LOCAL_tokptr->TokInfo) == '|') {
|
|
NextToken;
|
|
to_store[1] = ParseTerm(999, FailBuff, cmod PASS_REGS);
|
|
} else {
|
|
to_store[1] = MkAtomTerm(AtomNil);
|
|
}
|
|
} else {
|
|
syntax_msg("line %d: looking for symbol ',','|' got symbol '%s'",LOCAL_tokptr->TokPos,
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
return (o);
|
|
}
|
|
|
|
static Term ParseTerm(int prio, JMPBUFF *FailBuff, Term cmod USES_REGS) {
|
|
/* parse term with priority prio */
|
|
Volatile Term t;
|
|
Volatile Functor func;
|
|
Volatile VarEntry *varinfo;
|
|
Volatile int curprio = 0, opprio, oplprio, oprprio;
|
|
Volatile Atom opinfo;
|
|
|
|
switch (LOCAL_tokptr->Tok) {
|
|
case Name_tok:
|
|
t = LOCAL_tokptr->TokInfo;
|
|
NextToken;
|
|
/* special rules apply for +1, -2.3, etc... */
|
|
if (LOCAL_tokptr->Tok == Number_tok) {
|
|
if ((Atom)t == AtomMinus) {
|
|
t = LOCAL_tokptr->TokInfo;
|
|
if (IsIntTerm(t))
|
|
t = MkIntTerm(-IntOfTerm(t));
|
|
else if (IsFloatTerm(t))
|
|
t = MkFloatTerm(-FloatOfTerm(t));
|
|
#ifdef USE_GMP
|
|
else if (IsBigIntTerm(t)) {
|
|
t = Yap_gmp_neg_big(t);
|
|
}
|
|
#endif
|
|
else
|
|
t = MkLongIntTerm(-LongIntOfTerm(t));
|
|
NextToken;
|
|
break;
|
|
}
|
|
}
|
|
if ((LOCAL_tokptr->Tok != Ord(Ponctuation_tok) ||
|
|
Unsigned(LOCAL_tokptr->TokInfo) != 'l') &&
|
|
IsPrefixOp((Atom)t, &opprio, &oprprio, cmod PASS_REGS)) {
|
|
if (LOCAL_tokptr->Tok == Name_tok) {
|
|
Atom at = (Atom)LOCAL_tokptr->TokInfo;
|
|
#ifndef _MSC_VER
|
|
if ((Atom)t == AtomPlus) {
|
|
if (at == AtomInf) {
|
|
t = MkFloatTerm(INFINITY);
|
|
NextToken;
|
|
break;
|
|
} else if (at == AtomNan) {
|
|
t = MkFloatTerm(NAN);
|
|
NextToken;
|
|
break;
|
|
}
|
|
} else if ((Atom)t == AtomMinus) {
|
|
if (at == AtomInf) {
|
|
t = MkFloatTerm(-INFINITY);
|
|
NextToken;
|
|
break;
|
|
} else if (at == AtomNan) {
|
|
t = MkFloatTerm(NAN);
|
|
NextToken;
|
|
break;
|
|
}
|
|
}
|
|
#endif
|
|
}
|
|
if (opprio <= prio) {
|
|
/* try to parse as a prefix operator */
|
|
TRY(
|
|
/* build appl on the heap */
|
|
func = Yap_MkFunctor((Atom)t, 1); if (func == NULL) {
|
|
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
t = ParseTerm(oprprio, FailBuff, cmod PASS_REGS);
|
|
t = Yap_MkApplTerm(func, 1, &t);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
} curprio = opprio;
|
|
, break;)
|
|
}
|
|
}
|
|
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok) &&
|
|
Unsigned(LOCAL_tokptr->TokInfo) == 'l')
|
|
t = ParseArgs((Atom)t, ')', FailBuff, 0L, cmod PASS_REGS);
|
|
else
|
|
t = MkAtomTerm((Atom)t);
|
|
break;
|
|
|
|
case Number_tok:
|
|
t = LOCAL_tokptr->TokInfo;
|
|
NextToken;
|
|
break;
|
|
|
|
case String_tok: /* build list on the heap */
|
|
{
|
|
Volatile char *p = (char *)LOCAL_tokptr->TokInfo;
|
|
// 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, cmod, LOCAL_encoding PASS_REGS);
|
|
if (!t) {
|
|
syntax_msg("line %d: could not convert \"%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo);
|
|
FAIL;
|
|
}
|
|
LOCAL_Error_TYPE = oerr;
|
|
NextToken;
|
|
} break;
|
|
|
|
case WString_tok: /* build list on the heap */
|
|
{
|
|
Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo;
|
|
// 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, cmod PASS_REGS);
|
|
if (!t) {
|
|
syntax_msg("line %d: could not convert \'%S\'",LOCAL_tokptr->TokPos, (wchar_t *)LOCAL_tokptr->TokInfo);
|
|
FAIL;
|
|
}
|
|
LOCAL_Error_TYPE = oerr;
|
|
NextToken;
|
|
} break;
|
|
|
|
case BQString_tok: /* build list on the heap */
|
|
{
|
|
Volatile char *p = (char *)LOCAL_tokptr->TokInfo;
|
|
// we may be operating under a syntax error
|
|
yap_error_number oerr = LOCAL_Error_TYPE;
|
|
LOCAL_Error_TYPE = YAP_NO_ERROR;
|
|
|
|
t = Yap_CharsToTBQ(p, cmod, LOCAL_encoding PASS_REGS);
|
|
if (!t) {
|
|
syntax_msg("line %d: could not convert \'%s\"",LOCAL_tokptr->TokPos, (char *)LOCAL_tokptr->TokInfo);
|
|
FAIL;
|
|
}
|
|
LOCAL_Error_TYPE = oerr;
|
|
NextToken;
|
|
} break;
|
|
|
|
case WBQString_tok: /* build list on the heap */
|
|
{
|
|
Volatile wchar_t *p = (wchar_t *)LOCAL_tokptr->TokInfo;
|
|
t = Yap_WCharsToTBQ(p, cmod PASS_REGS);
|
|
// we may be operating under a syntax error
|
|
yap_error_number oerr = LOCAL_Error_TYPE;
|
|
LOCAL_Error_TYPE = YAP_NO_ERROR;
|
|
if (!t) {
|
|
syntax_msg("line %d: could not convert \"%S\"",LOCAL_tokptr->TokPos, (wchar_t *)LOCAL_tokptr->TokInfo);
|
|
FAIL;
|
|
}
|
|
LOCAL_Error_TYPE = oerr;
|
|
NextToken;
|
|
} break;
|
|
|
|
case Var_tok:
|
|
varinfo = (VarEntry *)(LOCAL_tokptr->TokInfo);
|
|
if ((t = varinfo->VarAdr) == TermNil) {
|
|
t = varinfo->VarAdr = MkVarTerm();
|
|
}
|
|
NextToken;
|
|
break;
|
|
|
|
case Error_tok:
|
|
syntax_msg("line %d: found ill-formed \"%s\"",LOCAL_tokptr->TokPos, Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
|
|
case Ponctuation_tok:
|
|
|
|
switch ((int)LOCAL_tokptr->TokInfo) {
|
|
case '(':
|
|
case 'l': /* non solo ( */
|
|
NextToken;
|
|
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, cmod PASS_REGS);
|
|
checkfor(')', FailBuff PASS_REGS);
|
|
break;
|
|
case '[':
|
|
NextToken;
|
|
if (LOCAL_tokptr->Tok == Ponctuation_tok &&
|
|
(int)LOCAL_tokptr->TokInfo == ']') {
|
|
t = TermNil;
|
|
NextToken;
|
|
break;
|
|
}
|
|
t = ParseList(FailBuff, cmod PASS_REGS);
|
|
checkfor(']', FailBuff PASS_REGS);
|
|
break;
|
|
case '{':
|
|
NextToken;
|
|
if (LOCAL_tokptr->Tok == Ponctuation_tok &&
|
|
(int)LOCAL_tokptr->TokInfo == '}') {
|
|
t = MkAtomTerm(AtomBraces);
|
|
NextToken;
|
|
break;
|
|
}
|
|
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, cmod PASS_REGS);
|
|
t = Yap_MkApplTerm(FunctorBraces, 1, &t);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
checkfor('}', FailBuff PASS_REGS);
|
|
break;
|
|
default:
|
|
syntax_msg("line %d: unexpected ponctuation signal %s",LOCAL_tokptr->TokPos, Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
break;
|
|
|
|
#if QQ
|
|
case QuasiQuotes_tok: {
|
|
qq_t *qq = (qq_t *)(LOCAL_tokptr->TokInfo);
|
|
term_t pv, positions = LOCAL_subtpos, to;
|
|
Atom at;
|
|
Term tn;
|
|
CELL *tnp;
|
|
|
|
// from SWI, enter the list
|
|
/* prepare (if we are the first in term) */
|
|
if (!LOCAL_varnames)
|
|
LOCAL_varnames = PL_new_term_ref();
|
|
if (!LOCAL_qq) {
|
|
if (LOCAL_quasi_quotations) {
|
|
LOCAL_qq = LOCAL_quasi_quotations;
|
|
} else {
|
|
if (!(LOCAL_qq = PL_new_term_ref()))
|
|
return FALSE;
|
|
}
|
|
// create positions term
|
|
if (positions) {
|
|
if (!(pv = PL_new_term_refs(3)) ||
|
|
!PL_unify_term(positions, PL_FUNCTOR,
|
|
FUNCTOR_quasi_quotation_position5, PL_INTPTR,
|
|
qq->start.charno, PL_VARIABLE, PL_TERM,
|
|
pv + 0, // leave three open slots
|
|
PL_TERM, pv + 1, PL_TERM, pv + 2))
|
|
return FALSE;
|
|
} else
|
|
pv = 0;
|
|
/* push type */
|
|
|
|
if (!(LOCAL_qq_tail = PL_copy_term_ref(LOCAL_qq)))
|
|
return FALSE;
|
|
}
|
|
|
|
NextToken;
|
|
t = ParseTerm(GLOBAL_MaxPriority, FailBuff, cmod PASS_REGS);
|
|
if (LOCAL_tokptr->Tok != QuasiQuotes_tok) {
|
|
syntax_msg("expected to find quasi quotes, got \"%s\"", ,
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
if (!(is_quasi_quotation_syntax(t, &at))) {
|
|
syntax_msg("bad quasi quotation syntax, at \"%s\"",
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
/* Arg 2: the content */
|
|
tn = Yap_MkNewApplTerm(SWIFunctorToFunctor(FUNCTOR_quasi_quotation4), 4);
|
|
tnp = RepAppl(tn) + 1;
|
|
tnp[0] = MkAtomTerm(at);
|
|
if (!get_quasi_quotation(Yap_InitSlot(ArgOfTerm(2, tn)), &qq->text,
|
|
qq->text + strlen((const char *)qq->text))) {
|
|
syntax_msg("could not get quasi quotation, at \"%s\"",
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
if (positions) {
|
|
intptr_t qqend = qq->end.charno;
|
|
|
|
// set_range_position(positions, -1, qqend PASS_LD);
|
|
if (!PL_unify_term(Yap_InitSlot(ArgOfTerm(2, t)), PL_FUNCTOR,
|
|
FUNCTOR_minus2, PL_INTPTR,
|
|
qq->mid.charno + 2, /* end of | token */
|
|
PL_INTPTR, qqend - 2)) /* end minus "|}" */
|
|
syntax_msg("failed to unify quasi quotation, at \"%s\"",
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
|
|
tnp[2] = Yap_GetFromSlot(LOCAL_varnames); /* Arg 3: the var dictionary */
|
|
/* Arg 4: the result */
|
|
t = ArgOfTerm(4, tn);
|
|
if (!(to = PL_new_term_ref()) ||
|
|
!PL_unify_list(LOCAL_qq_tail, to, LOCAL_qq_tail) ||
|
|
!PL_unify(to, Yap_InitSlot(tn))) {
|
|
syntax_msg("failed to unify quasi quotation, at \"%s\"",
|
|
Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
}
|
|
#endif
|
|
NextToken;
|
|
break;
|
|
default:
|
|
syntax_msg("line %d: expected operator, got \'%s\'",LOCAL_tokptr->TokPos, Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
|
|
/* main loop to parse infix and posfix operators starts here */
|
|
while (true) {
|
|
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, cmod PASS_REGS) &&
|
|
opprio <= prio && oplprio >= curprio) {
|
|
/* try parsing as infix operator */
|
|
Volatile int oldprio = curprio;
|
|
TRY3(
|
|
func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 2);
|
|
if (func == NULL) {
|
|
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
} NextToken;
|
|
{
|
|
Term args[2];
|
|
args[0] = t;
|
|
args[1] = ParseTerm(oprprio, FailBuff, cmod PASS_REGS);
|
|
t = Yap_MkApplTerm(func, 2, args);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
},
|
|
curprio = opprio;
|
|
opinfo = save_opinfo; continue;, opinfo = save_opinfo;
|
|
curprio = oldprio;)
|
|
}
|
|
if (IsPosfixOp(opinfo, &opprio, &oplprio, cmod PASS_REGS) && opprio <= prio &&
|
|
oplprio >= curprio) {
|
|
/* parse as posfix operator */
|
|
Functor func = Yap_MkFunctor((Atom)LOCAL_tokptr->TokInfo, 1);
|
|
if (func == NULL) {
|
|
syntax_msg("line %d: Heap Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
t = Yap_MkApplTerm(func, 1, &t);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
curprio = opprio;
|
|
NextToken;
|
|
continue;
|
|
}
|
|
break;
|
|
}
|
|
if (LOCAL_tokptr->Tok == Ord(Ponctuation_tok)) {
|
|
if (Unsigned(LOCAL_tokptr->TokInfo) == ',' && prio >= 1000 &&
|
|
curprio <= 999) {
|
|
Volatile Term args[2];
|
|
NextToken;
|
|
args[0] = t;
|
|
args[1] = ParseTerm(1000, FailBuff, cmod PASS_REGS);
|
|
t = Yap_MkApplTerm(FunctorComma, 2, args);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
curprio = 1000;
|
|
continue;
|
|
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '|' &&
|
|
IsInfixOp(AtomVBar, &opprio, &oplprio, &oprprio, cmod PASS_REGS) &&
|
|
opprio <= prio && oplprio >= curprio) {
|
|
Volatile Term args[2];
|
|
NextToken;
|
|
args[0] = t;
|
|
args[1] = ParseTerm(oprprio, FailBuff, cmod PASS_REGS);
|
|
t = Yap_MkApplTerm(FunctorVBar, 2, args);
|
|
/* check for possible overflow against local stack */
|
|
if (HR > ASP - 4096) {
|
|
syntax_msg("line %d: Stack Overflow",LOCAL_tokptr->TokPos);
|
|
FAIL;
|
|
}
|
|
curprio = opprio;
|
|
continue;
|
|
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '(' &&
|
|
IsPosfixOp(AtomEmptyBrackets, &opprio, &oplprio, cmod PASS_REGS) &&
|
|
opprio <= prio && oplprio >= curprio) {
|
|
t = ParseArgs(AtomEmptyBrackets, ')', FailBuff, t, cmod PASS_REGS);
|
|
curprio = opprio;
|
|
continue;
|
|
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '[' &&
|
|
IsPosfixOp(AtomEmptySquareBrackets, &opprio,
|
|
&oplprio, cmod PASS_REGS) &&
|
|
opprio <= prio && oplprio >= curprio) {
|
|
t = ParseArgs(AtomEmptySquareBrackets, ']', FailBuff, t, cmod PASS_REGS);
|
|
t = MakeAccessor(t, FunctorEmptySquareBrackets PASS_REGS);
|
|
curprio = opprio;
|
|
continue;
|
|
} else if (Unsigned(LOCAL_tokptr->TokInfo) == '{' &&
|
|
IsPosfixOp(AtomEmptyCurlyBrackets, &opprio,
|
|
&oplprio, cmod PASS_REGS) &&
|
|
opprio <= prio && oplprio >= curprio) {
|
|
t = ParseArgs(AtomEmptyCurlyBrackets, '}', FailBuff, t, cmod PASS_REGS);
|
|
t = MakeAccessor(t, FunctorEmptyCurlyBrackets PASS_REGS);
|
|
curprio = opprio;
|
|
continue;
|
|
}
|
|
}
|
|
if (LOCAL_tokptr->Tok <= Ord(WString_tok)) {
|
|
syntax_msg("line %d: expected operator, got \'%s\'",LOCAL_tokptr->TokPos, Yap_tokRep(LOCAL_tokptr));
|
|
FAIL;
|
|
}
|
|
break;
|
|
}
|
|
return t;
|
|
}
|
|
|
|
Term Yap_Parse(UInt prio, Term cmod) {
|
|
CACHE_REGS
|
|
Volatile Term t;
|
|
JMPBUFF FailBuff;
|
|
yhandle_t sls = Yap_StartSlots();
|
|
|
|
if (!sigsetjmp(FailBuff.JmpBuff, 0)) {
|
|
|
|
t = ParseTerm(prio, &FailBuff, cmod PASS_REGS);
|
|
#if DEBUG
|
|
if (GLOBAL_Option['p' - 'a' + 1]) {
|
|
Yap_DebugPutc(stderr, '[');
|
|
if (t == 0)
|
|
Yap_DebugPlWrite(MkIntTerm(0));
|
|
else
|
|
Yap_DebugPlWrite(t);
|
|
Yap_DebugPutc(stderr, ']');
|
|
Yap_DebugPutc(stderr, '\n');
|
|
}
|
|
#endif
|
|
Yap_CloseSlots(sls);
|
|
if (LOCAL_tokptr != NULL && LOCAL_tokptr->Tok != Ord(eot_tok)) {
|
|
LOCAL_Error_TYPE = SYNTAX_ERROR;
|
|
LOCAL_ErrorMessage = "term does not end on . ";
|
|
t = 0;
|
|
}
|
|
if (t != 0 && LOCAL_Error_TYPE == SYNTAX_ERROR) {
|
|
LOCAL_Error_TYPE = YAP_NO_ERROR;
|
|
LOCAL_ErrorMessage = NULL;
|
|
}
|
|
// if (LOCAL_tokptr->Tok != Ord(eot_tok))
|
|
// return (0L);
|
|
return t;
|
|
}
|
|
Yap_CloseSlots(sls);
|
|
|
|
return (0);
|
|
}
|
|
|
|
//! @}
|