#include "defs"
#include "tokdefs"

# define BLANK	' '
# define MYQUOTE (2)
# define SEOF 0

/* card types */

# define STEOF 1
# define STINITIAL 2
# define STCONTINUE 3

/* lex states */

#define NEWSTMT	1
#define FIRSTTOKEN	2
#define OTHERTOKEN	3
#define RETEOS	4


LOCAL int stkey;
LOCAL int lastend = 1;
ftnint yystno;
flag intonly;
LOCAL long int stno;
LOCAL long int nxtstno;
LOCAL int parlev;
LOCAL int expcom;
LOCAL int expeql;
LOCAL char *nextch;
LOCAL char *lastch;
LOCAL char *nextcd 	= NULL;
LOCAL char *endcd;
LOCAL int prevlin;
LOCAL int thislin;
LOCAL int code;
LOCAL int lexstate	= NEWSTMT;
LOCAL char s[1390];
LOCAL char *send	= s+20*66;
LOCAL int nincl	= 0;
LOCAL int getcds(), getcd(), crunch(), analyz(), getkwd(), gettok();

struct Inclfile
{
	struct Inclfile *inclnext;
	FILEP inclfp;
	char *inclname;
	int incllno;
	char *incllinp;
	int incllen;
	int inclcode;
	ftnint inclstno;
};

LOCAL struct Inclfile *inclp	=  NULL;
LOCAL struct Keylist { 
	char *keyname; 
	int keyval; 
	char notinf66; 
};
LOCAL struct Punctlist { 
	char punchar; 
	int punval; 
};
LOCAL struct Fmtlist { 
	char fmtchar; 
	int fmtval; 
};
LOCAL struct Dotlist { 
	char *dotname; 
	int dotval; 
};
LOCAL struct Keylist *keystart[26], *keyend[26];




inilex(name)
char *name;
{
	nincl = 0;
	inclp = NULL;
	doinclude(name);
	lexstate = NEWSTMT;
	return(NO);
}



/* throw away the rest of the current line */
flline()
{
	lexstate = RETEOS;
}



char *lexline(n)
int *n;
{
	*n = (lastch - nextch) + 1;
	return(nextch);
}





doinclude(name)
char *name;
{
	FILEP fp;
	struct Inclfile *t;
	char temp[100];
	register char *lastslash, *s;

	if(inclp)
	{
		inclp->incllno = thislin;
		inclp->inclcode = code;
		inclp->inclstno = nxtstno;
		if(nextcd)
			inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
		else
			inclp->incllinp = 0;
	}
	nextcd = NULL;

	if(++nincl >= MAXINCLUDES)
		fatal("includes nested too deep");
	if(name[0] == '\0')
		fp = stdin;
	else if(name[0]=='/' || inclp==NULL)
		fp = fopen(name, "r");
	else	{
		lastslash = NULL;
		for(s = inclp->inclname ; *s ; ++s)
			if(*s == '/')
				lastslash = s;
		if(lastslash)
		{
			*lastslash = '\0';
			sprintf(temp, "%s/%s", inclp->inclname, name);
			*lastslash = '/';
		}
		else
			strcpy(temp, name);

		if( (fp = fopen(temp, "r")) == NULL )
		{
			sprintf(temp, "/usr/include/%s", name);
			fp = fopen(temp, "r");
		}
		if(fp)
			name = copys(temp);
	}

	if( fp )
	{
		t = inclp;
		inclp = ALLOC(Inclfile);
		inclp->inclnext = t;
		prevlin = thislin = 0;
		infname = inclp->inclname = name;
		infile = inclp->inclfp = fp;
	}
	else
	{
		fprintf(diagfile, "Cannot open file %s", name);
		done(1);
	}
}




LOCAL popinclude()
{
	struct Inclfile *t;
	register char *p;
	register int k;

	if(infile != stdin)
		clf(&infile);
	free(infname);

	--nincl;
	t = inclp->inclnext;
	free( (charptr) inclp);
	inclp = t;
	if(inclp == NULL)
		return(NO);

	infile = inclp->inclfp;
	infname = inclp->inclname;
	prevlin = thislin = inclp->incllno;
	code = inclp->inclcode;
	stno = nxtstno = inclp->inclstno;
	if(inclp->incllinp)
	{
		endcd = nextcd = s;
		k = inclp->incllen;
		p = inclp->incllinp;
		while(--k >= 0)
			*endcd++ = *p++;
		free( (charptr) (inclp->incllinp) );
	}
	else
		nextcd = NULL;
	return(YES);
}




yylex()
{
	static int  tokno;

	switch(lexstate)
	{
	case NEWSTMT :	/* need a new statement */
		if(getcds() == STEOF)
			return(SEOF);
		lastend =  stkey == SEND;
		crunch();
		tokno = 0;
		lexstate = FIRSTTOKEN;
		yystno = stno;
		stno = nxtstno;
		toklen = 0;
		return(SLABEL);

first:
	case FIRSTTOKEN :	/* first step on a statement */
		analyz();
		lexstate = OTHERTOKEN;
		tokno = 1;
		return(stkey);

	case OTHERTOKEN :	/* return next token */
		if(nextch > lastch)
			goto reteos;
		++tokno;
		if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
			goto first;

		if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
		    nextch[0]=='t' && nextch[1]=='o')
		{
			nextch+=2;
			return(STO);
		}
		return(gettok());

reteos:
	case RETEOS:
		lexstate = NEWSTMT;
		return(SEOS);
	}
	fatali("impossible lexstate %d", lexstate);
	/* NOTREACHED */
}

LOCAL getcds()
{
	register char *p, *q;

top:
	if(nextcd == NULL)
	{
		code = getcd( nextcd = s );
		stno = nxtstno;
		prevlin = thislin;
	}
	if(code == STEOF)
		if( popinclude() )
			goto top;
		else
			return(STEOF);

	if(code == STCONTINUE)
	{
		lineno = thislin;
		err("illegal continuation card ignored");
		nextcd = NULL;
		goto top;
	}

	if(nextcd > s)
	{
		q = nextcd;
		p = s;
		while(q < endcd)
			*p++ = *q++;
		endcd = p;
	}
	for(nextcd = endcd ;
	    nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ;
	    nextcd = endcd )
		;
	nextch = s;
	lastch = nextcd - 1;
	if(nextcd >= send)
		nextcd = NULL;
	lineno = prevlin;
	prevlin = thislin;
	return(STINITIAL);
}

LOCAL getcd(b)
register char *b;
{
	register int c;
	register char *p, *bend;
	int speclin;
	static char a[6];
	static char *aend	= a+6;

top:
	endcd = b;
	bend = b+66;
	speclin = NO;

	if( (c = getc(infile)) == '&')
	{
		a[0] = BLANK;
		a[5] = 'x';
		speclin = YES;
		bend = send;
	}
	else if(c=='c' || c=='C' || c=='*')
	{
		while( (c = getc(infile)) != '\n')
			if(c == EOF)
				return(STEOF);
		++thislin;
		goto top;
	}

	else if(c != EOF)
	{
		/* a tab in columns 1-6 skips to column 7 */
		ungetc(c, infile);
		for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
			if(c == '\t')
			{
				while(p < aend)
					*p++ = BLANK;
				speclin = YES;
				bend = send;
			}
			else
				*p++ = c;
	}
	if(c == EOF)
		return(STEOF);
	if(c == '\n')
	{
		while(p < aend)
			*p++ = BLANK;
		if( ! speclin )
			while(endcd < bend)
				*endcd++ = BLANK;
	}
	else	{	/* read body of line */
		while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
			*endcd++ = c;
		if(c == EOF)
			return(STEOF);
		if(c != '\n')
		{
			while( (c=getc(infile)) != '\n')
				if(c == EOF)
					return(STEOF);
		}

		if( ! speclin )
			while(endcd < bend)
				*endcd++ = BLANK;
	}
	++thislin;
	if( !isspace(a[5]) && a[5]!='0')
		return(STCONTINUE);
	for(p=a; p<aend; ++p)
		if( !isspace(*p) ) goto initline;
	for(p = b ; p<endcd ; ++p)
		if( !isspace(*p) ) goto initline;
	goto top;

initline:
	nxtstno = 0;
	for(p = a ; p<a+5 ; ++p)
		if( !isspace(*p) )
			if(isdigit(*p))
				nxtstno = 10*nxtstno + (*p - '0');
			else	{
				lineno = thislin;
				err("nondigit in statement number field");
				nxtstno = 0;
				break;
			}
	return(STINITIAL);
}

LOCAL crunch()
{
	register char *i, *j, *j0, *j1, *prvstr;
	int ten, nh, quote;

	/* i is the next input character to be looked at
j is the next output character */
	parlev = 0;
	expcom = 0;	/* exposed ','s */
	expeql = 0;	/* exposed equal signs */
	j = s;
	prvstr = s;
	for(i=s ; i<=lastch ; ++i)
	{
		if(isspace(*i) )
			continue;
		if(*i=='\'' ||  *i=='"')
		{
			quote = *i;
			*j = MYQUOTE; /* special marker */
			for(;;)
			{
				if(++i > lastch)
				{
					err("unbalanced quotes; closing quote supplied");
					break;
				}
				if(*i == quote)
					if(i<lastch && i[1]==quote) ++i;
					else break;
				else if(*i=='\\' && i<lastch)
					switch(*++i)
					{
					case 't':
						*i = '\t'; 
						break;
					case 'b':
						*i = '\b'; 
						break;
					case 'n':
						*i = '\n'; 
						break;
					case 'f':
						*i = '\f'; 
						break;
					case 'v':
						*i = '\v'; 
						break;
					case '0':
						*i = '\0'; 
						break;
					default:
						break;
					}
				*++j = *i;
			}
			j[1] = MYQUOTE;
			j += 2;
			prvstr = j;
		}
		else if( (*i=='h' || *i=='H')  && j>prvstr)	/* test for Hollerith strings */
		{
			if( ! isdigit(j[-1])) goto copychar;
			nh = j[-1] - '0';
			ten = 10;
			j1 = prvstr - 1;
			if (j1<j-5) j1=j-5;
			for(j0=j-2 ; j0>j1; -- j0)
			{
				if( ! isdigit(*j0 ) ) break;
				nh += ten * (*j0-'0');
				ten*=10;
			}
			if(j0 <= j1) goto copychar;
			/* a hollerith must be preceded by a punctuation mark.
   '*' is possible only as repetition factor in a data statement
   not, in particular, in character*2h
*/

			if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' &&
			    *j0!=',' && *j0!='=' && *j0!='.')
				goto copychar;
			if(i+nh > lastch)
			{
				erri("%dH too big", nh);
				nh = lastch - i;
			}
			j0[1] = MYQUOTE; /* special marker */
			j = j0 + 1;
			while(nh-- > 0)
			{
				if(*++i == '\\')
					switch(*++i)
					{
					case 't':
						*i = '\t'; 
						break;
					case 'b':
						*i = '\b'; 
						break;
					case 'n':
						*i = '\n'; 
						break;
					case 'f':
						*i = '\f'; 
						break;
					case '0':
						*i = '\0'; 
						break;
					default:
						break;
					}
				*++j = *i;
			}
			j[1] = MYQUOTE;
			j+=2;
			prvstr = j;
		}
		else	{
			if(*i == '(') ++parlev;
			else if(*i == ')') --parlev;
			else if(parlev == 0)
				if(*i == '=') expeql = 1;
				else if(*i == ',') expcom = 1;
copychar:		/*not a string or space -- copy, shifting case if necessary */
			if(shiftcase && isupper(*i))
				*j++ = tolower(*i);
			else	*j++ = *i;
		}
	}
	lastch = j - 1;
	nextch = s;
}

LOCAL analyz()
{
	register char *i;

	if(parlev != 0)
	{
		err("unbalanced parentheses, statement skipped");
		stkey = SUNKNOWN;
		return;
	}
	if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
	{
		/* assignment or if statement -- look at character after balancing paren */
		parlev = 1;
		for(i=nextch+3 ; i<=lastch; ++i)
			if(*i == (MYQUOTE))
			{
				while(*++i != MYQUOTE)
					;
			}
			else if(*i == '(')
				++parlev;
			else if(*i == ')')
			{
				if(--parlev == 0)
					break;
			}
		if(i >= lastch)
			stkey = SLOGIF;
		else if(i[1] == '=')
			stkey = SLET;
		else if( isdigit(i[1]) )
			stkey = SARITHIF;
		else	stkey = SLOGIF;
		if(stkey != SLET)
			nextch += 2;
	}
	else if(expeql) /* may be an assignment */
	{
		if(expcom && nextch<lastch &&
		    nextch[0]=='d' && nextch[1]=='o')
		{
			stkey = SDO;
			nextch += 2;
		}
		else	stkey = SLET;
	}
	/* otherwise search for keyword */
	else	{
		stkey = getkwd();
		if(stkey==SGOTO && lastch>=nextch)
			if(nextch[0]=='(')
				stkey = SCOMPGOTO;
			else if(isalpha(nextch[0]))
				stkey = SASGOTO;
	}
	parlev = 0;
}



LOCAL getkwd()
{
	register char *i, *j;
	register struct Keylist *pk, *pend;
	int k;

	if(! isalpha(nextch[0]) )
		return(SUNKNOWN);
	k = nextch[0] - 'a';
	if(pk = keystart[k])
		for(pend = keyend[k] ; pk<=pend ; ++pk )
		{
			i = pk->keyname;
			j = nextch;
			while(*++i==*++j && *i!='\0')
				;
			if(*i=='\0' && j<=lastch+1)
			{
				nextch = j;
				if(no66flag && pk->notinf66)
					errstr("Not a Fortran 66 keyword: %s",
					    pk->keyname);
				return(pk->keyval);
			}
		}
	return(SUNKNOWN);
}



LOCAL struct Dotlist  dots[ ] =
{
	"and.", SAND, 
	    "or.", SOR, 
	    "not.", SNOT, 
	    "true.", STRUE, 
	    "false.", SFALSE, 
	    "eq.", SEQ, 
	    "ne.", SNE, 
	    "lt.", SLT, 
	    "le.", SLE, 
	    "gt.", SGT, 
	    "ge.", SGE, 
	    "neqv.", SNEQV, 
	    "eqv.", SEQV, 
	    0, 0 };

LOCAL struct Keylist  keys[ ] =
{
	{ "assign",  SASSIGN  },
	{ "automatic",  SAUTOMATIC, YES  },
	{ "backspace",  SBACKSPACE  },
	{ "blockdata",  SBLOCK  },
	{ "call",  SCALL  },
	{ "character",  SCHARACTER, YES  },
	{ "close",  SCLOSE, YES  },
	{ "common",  SCOMMON  },
	{ "complex",  SCOMPLEX  },
	{ "continue",  SCONTINUE  },
	{ "data",  SDATA  },
	{ "dimension",  SDIMENSION  },
	{ "doubleprecision",  SDOUBLE  },
	{ "doublecomplex", SDCOMPLEX, YES  },
	{ "elseif",  SELSEIF, YES  },
	{ "else",  SELSE, YES  },
	{ "endfile",  SENDFILE  },
	{ "endif",  SENDIF, YES  },
	{ "end",  SEND  },
	{ "entry",  SENTRY, YES  },
	{ "equivalence",  SEQUIV  },
	{ "external",  SEXTERNAL  },
	{ "format",  SFORMAT  },
	{ "function",  SFUNCTION  },
	{ "goto",  SGOTO  },
	{ "implicit",  SIMPLICIT, YES  },
	{ "include",  SINCLUDE, YES  },
	{ "inquire",  SINQUIRE, YES  },
	{ "intrinsic",  SINTRINSIC, YES  },
	{ "integer",  SINTEGER  },
	{ "logical",  SLOGICAL  },
	{ "namelist", SNAMELIST, YES },
	{ "none", SUNDEFINED, YES },
	{ "open",  SOPEN, YES  },
	{ "parameter",  SPARAM, YES  },
	{ "pause",  SPAUSE  },
	{ "print",  SPRINT  },
	{ "program",  SPROGRAM, YES  },
	{ "punch",  SPUNCH, YES  },
	{ "read",  SREAD  },
	{ "real",  SREAL  },
	{ "return",  SRETURN  },
	{ "rewind",  SREWIND  },
	{ "save",  SSAVE, YES  },
	{ "static",  SSTATIC, YES  },
	{ "stop",  SSTOP  },
	{ "subroutine",  SSUBROUTINE  },
	{ "then",  STHEN, YES  },
	{ "undefined", SUNDEFINED, YES  },
	{ "write",  SWRITE  },
	{ 0, 0 }
};	


initkey()
{
	register struct Keylist *p;
	register int i,j;

	for(i = 0 ; i<26 ; ++i)
		keystart[i] = NULL;

	for(p = keys ; p->keyname ; ++p)
	{
		j = p->keyname[0] - 'a';
		if(keystart[j] == NULL)
			keystart[j] = p;
		keyend[j] = p;
	}
}

LOCAL gettok()
{
	int havdot, havexp, havdbl;
	int radix, val;
	extern struct Punctlist puncts[];
	struct Punctlist *pp;
	extern struct Fmtlist fmts[];
	struct Dotlist *pd;

	char *i, *j, *n1, *p;

	if(*nextch == (MYQUOTE))
	{
		++nextch;
		p = token;
		while(*nextch != MYQUOTE)
			*p++ = *nextch++;
		++nextch;
		toklen = p - token;
		*p = '\0';
		return (SHOLLERITH);
	}
	/*
	if(stkey == SFORMAT)
		{
		for(pf = fmts; pf->fmtchar; ++pf)
			{
			if(*nextch == pf->fmtchar)
				{
				++nextch;
				if(pf->fmtval == SLPAR)
					++parlev;
				else if(pf->fmtval == SRPAR)
					--parlev;
				return(pf->fmtval);
				}
			}
		if( isdigit(*nextch) )
			{
			p = token;
			*p++ = *nextch++;
			while(nextch<=lastch && isdigit(*nextch) )
				*p++ = *nextch++;
			toklen = p - token;
			*p = '\0';
			if(nextch<=lastch && *nextch=='p')
				{
				++nextch;
				return(SSCALE);
				}
			else	return(SICON);
			}
		if( isalpha(*nextch) )
			{
			p = token;
			*p++ = *nextch++;
			while(nextch<=lastch &&
				(*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) ))
					*p++ = *nextch++;
			toklen = p - token;
			*p = '\0';
			return(SFIELD);
			}
		goto badchar;
		}
/* Not a format statement */

	if(needkwd)
	{
		needkwd = 0;
		return( getkwd() );
	}

	for(pp=puncts; pp->punchar; ++pp)
		if(*nextch == pp->punchar)
		{
			if( (*nextch=='*' || *nextch=='/') &&
			    nextch<lastch && nextch[1]==nextch[0])
			{
				if(*nextch == '*')
					val = SPOWER;
				else	val = SCONCAT;
				nextch+=2;
			}
			else	{
				val = pp->punval;
				if(val==SLPAR)
					++parlev;
				else if(val==SRPAR)
					--parlev;
				++nextch;
			}
			return(val);
		}
	if(*nextch == '.')
		if(nextch >= lastch) goto badchar;
		else if(isdigit(nextch[1])) goto numconst;
		else	{
			for(pd=dots ; (j=pd->dotname) ; ++pd)
			{
				for(i=nextch+1 ; i<=lastch ; ++i)
					if(*i != *j) break;
					else if(*i != '.') ++j;
					else	{
						nextch = i+1;
						return(pd->dotval);
					}
			}
			goto badchar;
		}
	if( isalpha(*nextch) )
	{
		p = token;
		*p++ = *nextch++;
		while(nextch<=lastch)
			if( isalpha(*nextch) || isdigit(*nextch) )
				*p++ = *nextch++;
			else break;
		toklen = p - token;
		*p = '\0';
		if(inioctl && nextch<=lastch && *nextch=='=')
		{
			++nextch;
			return(SNAMEEQ);
		}
		if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) &&
		    nextch<lastch && nextch[0]=='(' &&
		    (nextch[1]==')' | isalpha(nextch[1])) )
		{
			nextch -= (toklen - 8);
			return(SFUNCTION);
		}
		if(toklen > VL)
		{
			char buff[30];
			sprintf(buff, "name %s too long, truncated to %d",
			    token, VL);
			err(buff);
			toklen = VL;
			token[VL] = '\0';
		}
		if(toklen==1 && *nextch==MYQUOTE)
		{
			switch(token[0])
			{
			case 'z':  
			case 'Z':
			case 'x':  
			case 'X':
				radix = 16; 
				break;
			case 'o':  
			case 'O':
				radix = 8; 
				break;
			case 'b':  
			case 'B':
				radix = 2; 
				break;
			default:
				err("bad bit identifier");
				return(SNAME);
			}
			++nextch;
			for(p = token ; *nextch!=MYQUOTE ; )
				if( hextoi(*p++ = *nextch++) >= radix)
				{
					err("invalid binary character");
					break;
				}
			++nextch;
			toklen = p - token;
			return( radix==16 ? SHEXCON :
			    (radix==8 ? SOCTCON : SBITCON) );
		}
		return(SNAME);
	}
	if( ! isdigit(*nextch) ) goto badchar;
numconst:
	havdot = NO;
	havexp = NO;
	havdbl = NO;
	for(n1 = nextch ; nextch<=lastch ; ++nextch)
	{
		if(*nextch == '.')
			if(havdot) break;
			else if(nextch+2<=lastch && isalpha(nextch[1])
			    && isalpha(nextch[2]))
				break;
			else	havdot = YES;
		else if( !intonly && (*nextch=='d' || *nextch=='e') )
		{
			p = nextch;
			havexp = YES;
			if(*nextch == 'd')
				havdbl = YES;
			if(nextch<lastch)
				if(nextch[1]=='+' || nextch[1]=='-')
					++nextch;
			if( ! isdigit(*++nextch) )
			{
				nextch = p;
				havdbl = havexp = NO;
				break;
			}
			for(++nextch ;
			    nextch<=lastch && isdigit(*nextch);
			    ++nextch);
			break;
		}
		else if( ! isdigit(*nextch) )
			break;
	}
	p = token;
	i = n1;
	while(i < nextch)
		*p++ = *i++;
	toklen = p - token;
	*p = '\0';
	if(havdbl) return(SDCON);
	if(havdot || havexp) return(SRCON);
	return(SICON);
badchar:
	s[0] = *nextch++;
	return(SUNKNOWN);
}

/* KEYWORD AND SPECIAL CHARACTER TABLES
*/

struct Punctlist puncts[ ] =
{
	'(', SLPAR,
	')', SRPAR,
	'=', SEQUALS,
	',', SCOMMA,
	'+', SPLUS,
	'-', SMINUS,
	'*', SSTAR,
	'/', SSLASH,
	'$', SCURRENCY,
	':', SCOLON,
	0, 0 };

/*
LOCAL struct Fmtlist  fmts[ ] =
	{
	'(', SLPAR,
	')', SRPAR,
	'/', SSLASH,
	',', SCOMMA,
	'-', SMINUS,
	':', SCOLON,
	0, 0 } ;
*/
