home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Vectronix 2
/
VECTRONIX2.iso
/
FILES_01
/
X_PROLOG.LZH
/
X_PROLOG
/
SOURCES
/
READER.C
< prev
next >
Wrap
C/C++ Source or Header
|
1990-08-13
|
17KB
|
837 lines
/*
* X PROLOG Vers. 2.0
*
*
* Written by : Andreas Toenne
* CS Dept. , IRB
* University of Dortmund, W-Germany
* <at@unido.uucp>
* <....!seismo!unido!at>
* <at@unido.bitnet>
*
* Copyright : This software is copyrighted by Andreas Toenne.
* Permission is granted hereby to copy the entire
* package including this copyright notice without fee.
*
*/
#include <stdio.h>
#include <setjmp.h>
#include "prolog.h"
#include "extern.h"
#include "error.h"
#include "charset.h"
extern functor *find_operator(); /* functor */
extern functor *get_functor(); /* fucntor */
extern term *argument(); /* terms */
extern term *term_copy(); /* terms */
extern term *int_copy(); /* terms */
extern term *var_copy(); /* terms */
term *rd_term(); /* forward */
jmp_buf hop; /* for syntax errors in reader */
/* Test a given term for an operator definition */
short isinfix(name, prio, lprio, rprio)
char *name;
short *lprio, *rprio, *prio;
{
short foo;
short flags;
short inf;
if (!find_operator(name, &flags, &inf, &foo, &foo) || !inf)
return(FALSE);
*lprio = (flags & LOWER_LEFT ? inf-1 : inf);
*rprio = (flags & LOWER_RIGHT ? inf-1 : inf);
*prio = inf;
return(TRUE);
}
short ispostfix(name, prio, lprio)
char *name;
short *prio, *lprio;
{
short foo;
short post;
short flags;
if (!find_operator(name, &flags, &foo, &foo, &post) || !post)
return(FALSE);
*lprio = (flags & LOWER_LEFT ? post-1 : post);
*prio = post;
return(TRUE);
}
short isprefix(name, prio, rprio)
char *name;
short *prio, *rprio;
{
short foo;
short pre;
short flags;
if (!find_operator(name, &flags, &foo, &pre, &foo) || !pre)
return(FALSE);
*rprio = (flags & LOWER_RIGHT ? pre-1 : pre);
*prio = pre;
return(TRUE);
}
short isoperator(name, prio)
char *name;
short *prio;
{
short inf, post, pre;
short flags;
if (!find_operator(name, &flags, &inf, &pre, &post))
return(FALSE);
*prio = MAX(inf, pre);
*prio = MAX(*prio, post);
if (*prio)
return(TRUE);
else
return(FALSE);
}
/* write a term's name to the output stream */
/* quote it, if it's not a proper name */
static put_name(t, quote)
term *t;
short quote;
{
char *p;
short ok = TRUE;
p = NAME(t);
switch(ctype[*p])
{
case LOWER: while (*p)
if (ctype[*p++] > DIGIT)
{
ok = FALSE;
break;
}
p = NAME(t);
break;
case SINGLE: ok = (*(p+1) == '\0');
break;
case BRACKET: ok = (!strcmp(p, ",") || !strcmp(p, "[]"));
break;
case SYMBOL: if (!strcmp(p, "/*") || !strcmp(p, "."))
ok = FALSE;
else
{
while (*p)
if (ctype[*p++] != SYMBOL)
{
ok = FALSE;
break;
}
p = NAME(t);
}
break;
default: ok = FALSE;
}
if (!ok && quote)
putc('\'', out->fp);
while (*p)
{
if (*p == '\'')
putc('\'', out->fp);
putc(*p++, out->fp);
}
if (!ok && quote)
putc('\'', out->fp);
}
/* display a term t in enviroment e with local prio. */
/* display in standart prefix notation, if !doop */
void display(t, e, prio, doop, doquote)
term *t;
env *e;
short prio;
short doop;
short doquote;
{
short i,j,k;
if (ISINT(t)) /* an integer */
{
fprintf(out->fp, "%ld", VALUE(t));
return;
}
if (ISVAR(t)) /* a variable */
{
putc('_', out->fp);
if (ISANONYMOUS(t) || ISANOPROTO(t))
return;
if (ISFRAME(t)) /* frame variable */
fprintf(out->fp,"%ld",
-1*(((long)t-(long)stack)/sizeof(term)));
else /* copy or proto */
if (ISCOPY(t))
fprintf(out->fp,"%ld",
((long)t-(long)copystack)/sizeof(term));
else
fprintf(out->fp,"%ld", REF(t));
return;
}
if (FUNC(t) == ASSERTFUNCTOR)
{
putc('{', out->fp);
display(argument(t,e,1),e,255,doop,doquote);
putc('}', out->fp);
return;
}
if (ISATOM(t)) /* an atom */
{
if (doop && isoperator(NAME(t), &j))/* this is an operator */
{
putc('(', out->fp);
put_name(t, doquote);
putc(')', out->fp);
}
else
put_name(t, doquote);
return;
}
if (FUNC(t) == DOTFUNCTOR) /* a list */
{
putc('[', out->fp);
do
{
display(argument(t, e, 1), e, 252, doop, doquote);
t = argument(t, e, 2);
if (FUNC(t) == DOTFUNCTOR)
putc(',', out->fp);
} while (FUNC(t) == DOTFUNCTOR);
if (FUNC(t) != NILFUNCTOR)
{
putc('|', out->fp);
display(t, e, 252, doop, doquote);
}
putc(']', out->fp);
return;
}
/* if we reach this, t must be a structure */
if (! ISSTRUCT(t)) /* oops */
{
fprintf(out->fp, "?Invalid term at %ld?", (long)t);
return;
}
i = ARITY(t);
if (i == 1) /* maybe a prefix or postfix operator?*/
{
if (doop && isprefix(NAME(t), &j, &k))
{
if (j > prio)
putc('(', out->fp);
put_name(t, doquote);
putc(' ', out->fp);
display(argument(t, e, 1), e, k, doop, doquote);
if (j > prio)
putc(')', out->fp);
return;
}
if (doop && ispostfix(NAME(t), &j, &k))
{
if (j > prio)
putc('(', out->fp);
display(argument(t, e, 1), e, k, doop, doquote);
putc(' ', out->fp);
put_name(t, doquote);
if (j > prio)
putc(')', out->fp);
return;
}
}
if (i==2 && doop && isinfix(NAME(t), &i, &j, &k))
{
if (i > prio)
putc('(', out->fp);
display(argument(t, e, 1), e, j, doop, doquote);
putc(' ', out->fp);
put_name(t, doquote);
putc(' ', out->fp);
display(argument(t, e, 2), e, k, doop, doquote);
if (i > prio)
putc(')', out->fp);
return;
}
/* sorry pal, this is no operator. */
put_name(t, doquote);
putc('(', out->fp);
for (j=1; j<=i; j++)
{
display(argument(t, e, j), e, 252, doop, doquote);
if (j < i)
putc(',', out->fp);
}
putc(')', out->fp);
return;
}
/* The Prolog Reader */
/* Read a character from the current file */
char rd_it()
{
if (lastc == '\n' && FUNC(in->atom) == USERFUNCTOR)
fputs(NAME(prompt), out->fp);
lastc = getc(in->fp);
if (lastc == EOF) /* stop reading immediately */
{
c_errno = EEOF; /* signal error */
longjmp(hop, 2);
}
return(lastc);
}
/* Read a term in the line buffer */
short rd_line()
{
short i;
i = 0; /* start a new line */
do
{
c = rd_it();
c_type = ctype[c];
DOTTEST:
if (c == '.' && i > 0 && ctype[line[i-1]] != SYMBOL)
{
line[i++] = '.';
c = rd_it();
if (ctype[c] == BLANK) /* end of term */
{
line[i++] = ' ';
line[i] = '\0'; /* terminate line */
p = line;
return(TRUE); /* all is well */
}
c_type = ctype[c];
}
if (c_type == BLANK) /* skip blanks */
{
do
c = rd_it();
while (ctype[c] == BLANK);
line[i++] = ' '; /* leave just one blank */
c_type = ctype[c];
goto DOTTEST;
}
if (c == '%')
{
while(rd_it() != '\n');
continue;
}
line[i++] = c; /* enter the character */
if (c == '*' && i > 1 && line[i-2] == '/') /* comment */
{
i -= 2; /* remove / and * */
do
{
while ((c = rd_it()) != '*');
while ((c = rd_it()) == '*');
} while (c != '/');
continue; /* with the loop */
}
if (i > MAXLINE)
{
fprintf(stderr, "Term too long\n");
BIERROR(EIO);
}
if (feof(in->fp) || ferror(in->fp))
FILEERROR(EEOF);
if (c_type == QUOTE) /* sweep fuzzy name */
{
do
{
line[i++] = c = rd_it();
} while (ctype[c] != QUOTE);
continue; /* with the loop */
}
if (c_type == STRING) /* sweep string */
{
do
{
line[i++] = c = rd_it();
} while (ctype[c] != STRING);
continue; /* with the loop */
}
} while (TRUE);
}
/* fetch the next character from the current line */
short rd_char()
{
if (!*p) /* current line is empty */
if (!rd_line()) /* eof on input */
return(FALSE); /* signal an error */
c = *p++;
c_type = ctype[c];
return(TRUE);
}
/* Show a syntax error */
short syntax_error(t)
char *t;
{
char *q;
fprintf(stderr, "\n [Syntax Error %s] \n", t);
for (q=line; *q && q<p; putc(*q++, stderr));
fprintf(stderr, "\n [Here] \n");
for (; *q; putc(*q++, stderr));
*p = '\0';
c_errno = ESYNTAX;
putc('\n', stderr);
longjmp(hop, 1);
}
/* search/enter a variable in the local variable space */
/* if the variable is not given, create and return it. */
term *getvar(name)
char *name;
{
term *t;
short i;
if (!strcmp(name, "_")) /* a anonymous variable */
return(ANONYMOUSATOM);
for (i=0; i<tide; i++) /* search in the table */
if (!strcmp(l_table[i].name, name))
return(l_table[i].t);
if (tide == MAXVARS) /* table overflow */
BIERROR(ETOOMANY);
t = var_copy(); /* create new variable */
l_table[i].t = t;
strcpy(l_table[i].name, name);
tide++;
return(t);
}
/* parse the term and split it into token */
short rd_token()
{
short i, k;
long l;
k = 0;
if (valid_token)
{
valid_token = FALSE;
return(token_type);
}
do
switch(c_type)
{
case BLANK:
while (rd_char() && c_type == BLANK);
continue;
case UPPER:
k++;
case LOWER:
i = 0;
do
{
name[i++] = c;
} while (rd_char() && c_type <= DIGIT && i < MAXNAME);
if (i == MAXNAME)
syntax_error("Name too long");
name[i] = '\0';
if (k)
{
token_type = TVARIABLE;
token = (char *)getvar(name);
return(TVARIABLE);
}
else
{
token_type = TSYMBOL;
token = name;
return(TSYMBOL);
}
case DIGIT:
l = 0;
do
{
l = 10*l + c-'0';
} while (rd_char() && c_type == DIGIT);
token_type = TINTEGER;
token = (char *)int_copy(l);
return(TINTEGER);
case QUOTE:
case STRING:
k = c_type;
i = 0;
rd_char(); /* skip ' or " */
do
{
if (c_type==k && *p == c)
rd_char();
name[i++] = c;
} while (rd_char() && (c_type != k || *p==c) &&
i < MAXNAME);
if (i == MAXNAME)
syntax_error("Name too long");
name[i] = '\0';
rd_char(); /* skip ' or " */
if (k == QUOTE)
{
token_type = TSYMBOL;
token = name;
return(TSYMBOL);
}
else
{
token_type = TSTRING;
token = name;
return(TSTRING);
}
case SYMBOL:
if (c == '/' && *p == '*')
{
while(rd_char() && c != '*' && *p != '/');
rd_char();
rd_char();
continue;
}
i = 1;
name[0] = c;
if (c == '.')
{
if (rd_char() && c_type == BLANK)
{
token_type = TDOT;
p--;
return(TDOT);
}
}
else
rd_char();
while (c_type == SYMBOL && i < MAXNAME)
{
name[i++] = c;
rd_char();
}
if (i == MAXNAME)
syntax_error("Name too long");
name[i] = '\0';
token_type = TSYMBOL;
token = name;
return(TSYMBOL);
case SINGLE:
name[0] = c;
name[1] = '\0';
rd_char();
token_type = TSYMBOL;
token = name;
return(TSYMBOL);
case BRACKET:
if (c == '[' && *p == ']')
{
rd_char();
rd_char(); /* skip ] */
token_type = TINTEGER;
token = (char *)NILATOM;
return(TINTEGER);
}
token_type = TSPECIAL;
token = (char *)c;
rd_char();
return(TSPECIAL);
}
while (TRUE);
}
/* read the arguments of a standart term */
/* as we need a relative large local vector, we put this in it's */
/* own function to decrease stack usage as recursion takes place */
term *rd_args(name)
term *name;
{
short i = 0;
term *v[MAXARGS];
term *t;
char sname[MAXNAME]; /* the global name will be used again */
strcpy(sname, name); /* save the name for later use */
rd_char(); /* skip the ( */
do
{
v[i++] = rd_term(252);
} while (rd_token()==TSPECIAL && (char)token == ',' && i < MAXARGS);
if (token_type != TSPECIAL || (char)token != ')' || i == MAXARGS)
syntax_error("Wrong arguments list");
t = term_copy(get_functor(sname, i));
while (i > 0)
{
ARG(t,i) = v[i-1];
i--;
}
return(t);
}
/* convert a string into a dotted list */
term *rd_string(name)
char *name;
{
term *t, *p;
if (!*name)
return(NILATOM);
t = p = term_copy(DOTFUNCTOR);
do
{
ARG(p,1) = int_copy((long)*name++);
if (*name)
{
ARG(p,2) = term_copy(DOTFUNCTOR);
p = ARG(p,2);
}
} while (*name);
ARG(p,2) = NILATOM;
return(t);
}
/* parse a list */
term *rd_list()
{
term *t, *p;
p = t = term_copy(DOTFUNCTOR);
while (TRUE)
{
ARG(p,1) = rd_term(252);
if (rd_token() == TSPECIAL && (char)token == ',')
{
ARG(p,2) = term_copy(DOTFUNCTOR);
p = ARG(p,2);
}
else
{
if (token_type == TSPECIAL && (char)token == '|')
ARG(p,2) = rd_term(252);
else
{
ARG(p,2) = NILATOM;
valid_token = TRUE;
}
break;
}
}
return(t);
}
/* read a whole prolog term */
term *rd_term(prio)
short prio;
{
short i,j,k;
short lp; /* local prio */
term *t, *p;
if (c_errno) /* bad */
return(NULL);
lp = 0; /* local prio */
switch(rd_token())
{
case TSYMBOL:
if (c == '(') /* standart syntax */
{
t = rd_args(token);
break;
}
if (isprefix(token, &lp, &k))
{
t = term_copy(get_functor(token, 1));
if (rd_token() == TSPECIAL &&
((char)token != '(' &&
(char)token != '{' &&
(char)token != '[')
|| token_type == TDOT) /* missing arg */
{
if (lp > prio)
syntax_error("Priority conflict");
valid_token = TRUE;
ARG(t,0)=(term *)get_functor(NAME(t),0);
break;
}
valid_token = TRUE;
p = rd_term(k);
if (FUNC(t) == MINUSFUNCTOR && ISINT(p))
{
VALUE(p) = VALUE(p)*-1;
t = p;
}
else
ARG(t,1) = p;
break;
}
t = term_copy(get_functor(token, 0));
break;
case TINTEGER:
t = (term *)token;
break;
case TVARIABLE:
t = (term *)token;
break;
case TSTRING:
t = rd_string(token);
break;
case TSPECIAL:
if ((char)token == '(')
{
t = rd_term(255);
if (rd_token() != TSPECIAL||(char)token != ')')
syntax_error("Missing bracket");
break;
}
if ((char)token == '[')
{
t = rd_list();
if (rd_token() != TSPECIAL ||
(char)token != ']')
syntax_error("Missing bracket");
break;
}
if ((char)token == '{')
{
p = rd_term(255);
if (rd_token() != TSPECIAL || (char)token!='}')
syntax_error("Missing bracket");
t = term_copy(ASSERTFUNCTOR);
ARG(t,1) = p;
break;
}
case TDOT:
syntax_error("Unexpected end of term");
return(NULL);
}
while (TRUE)
{
if (c_errno)
return(NULL);
if (rd_token() == TSYMBOL)
{
if (isinfix(token, &i, &j, &k))
{
if (i <= prio && j >= lp)
{
p = term_copy(get_functor(token, 2));
ARG(p,1) = t;
t = p;
ARG(t,2) = rd_term(k);
lp = i;
continue;
}
}
if (ispostfix(token, &j, &k))
{
if (j <= prio && k >= lp)
{
p = term_copy(get_functor(token, 1));
ARG(p,1) = t;
t = p;
lp = j;
continue;
}
}
valid_token = TRUE;
return(t);
}
if (token_type == TDOT)
{
valid_token = TRUE;
return(t);
}
if (token_type != TSPECIAL || (char)token == '('
|| (char)token == '[')
{
syntax_error("Misplaced bracket");
return(NULL);
}
if ((char)token == ',' && prio >= 253 && lp <=252)
{
p = term_copy(COMMAFUNCTOR);
ARG(p,1) = t;
t = p;
ARG(t,2) = rd_term(253);
lp = 253;
if (lp < prio)
continue;
return(t);
}
valid_token = TRUE;
return(t);
}
}
/* The primitive for the BI read */
term *read_term()
{
term *t;
term *oldtop, *oldnext; /* old proto heigth */
oldtop = copytop;
oldnext = copynext;
tide = 0; /* no variables read */
p = line;
*p = '\0'; /* no input term */
valid_token = FALSE; /* no token read so far */
if (setjmp(hop)) /* we returned from a longjmp */
{
copynext = oldnext;
copytop = oldtop;
if (!c_errno)
c_errno = EIO;
return(NULL);
}
if (!rd_line()) /* error while reading */
return(NULL);
rd_char();
t = rd_term(255);
if (rd_token() != TDOT)
syntax_error("Missing end of term");
if (c_errno)
{
copynext = oldnext;
copytop = oldtop;
return(NULL);
}
else
return(t);
}