/* ----------------------------------------------------------
% (C)1992 Institute for New Generation Computer Technology
% (Read COPYRIGHT for detailed information.)
----------------------------------------------------------- */
/*=====================================================================
* cu-Prolog III (Constraint Unification Prolog)
* Copyright: Institute for New Generation Computer Technology,Japan
* 1989--91
==================================================================== */
/*--------------------------------------------------------------------
* <<<< read.c >>>>
* input routines
* 94.8.10 unsigned char for Kanji input
--------------------------------------------------------------------*/
#include "include.h"
/* Classification of Characters */
#define BL 001 /* blank */
#define UC 002 /* Upper Character */
#define LC 003 /* Lower Character */
#define UL 004 /* UnderLine */
#define N 005 /* Numeric */
#define SG 006 /* sign, +- */
#define SP 007 /* special character */
#define Q 010 /* single/double quote */
#define CT 011 /* Cut */
#define CM 012 /* comment character */
#define BR 013 /* Brackets, Commas */
#define CO 014 /* Constraint Marker */
#define kanzi(CH) (CH > 128) /* for EUC */
#define alpha (kanzi(cbuf) || ((UC <= char_type[cbuf]) && \
(char_type[cbuf] <= N)))
/* special characters are #$%&*+-/:<=>?@\^|~ */
#define specialchar(C) ((! kanzi(C)) && ((char_type[C] == SG) || \
(char_type[C] == SP)))
#define delimitchar(C) ((! kanzi(C)) && ((char_type[C] >= BR) || (C == '.')))
#define bracket(C) ((! kanzi(C)) && (char_type[C] == BR))
#define quotesign ((! kanzi(cbuf)) && (char_type[cbuf] == Q))
#define white ((! kanzi(cbuf)) && (char_type[cbuf] == BL))
#define numeric(X) ((X == '-') || ((! kanzi(X)) && (char_type[X]==N)))
#define isdigit(X) ((! kanzi(X)) && (char_type[X]==N))
#define isxdigit(X) ((! kanzi(X)) && ((char_type[X]==N) || \
((char_type[X] == LC) && ('a' <= X) && (X <= 'f')) || \
((char_type[X] == UC) && ('A' <= X) && (X <= 'F'))))
#define is_varname(X) ((X == '_') || ((! kanzi(X)) && (char_type[X]==UC)))
#define notconst_list(L) (((struct clause *)L)->c_type != CONST_LIST_TYPE)
#define isconst_list(L) (((struct clause *)L)->c_type == CONST_LIST_TYPE)
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++
Rterm(num,flag)
general read routine entry
num: operator strength
flag: heap mode (TEMPORAL,ETERNAL,...)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
struct term *Rterm(n,flag)
int n,flag;
{
int m = 0;
struct term *Rterm_half(),*Rterm_leftover();
struct term *t = Rterm_half(n,flag,&m);
t = Rterm_leftover(n,m,flag,t);
if ((is_clause(t)) && (((struct clause *)t)->c_link == NULL))
return(((struct clause *)t)->c_form);
return(t);
}
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++
next()
get next char into cbuf (global char register)
+++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
void next()
{
if (feof(fp))
{
clearerr(fp);
cbuf = EOF;
return;
}
if (ferror(fp))
{
clearerr(fp);
error("input error !");
}
cbuf = getc(fp);
if (lfp) putc(cbuf,lfp); /* log file */
if (ECHO_BACK) putc(cbuf, wfp);
}
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++
int check(c)
check whether next input is c
+++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
int check(c) /* check if c is cbuf */
char c;
{
if(cbuf == c) {
advance;
return(TRUE);
} else
return(FALSE);
}
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++
int keyread(a)
check whether user's input is 'a....\n'
+++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
int keyread(a)
char a;
{
int c,c1;
c = c1 = getchar();
while (c1 != '\n') c1 = getchar();
if (lfp) fprintf(lfp,"\n");
if (c == a) return(TRUE);
else return(FALSE);
}
void adv() /* skip white and set the next char into cbuf */
{
while(white)
next();
}
int skip(c) /* skip c */
char c;
{
if(cbuf != c){
wfp = stderr;
tprint2("\n '%c' <-> '%c'", cbuf, c);
error(" illegal character ");
}
advance;
return(cbuf);
}
int alldigit(c)
register unsigned char *c;
{
if ( c[0] >= 0x80 ) return(FALSE);
if (! numeric(*c)) return(FALSE);
for( c++ ; *c!='\0' ; c++ )
if (! isdigit(*c)) return(FALSE);
return(TRUE);
}
void read_hexa(i)
register int i;
{
for(i=0; isxdigit(cbuf); next())
if (i < NAMELEN_MAX) nbuf[i++]=cbuf;
nbuf[i]='\0';
}
void read_digits(i)
register int i;
{
for( ; isdigit(cbuf); next())
if (i < NAMELEN_MAX) nbuf[i++] = cbuf;
if (cbuf=='.')
do
{ nbuf[i++] = cbuf;
next();
} while((isdigit(cbuf)) && (i < NAMELEN_MAX));
if ((cbuf == 'e') || (cbuf == 'E')) {
nbuf[i++] = 'E';
next();
if ((cbuf == '-') || isdigit(cbuf))
do
{ nbuf[i++] = cbuf;
next();
} while((isdigit(cbuf)) && (i < NAMELEN_MAX));
}
nbuf[i]='\0';
}
void read_comments()
{
while (1) {
next();
if (cbuf == '*') {
next();
if (cbuf == '/') {advance; return;}
}
}
}
void read_spechar(i)
register int i;
{
while (specialchar(cbuf) && (i < NAMELEN_MAX)) {
nbuf[i++] = cbuf;
next();
}
nbuf[i]='\0';
}
int Rtoken() /* read name into nbuf[] */
{
if (reread) {
reread = FALSE;
return(tokentype);
}
adv();
if (cbuf==EOF) {
set_eof();
error("unexpected End Of File");
}
if (bracket(cbuf)) /* ()[]{}|, */
{
if (cbuf==',') return(tokentype = COMMA);
nbuf[0] = cbuf;
nbuf[1] = '\0';
return(tokentype = BRACKET);
}
if (! kanzi(cbuf)) {
/* if (char_type[cbuf] == CO) return(tokentype = CONST_MARK); */
if (char_type[cbuf] == CM) {
skipline;
return(Rtoken());
}
}
tokentype = NAME;
if (isdigit(cbuf))
{
read_digits(0);
return(tokentype = NUMBER);
}
if (alpha) {
register int i = 0;
if (is_varname(cbuf)) tokentype = VARNAME;
while(alpha && (i < NAMELEN_MAX)){
if (kanzi(cbuf)) {
nbuf[i++] = cbuf;
next();
}
nbuf[i++] = cbuf;
next();
}
nbuf[i]='\0';
return(tokentype);
}
if (quotesign) {
register char temp = cbuf;
register int i;
if (temp == '\"') tokentype = STRING;
next();
for (i = 0; i < NAMELEN_MAX; next()) {
if (cbuf != temp) nbuf[i++]=cbuf;
else {
next();
if (cbuf == temp) nbuf[i++]=cbuf;
else break;
}
}
if (i >= NAMELEN_MAX) {
nbuf[i]='\0';
wfp = stderr;
sprintf(nbuf,">>> %s <<<",nbuf);
error("too long string/name");
}
nbuf[i]='\0';
return(tokentype);
}
if (cbuf == '!') {
nbuf[0] = cbuf;
nbuf[1] = '\0';
next();
return(tokentype);
}
if (char_type[cbuf] == CO) {
nbuf[0] = cbuf;
nbuf[1] = '\0';
next();
return(tokentype);
}
if (specialchar(cbuf)) {
register int i = 0;
nbuf[i++] = cbuf;
next();
switch (nbuf[0]) {
case '-':
if (isdigit(cbuf)) {
tokentype = NUMBER;
read_digits(i);
}
else read_spechar(i);
break;
case '/':
if (cbuf == '*') {
read_comments();
return(Rtoken());
}
else read_spechar(i);
break;
case '#':
if (isxdigit(cbuf)) {
tokentype = FILE_TYPE;
read_hexa(i);
}
else read_spechar(i);
break;
case '.':
if (white) tokentype = FULLSTOP;
else read_spechar(i);
break;
default:
read_spechar(i);
}
}
else {
sprintf(nbuf,"Illegal Character:>>> %c <<<",cbuf);
error(nbuf);
}
return(tokentype);
}
struct term *Rlist(flag) /* read list */
int flag;
{
register struct term *v;
register struct clause *c;
int ac;
advance; /* skip [ */
if (cbuf == ']') { /* [] */
return(NIL);
}
/* read the first argument */
c = Nlist(Rterm(999,flag),(struct clause *)NIL,flag);
ac = c->c_type;
switch (Rtoken()) {
case COMMA:
c->c_link = (struct clause *)Rlist(flag);
if (notconst_list(c->c_link)) c->c_type = LIST_TYPE;
return((struct term *)c);
case BRACKET:
if (nbuf[0]=='|') {
advance;
v = Rterm(999,flag);
c->c_link = (struct clause *)v;
if (isvar(v) || notconst_list(v))
c->c_type = LIST_TYPE;
return((struct term *)c);
}
else {
reread = TRUE;
return((struct term *)c);
}
default: error("Illegal list : ? ");
}
}
struct term *Rpst(flag) /* pst */
int flag;
{
struct term *p = (struct term *)Npst(flag);
struct term *t;
struct eclause *pobj = NULL_ECL;
while (1) {
advance;
if (cbuf == '}') return(p);
t = Rterm(999, flag);
if (Pred(t) != PNAME_P) {
error_detail(t,NULL_ENV,
"Illegal PST: Delimiter of PST should be '/'");
}
if ((! is_functor(Arg1(t)) || (Arg1(t)->t_arity != 0))) {
error_detail(t,NULL_ENV,
"Illegal PST: PNAME of PST should be ATOM");
}
pobj = insert_pstobj(t,pobj,flag);
switch (Rtoken()) {
case COMMA:
break;
case BRACKET:
reread = TRUE;
((struct pst *)p)->p_lists = pobj;
return(p);
default:
sprintf(nbuf,"Illegal pst : >>> %c <<<",cbuf);
error(nbuf);
}
}
}
struct eclause *insert_pstobj(val,tail,flag)
struct term *val;
struct eclause *tail;
int flag;
{
struct eclause *pre, *ptop = tail;
register int f,i;
if (! is_functor(Arg1(val))) {
error_detail(Arg1(val),NULL_ENV,
"Illegal Property name for PST");
}
if (tail == NULL_ECL)
return(Npstobj(val,NULL_ENV,tail,flag));
pre = tail;
f = Pred(Arg1(val))->f_number;
while (tail != NULL_ECL) {
i = Pred(Arg1(tail->c_form))->f_number - f;
if (i > 0) {
if (pre == tail) return(Npstobj(val,NULL_ENV,tail,flag));
else break;
}
if (i==0) {
wfp = stderr;
Pterm(Arg1(tail->c_form),NULL_ENV); NL;
Pterm(Arg1(val),NULL_ENV);
error("ERROR: There are same PNAMES in PST");
}
pre = tail;
tail = tail->c_link;
}
pre->c_link = Npstobj(val,NULL_ENV,tail,flag);
return(ptop);
}
int is_term_end(c)
register char c;
{
switch(c) {
case '.':
case ')':
case '|' :
case ',':
case ';':
case ']': return(TRUE);
default: return(FALSE);
}
}
int prefix_is_atom(m)
int m;
{
switch(tokentype) {
case FULLSTOP: return(TRUE);
case COMMA:
case BRACKET:
return(is_term_end(nbuf[0]));
case NAME: {
register struct operator *o;
if ((o = op_search(nbuf,INFIX)) != NULL)
if ((o->o_prec - ((o->o_type & 0010) != 0)) >= m) return(TRUE);
if ((o = op_search(nbuf,POSTFIX)) != NULL)
if ((o->o_prec - ((o->o_type & 0010) != 0)) >= m) return(TRUE);
}
default: return(FALSE);
}
}
struct term *Rterm_half(n,flag,m)
int n, flag, *m;
{
register struct term *t;
char tempname[NAMELEN_MAX];
int ac = CONSTANT_TERM;
switch (Rtoken()) {
case BRACKET:
switch (nbuf[0]) {
case '[':
t = ((struct term *)Rlist(flag));
if ((Rtoken() != BRACKET) || nbuf[0] != ']') {
error_detail(t,NULL_ENV,"Syntax error --- ] missing");
}
advance;
return(t);
case '(':
advance;
t = Rterm(1200,flag);
if ((Rtoken() != BRACKET) || nbuf[0] != ')') {
error_detail(t,NULL_ENV,"Syntax error --- ) missing");
}
advance;
if (is_clause(t)) {
struct clause *c = (struct clause *)t;
return((c->c_link == NULL) ? c->c_form : t);
}
else return(t);
case '{':
t = (struct term *)Rpst(flag);
if ((Rtoken() != BRACKET) || nbuf[0] != '}') {
error_detail(t,NULL_ENV,"Syntax error --- } missing");
}
advance;
return(t);
default :
sprintf(nbuf,"Syntax Error: unexpected >>> %c <<<",nbuf[0]);
error(nbuf);
}
case VARNAME: /* variable */
if (streq(nbuf, "_")) return(Anonymous_var);
if((t = varsearch(nbuf))==NULL)
return(Nvar(nbuf,flag));
else return(t);
case NUMBER: /* number */
return(Nnum(nbuf,flag));
case STRING: /* string */
return(Nstr(nbuf,flag));
case FILE_TYPE: { /* file pointer */
int pt;
sscanf(nbuf,"%x",&pt);
return(Nfile((FILE *)pt));
}
case NAME: /* name */
strcpy(tempname,nbuf); /* tempname <- nbuf */
/* constant or functor */
if (check('(')) {
register int i,arity = 0;
struct clause *temp, *argstack;
argstack = temp
= Nclause(NULL_TERM,NULL_CL,TEMPORAL);
while(1) {
reread = FALSE; /* read term */
t = Rterm(999,flag);
if (notconst(t)) ac = NOT_CONSTANT_TERM;
temp->c_link = Nclause(t,NULL_CL,TEMPORAL);
temp = temp->c_link;
arity++;
if (tokentype != COMMA) break;
advance;
}
skip(')');
t = Nterm(arity,flag);
if (ac==CONSTANT_TERM) t->t_arity = -arity;
t->type.t_func = Predicate(tempname,arity);
temp = argstack;
for(i=0; i < arity; i++) {
temp = temp->c_link;
t->tag.t_arg[i] = temp->c_form;
}
return(t);
}
{
struct operator *o;
if ((o = op_search(tempname, PREFIX)) == NULL) {
t = Nterm(0,flag);
t->type.t_func = Predicate(tempname,0);
return(t);
}
if (o->o_prec > n) {
sprintf(nbuf,"Syntax Error:>>> %s <<<",tempname);
error(nbuf);
}
Rtoken();
reread=TRUE;
if (prefix_is_atom(o->o_prec)) {
if (*m > n) error("Syntax error");
t = Nterm(0,flag);
t->type.t_func = Predicate(tempname,0);
return(t);
}
(t = Nterm(1,flag))->type.t_func = o->o_func;
Arg1(t) = Rterm((o->o_prec - o->o_type + PREFIX),flag);
*m = o->o_prec;
if (isconst(Arg1(t))) t->t_arity = -t->t_arity;
return(t);
}
default: /* else */
sprintf(nbuf,"Syntax error --- unexpected %c",cbuf);
error(nbuf);
}
}
struct term *Rterm_leftover(n,m,flag,t)
register int n,flag,m;
struct term *t;
{
struct operator *o;
int ac = (notconst(t)) ? NOT_CONSTANT_TERM : CONSTANT_TERM;
switch(Rtoken()) {
case NAME:
reread=FALSE;
if ((o = op_search(nbuf,INFIX)) != NULL) {
if ((o->o_prec <= n) &&
((o->o_prec - ((o->o_type & 0010) ? 1 : 0)) >= m)) {
struct term *tt = Nterm(2,flag);
tt->type.t_func = o->o_func;
Arg1(tt) = t;
Arg2(tt) = Rterm(o->o_prec - (o->o_type & 0001), flag);
if ((ac == CONSTANT_TERM) && (isconst(Arg2(tt))))
tt->t_arity = -tt->t_arity;
return(Rterm_leftover(n,o->o_prec,flag,tt));
}
}
if ((o = op_search(nbuf,POSTFIX)) != NULL) {
if ((o->o_prec <= n) &&
(o->o_prec >= (m + ((o->o_type & 0010) ? 1 : 0)))) {
struct term *tt = Nterm(1,flag);
tt->type.t_func = o->o_func;
Arg1(tt) = t;
if (ac == CONSTANT_TERM) tt->t_arity = -tt->t_arity;
return(Rterm_leftover(n,o->o_prec,flag,tt));
}
}
case FULLSTOP:
reread = TRUE;
return(t);
case BRACKET:
switch(nbuf[0]) {
case '(':
case '[':
sprintf(nbuf,"Syntax Error:>>> %c <<<",nbuf[0]);
error(nbuf);
}
return(t);
case COMMA:
if ((n >= 1000) && (m < 1000)) {
struct term *tt;
advance;
tt = Rterm(1000,flag);
reread = TRUE;
if (! is_clause(tt))
tt=(struct term *)Nclause(tt,NULL_CL,flag);
t = (struct term *)Nclause(t,(struct clause *)tt,flag);
if (n > 1000)
return(Rterm_leftover(n,1000,flag,t));
}
default:
return(t);
}
}
syntax highlighted by Code2HTML, v. 0.9.1