Home | History | Annotate | Line # | Download | only in fcom 
      1 /*	Id: lex.c,v 1.12 2008/05/11 15:28:03 ragge Exp 	*/
      2 /*	$NetBSD: lex.c,v 1.1.1.2 2010/06/03 18:57:50 plunky Exp $	*/
      3 /*
      4  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
      5  *
      6  * Redistribution and use in source and binary forms, with or without
      7  * modification, are permitted provided that the following conditions
      8  * are met:
      9  *
     10  * Redistributions of source code and documentation must retain the above
     11  * copyright notice, this list of conditions and the following disclaimer.
     12  * Redistributions in binary form must reproduce the above copyright
     13  * notice, this list of conditionsand the following disclaimer in the
     14  * documentation and/or other materials provided with the distribution.
     15  * All advertising materials mentioning features or use of this software
     16  * must display the following acknowledgement:
     17  * 	This product includes software developed or owned by Caldera
     18  *	International, Inc.
     19  * Neither the name of Caldera International, Inc. nor the names of other
     20  * contributors may be used to endorse or promote products derived from
     21  * this software without specific prior written permission.
     22  *
     23  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
     24  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
     25  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
     26  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
     27  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
     28  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
     29  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
     30  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
     31  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
     32  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
     33  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
     34  * POSSIBILITY OF SUCH DAMAGE.
     35  */
     36 #include "defines.h"
     37 #include "defs.h"
     38 
     39 #include "gram.h"
     40 
     41 # define BLANK	' '
     42 # define MYQUOTE (2)
     43 # define SEOF 0
     44 
     45 /* card types */
     46 
     47 # define STEOF 1
     48 # define STINITIAL 2
     49 # define STCONTINUE 3
     50 
     51 /* lex states */
     52 
     53 #define NEWSTMT	1
     54 #define FIRSTTOKEN	2
     55 #define OTHERTOKEN	3
     56 #define RETEOS	4
     57 
     58 
     59 LOCAL int stkey;
     60 LOCAL int stno;
     61 LOCAL long int nxtstno;
     62 LOCAL int parlev;
     63 LOCAL int expcom;
     64 LOCAL int expeql;
     65 LOCAL char *nextch;
     66 LOCAL char *lastch;
     67 LOCAL char *nextcd 	= NULL;
     68 LOCAL char *endcd;
     69 LOCAL int prevlin;
     70 LOCAL int thislin;
     71 LOCAL int code;
     72 LOCAL int lexstate	= NEWSTMT;
     73 LOCAL char s[1390];
     74 LOCAL char *send	= s+20*66;
     75 LOCAL int nincl	= 0;
     76 
     77 struct inclfile
     78 	{
     79 	struct inclfile *inclnext;
     80 	FILEP inclfp;
     81 	char *inclname;
     82 	int incllno;
     83 	char *incllinp;
     84 	int incllen;
     85 	int inclcode;
     86 	ftnint inclstno;
     87 	} ;
     88 
     89 LOCAL struct inclfile *inclp	=  NULL;
     90 struct keylist { char *keyname; int keyval; } ;
     91 struct punctlist { char punchar; int punval; };
     92 struct fmtlist { char fmtchar; int fmtval; };
     93 struct dotlist { char *dotname; int dotval; };
     94 LOCAL struct dotlist  dots[];
     95 LOCAL struct keylist *keystart[26], *keyend[26];
     96 LOCAL struct keylist  keys[];
     97 
     98 LOCAL int getcds(void);
     99 LOCAL void crunch(void);
    100 LOCAL void analyz(void);
    101 LOCAL int gettok(void);
    102 LOCAL int getcd(char *b);
    103 LOCAL int getkwd(void);
    104 LOCAL int popinclude(void);
    105 
    106 /*
    107  * called from main() to start parsing.
    108  * name[0] may be \0 if stdin.
    109  */
    110 int
    111 inilex(char *name)
    112 {
    113 	nincl = 0;
    114 	inclp = NULL;
    115 	doinclude(name);
    116 	lexstate = NEWSTMT;
    117 	return(NO);
    118 }
    119 
    120 
    121 
    122 /* throw away the rest of the current line */
    123 void
    124 flline()
    125 {
    126 lexstate = RETEOS;
    127 }
    128 
    129 
    130 
    131 char *lexline(n)
    132 ftnint *n;
    133 {
    134 *n = (lastch - nextch) + 1;
    135 return(nextch);
    136 }
    137 
    138 
    139 
    140 
    141 void
    142 doinclude(char *name)
    143 {
    144 	FILEP fp;
    145 	struct inclfile *t;
    146 
    147 	if(inclp) {
    148 		inclp->incllno = thislin;
    149 		inclp->inclcode = code;
    150 		inclp->inclstno = nxtstno;
    151 		if(nextcd)
    152 			inclp->incllinp =
    153 			    copyn(inclp->incllen = endcd-nextcd , nextcd);
    154 		else
    155 			inclp->incllinp = 0;
    156 	}
    157 	nextcd = NULL;
    158 
    159 	if(++nincl >= MAXINCLUDES)
    160 		fatal("includes nested too deep");
    161 	if(name[0] == '\0')
    162 		fp = stdin;
    163 	else
    164 		fp = fopen(name, "r");
    165 	if( fp ) {
    166 		t = inclp;
    167 		inclp = ALLOC(inclfile);
    168 		inclp->inclnext = t;
    169 		prevlin = thislin = 0;
    170 		infname = inclp->inclname = name;
    171 		infile = inclp->inclfp = fp;
    172 	} else {
    173 		fprintf(diagfile, "Cannot open file %s", name);
    174 		done(1);
    175 	}
    176 }
    177 
    178 
    179 
    180 
    181 LOCAL int
    182 popinclude()
    183 {
    184 	struct inclfile *t;
    185 	register char *p;
    186 	register int k;
    187 
    188 	if(infile != stdin)
    189 		fclose(infile);
    190 	ckfree(infname);
    191 
    192 	--nincl;
    193 	t = inclp->inclnext;
    194 	ckfree(inclp);
    195 	inclp = t;
    196 	if(inclp == NULL)
    197 		return(NO);
    198 
    199 	infile = inclp->inclfp;
    200 	infname = inclp->inclname;
    201 	prevlin = thislin = inclp->incllno;
    202 	code = inclp->inclcode;
    203 	stno = nxtstno = inclp->inclstno;
    204 	if(inclp->incllinp) {
    205 		endcd = nextcd = s;
    206 		k = inclp->incllen;
    207 		p = inclp->incllinp;
    208 		while(--k >= 0)
    209 			*endcd++ = *p++;
    210 		ckfree(inclp->incllinp);
    211 	} else
    212 		nextcd = NULL;
    213 	return(YES);
    214 }
    215 
    216 
    217 
    218 int
    219 yylex()
    220 {
    221 static int  tokno;
    222 
    223 	switch(lexstate)
    224 	{
    225 case NEWSTMT :	/* need a new statement */
    226 	if(getcds() == STEOF)
    227 		return(SEOF);
    228 	crunch();
    229 	tokno = 0;
    230 	lexstate = FIRSTTOKEN;
    231 	yylval.num = stno;
    232 	stno = nxtstno;
    233 	toklen = 0;
    234 	return(SLABEL);
    235 
    236 first:
    237 case FIRSTTOKEN :	/* first step on a statement */
    238 	analyz();
    239 	lexstate = OTHERTOKEN;
    240 	tokno = 1;
    241 	return(stkey);
    242 
    243 case OTHERTOKEN :	/* return next token */
    244 	if(nextch > lastch)
    245 		goto reteos;
    246 	++tokno;
    247 	if((stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) goto first;
    248 	if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
    249 		nextch[0]=='t' && nextch[1]=='o')
    250 			{
    251 			nextch+=2;
    252 			return(STO);
    253 			}
    254 	return(gettok());
    255 
    256 reteos:
    257 case RETEOS:
    258 	lexstate = NEWSTMT;
    259 	return(SEOS);
    260 	}
    261 fatal1("impossible lexstate %d", lexstate);
    262 /* NOTREACHED */
    263 return 0; /* XXX gcc */
    264 }
    265 
    266 LOCAL int
    267 getcds()
    268 {
    269 register char *p, *q;
    270 
    271 top:
    272 	if(nextcd == NULL)
    273 		{
    274 		code = getcd( nextcd = s );
    275 		stno = nxtstno;
    276 		prevlin = thislin;
    277 		}
    278 	if(code == STEOF) {
    279 		if( popinclude() )
    280 			goto top;
    281 		else
    282 			return(STEOF);
    283 	}
    284 	if(code == STCONTINUE)
    285 		{
    286 		lineno = thislin;
    287 		err("illegal continuation card ignored");
    288 		nextcd = NULL;
    289 		goto top;
    290 		}
    291 
    292 	if(nextcd > s)
    293 		{
    294 		q = nextcd;
    295 		p = s;
    296 		while(q < endcd)
    297 			*p++ = *q++;
    298 		endcd = p;
    299 		}
    300 	for(nextcd = endcd ;
    301 		nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ;
    302 		nextcd = endcd )
    303 			;
    304 	nextch = s;
    305 	lastch = nextcd - 1;
    306 	if(nextcd >= send)
    307 		nextcd = NULL;
    308 	lineno = prevlin;
    309 	prevlin = thislin;
    310 	return(STINITIAL);
    311 }
    312 
    313 LOCAL int
    314 getcd(b)
    315 register char *b;
    316 {
    317 register int c;
    318 register char *p, *bend;
    319 int speclin;
    320 static char a[6];
    321 static char *aend	= a+6;
    322 
    323 top:
    324 	endcd = b;
    325 	bend = b+66;
    326 	speclin = NO;
    327 
    328 	if( (c = getc(infile)) == '&')
    329 		{
    330 		a[0] = BLANK;
    331 		a[5] = 'x';
    332 		speclin = YES;
    333 		bend = send;
    334 		}
    335 	else if(c=='c' || c=='C' || c=='*')
    336 		{
    337 		while( (c = getc(infile)) != '\n')
    338 			if(c == EOF)
    339 				return(STEOF);
    340 		++thislin;
    341 		goto top;
    342 		}
    343 
    344 	else if(c != EOF)
    345 		{
    346 		/* a tab in columns 1-6 skips to column 7 */
    347 		ungetc(c, infile);
    348 		for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
    349 			if(c == '\t')
    350 				{
    351 				while(p < aend)
    352 					*p++ = BLANK;
    353 				speclin = YES;
    354 				bend = send;
    355 				}
    356 			else
    357 				*p++ = c;
    358 		}
    359 	if(c == EOF)
    360 		return(STEOF);
    361 	if(c == '\n')
    362 		{
    363 		p = a; /* XXX ??? */
    364 		while(p < aend)
    365 			*p++ = BLANK;
    366 		if( ! speclin )
    367 			while(endcd < bend)
    368 				*endcd++ = BLANK;
    369 		}
    370 	else	{	/* read body of line */
    371 		while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
    372 			*endcd++ = (c == '\t' ? BLANK : c);
    373 		if(c == EOF)
    374 			return(STEOF);
    375 		if(c != '\n')
    376 			{
    377 			while( (c=getc(infile)) != '\n')
    378 				if(c == EOF)
    379 					return(STEOF);
    380 			}
    381 
    382 		if( ! speclin )
    383 			while(endcd < bend)
    384 				*endcd++ = BLANK;
    385 		}
    386 	++thislin;
    387 	if(a[5]!=BLANK && a[5]!='0')
    388 		return(STCONTINUE);
    389 	for(p=a; p<aend; ++p)
    390 		if(*p != BLANK) goto initline;
    391 	for(p = b ; p<endcd ; ++p)
    392 		if(*p != BLANK) goto initline;
    393 	goto top;
    394 
    395 initline:
    396 	nxtstno = 0;
    397 	for(p = a ; p<a+5 ; ++p)
    398 		if(*p != BLANK) {
    399 			if(isdigit((int)*p))
    400 				nxtstno = 10*nxtstno + (*p - '0');
    401 			else	{
    402 				lineno = thislin;
    403 				err("nondigit in statement number field");
    404 				nxtstno = 0;
    405 				break;
    406 				}
    407 		}
    408 	return(STINITIAL);
    409 }
    410 
    411 LOCAL void
    412 crunch()
    413 {
    414 register char *i, *j, *j0, *j1, *prvstr;
    415 int ten, nh, quote;
    416 
    417 /* i is the next input character to be looked at
    418 j is the next output character */
    419 parlev = 0;
    420 expcom = 0;	/* exposed ','s */
    421 expeql = 0;	/* exposed equal signs */
    422 j = s;
    423 prvstr = s;
    424 for(i=s ; i<=lastch ; ++i)
    425 	{
    426 	if(*i == BLANK) continue;
    427 	if(*i=='\'' ||  *i=='"')
    428 		{
    429 		quote = *i;
    430 		*j = MYQUOTE; /* special marker */
    431 		for(;;)
    432 			{
    433 			if(++i > lastch)
    434 				{
    435 				err("unbalanced quotes; closing quote supplied");
    436 				break;
    437 				}
    438 			if(*i == quote)
    439 				if(i<lastch && i[1]==quote) ++i;
    440 				else break;
    441 			else if(*i=='\\' && i<lastch)
    442 				switch(*++i)
    443 					{
    444 					case 't':
    445 						*i = '\t'; break;
    446 					case 'b':
    447 						*i = '\b'; break;
    448 					case 'n':
    449 						*i = '\n'; break;
    450 					case 'f':
    451 						*i = '\f'; break;
    452 					case '0':
    453 						*i = '\0'; break;
    454 					default:
    455 						break;
    456 					}
    457 			*++j = *i;
    458 			}
    459 		j[1] = MYQUOTE;
    460 		j += 2;
    461 		prvstr = j;
    462 		}
    463 	else if( (*i=='h' || *i=='H')  && j>prvstr)	/* test for Hollerith strings */
    464 		{
    465 		if( ! isdigit((int)j[-1])) goto copychar;
    466 		nh = j[-1] - '0';
    467 		ten = 10;
    468 		j1 = prvstr - 1;
    469 		if (j1<j-5) j1=j-5;
    470 		for(j0=j-2 ; j0>j1; -- j0)
    471 			{
    472 			if( ! isdigit((int)*j0 ) ) break;
    473 			nh += ten * (*j0-'0');
    474 			ten*=10;
    475 			}
    476 		if(j0 <= j1) goto copychar;
    477 /* a hollerith must be preceded by a punctuation mark.
    478    '*' is possible only as repetition factor in a data statement
    479    not, in particular, in character*2h
    480 */
    481 
    482 		if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' &&
    483 			*j0!=',' && *j0!='=' && *j0!='.')
    484 				goto copychar;
    485 		if(i+nh > lastch)
    486 			{
    487 			err1("%dH too big", nh);
    488 			nh = lastch - i;
    489 			}
    490 		j0[1] = MYQUOTE; /* special marker */
    491 		j = j0 + 1;
    492 		while(nh-- > 0)
    493 			{
    494 			if(*++i == '\\')
    495 				switch(*++i)
    496 					{
    497 					case 't':
    498 						*i = '\t'; break;
    499 					case 'b':
    500 						*i = '\b'; break;
    501 					case 'n':
    502 						*i = '\n'; break;
    503 					case 'f':
    504 						*i = '\f'; break;
    505 					case '0':
    506 						*i = '\0'; break;
    507 					default:
    508 						break;
    509 					}
    510 			*++j = *i;
    511 			}
    512 		j[1] = MYQUOTE;
    513 		j+=2;
    514 		prvstr = j;
    515 		}
    516 	else	{
    517 		if(*i == '(') ++parlev;
    518 		else if(*i == ')') --parlev;
    519 		else if(parlev == 0) {
    520 			if(*i == '=') expeql = 1;
    521 			else if(*i == ',') expcom = 1;
    522 copychar:	;	/*not a string of BLANK -- copy, shifting case if necessary */
    523 		}
    524 		if(shiftcase && isupper((int)*i))
    525 			*j++ = tolower((int)*i);
    526 		else	*j++ = *i;
    527 		}
    528 	}
    529 lastch = j - 1;
    530 nextch = s;
    531 }
    532 
    533 LOCAL void
    534 analyz()
    535 {
    536 register char *i;
    537 
    538 	if(parlev != 0)
    539 		{
    540 		err("unbalanced parentheses, statement skipped");
    541 		stkey = SUNKNOWN;
    542 		return;
    543 		}
    544 	if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
    545 		{
    546 /* assignment or if statement -- look at character after balancing paren */
    547 		parlev = 1;
    548 		for(i=nextch+3 ; i<=lastch; ++i)
    549 			if(*i == (MYQUOTE))
    550 				{
    551 				while(*++i != MYQUOTE)
    552 					;
    553 				}
    554 			else if(*i == '(')
    555 				++parlev;
    556 			else if(*i == ')')
    557 				{
    558 				if(--parlev == 0)
    559 					break;
    560 				}
    561 		if(i >= lastch)
    562 			stkey = SLOGIF;
    563 		else if(i[1] == '=')
    564 			stkey = SLET;
    565 		else if( isdigit((int)i[1]) )
    566 			stkey = SARITHIF;
    567 		else	stkey = SLOGIF;
    568 		if(stkey != SLET)
    569 			nextch += 2;
    570 		}
    571 	else if(expeql) /* may be an assignment */
    572 		{
    573 		if(expcom && nextch<lastch &&
    574 			nextch[0]=='d' && nextch[1]=='o')
    575 				{
    576 				stkey = SDO;
    577 				nextch += 2;
    578 				}
    579 		else	stkey = SLET;
    580 		}
    581 /* otherwise search for keyword */
    582 	else	{
    583 		stkey = getkwd();
    584 		if(stkey==SGOTO && lastch>=nextch) {
    585 			if(nextch[0]=='(')
    586 				stkey = SCOMPGOTO;
    587 			else if(isalpha((int)nextch[0]))
    588 				stkey = SASGOTO;
    589 		}
    590 	}
    591 	parlev = 0;
    592 }
    593 
    594 
    595 
    596 LOCAL int
    597 getkwd()
    598 {
    599 register char *i, *j;
    600 register struct keylist *pk, *pend;
    601 int k;
    602 
    603 if(! isalpha((int)nextch[0]) )
    604 	return(SUNKNOWN);
    605 k = nextch[0] - 'a';
    606 if((pk = keystart[k]))
    607 	for(pend = keyend[k] ; pk<=pend ; ++pk )
    608 		{
    609 		i = pk->keyname;
    610 		j = nextch;
    611 		while(*++i==*++j && *i!='\0')
    612 			;
    613 		if(*i == '\0')
    614 			{
    615 			nextch = j;
    616 			return(pk->keyval);
    617 			}
    618 		}
    619 return(SUNKNOWN);
    620 }
    621 
    622 
    623 void
    624 initkey()
    625 {
    626 register struct keylist *p;
    627 register int i,j;
    628 
    629 for(i = 0 ; i<26 ; ++i)
    630 	keystart[i] = NULL;
    631 
    632 for(p = keys ; p->keyname ; ++p)
    633 	{
    634 	j = p->keyname[0] - 'a';
    635 	if(keystart[j] == NULL)
    636 		keystart[j] = p;
    637 	keyend[j] = p;
    638 	}
    639 }
    640 
    641 LOCAL int
    643 gettok()
    644 {
    645 int havdot, havexp, havdbl;
    646 int radix;
    647 extern struct punctlist puncts[];
    648 struct punctlist *pp;
    649 #if 0
    650 extern struct fmtlist fmts[];
    651 #endif
    652 struct dotlist *pd;
    653 
    654 char *i, *j, *n1, *p;
    655 
    656 	if(*nextch == (MYQUOTE))
    657 		{
    658 		++nextch;
    659 		p = token;
    660 		while(*nextch != MYQUOTE)
    661 			*p++ = *nextch++;
    662 		++nextch;
    663 		toklen = p - token;
    664 		*p = '\0';
    665 		return (SHOLLERITH);
    666 		}
    667 /*
    668 	if(stkey == SFORMAT)
    669 		{
    670 		for(pf = fmts; pf->fmtchar; ++pf)
    671 			{
    672 			if(*nextch == pf->fmtchar)
    673 				{
    674 				++nextch;
    675 				if(pf->fmtval == SLPAR)
    676 					++parlev;
    677 				else if(pf->fmtval == SRPAR)
    678 					--parlev;
    679 				return(pf->fmtval);
    680 				}
    681 			}
    682 		if( isdigit(*nextch) )
    683 			{
    684 			p = token;
    685 			*p++ = *nextch++;
    686 			while(nextch<=lastch && isdigit(*nextch) )
    687 				*p++ = *nextch++;
    688 			toklen = p - token;
    689 			*p = '\0';
    690 			if(nextch<=lastch && *nextch=='p')
    691 				{
    692 				++nextch;
    693 				return(SSCALE);
    694 				}
    695 			else	return(SICON);
    696 			}
    697 		if( isalpha(*nextch) )
    698 			{
    699 			p = token;
    700 			*p++ = *nextch++;
    701 			while(nextch<=lastch &&
    702 				(*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) ))
    703 					*p++ = *nextch++;
    704 			toklen = p - token;
    705 			*p = '\0';
    706 			return(SFIELD);
    707 			}
    708 		goto badchar;
    709 		}
    710  XXX ??? */
    711 /* Not a format statement */
    712 
    713 if(needkwd)
    714 	{
    715 	needkwd = 0;
    716 	return( getkwd() );
    717 	}
    718 
    719 	for(pp=puncts; pp->punchar; ++pp)
    720 		if(*nextch == pp->punchar)
    721 			{
    722 			if( (*nextch=='*' || *nextch=='/') &&
    723 				nextch<lastch && nextch[1]==nextch[0])
    724 					{
    725 					if(*nextch == '*')
    726 						yylval.num = SPOWER;
    727 					else	yylval.num = SCONCAT;
    728 					nextch+=2;
    729 					}
    730 			else	{yylval.num=pp->punval;
    731 					if(yylval.num==SLPAR)
    732 						++parlev;
    733 					else if(yylval.num==SRPAR)
    734 						--parlev;
    735 					++nextch;
    736 				}
    737 			return(yylval.num);
    738 			}
    739 	if(*nextch == '.') {
    740 		if(nextch >= lastch) goto badchar;
    741 		else if(isdigit((int)nextch[1])) goto numconst;
    742 		else	{
    743 			for(pd=dots ; (j=pd->dotname) ; ++pd)
    744 				{
    745 				for(i=nextch+1 ; i<=lastch ; ++i)
    746 					if(*i != *j) break;
    747 					else if(*i != '.') ++j;
    748 					else	{
    749 						nextch = i+1;
    750 						return(pd->dotval);
    751 						}
    752 				}
    753 			goto badchar;
    754 			}
    755 	}
    756 	if( isalpha((int)*nextch) )
    757 		{
    758 		p = token;
    759 		*p++ = *nextch++;
    760 		while(nextch<=lastch)
    761 			if( isalpha((int)*nextch) || isdigit((int)*nextch) )
    762 				*p++ = *nextch++;
    763 			else break;
    764 		toklen = p - token;
    765 		*p = '\0';
    766 		if(inioctl && nextch<=lastch && *nextch=='=')
    767 			{
    768 			++nextch;
    769 			return(SNAMEEQ);
    770 			}
    771 		if(toklen>=8 && eqn(8, token, "function") &&
    772 			nextch<lastch && *nextch=='(')
    773 				{
    774 				nextch -= (toklen - 8);
    775 				return(SFUNCTION);
    776 				}
    777 		if(toklen > VL)
    778 			{
    779 			err2("name %s too long, truncated to %d", token, VL);
    780 			toklen = VL;
    781 			token[6] = '\0';
    782 			}
    783 		if(toklen==1 && *nextch==MYQUOTE)
    784 			{
    785 			switch(token[0])
    786 				{
    787 				case 'z':  case 'Z':
    788 				case 'x':  case 'X':
    789 					radix = 16; break;
    790 				case 'o':  case 'O':
    791 					radix = 8; break;
    792 				case 'b':  case 'B':
    793 					radix = 2; break;
    794 				default:
    795 					err("bad bit identifier");
    796 					return(SFNAME);
    797 				}
    798 			++nextch;
    799 			for(p = token ; *nextch!=MYQUOTE ; )
    800 				if( hextoi(*p++ = *nextch++) >= radix)
    801 					{
    802 					err("invalid binary character");
    803 					break;
    804 					}
    805 			++nextch;
    806 			toklen = p - token;
    807 			return( radix==16 ? SHEXCON : (radix==8 ? SOCTCON : SBITCON) );
    808 			}
    809 		return(SFNAME);
    810 		}
    811 	if( ! isdigit((int)*nextch) ) goto badchar;
    812 numconst:
    813 	havdot = NO;
    814 	havexp = NO;
    815 	havdbl = NO;
    816 	for(n1 = nextch ; nextch<=lastch ; ++nextch)
    817 		{
    818 		if(*nextch == '.')
    819 			if(havdot) break;
    820 			else if(nextch+2<=lastch && isalpha((int)nextch[1])
    821 				&& isalpha((int)nextch[2]))
    822 					break;
    823 			else	havdot = YES;
    824 		else if(*nextch=='d' || *nextch=='e')
    825 			{
    826 			p = nextch;
    827 			havexp = YES;
    828 			if(*nextch == 'd')
    829 				havdbl = YES;
    830 			if(nextch<lastch)
    831 				if(nextch[1]=='+' || nextch[1]=='-')
    832 					++nextch;
    833 			if( ! isdigit((int)*++nextch) )
    834 				{
    835 				nextch = p;
    836 				havdbl = havexp = NO;
    837 				break;
    838 				}
    839 			for(++nextch ;
    840 				nextch<=lastch && isdigit((int)*nextch);
    841 				++nextch);
    842 			break;
    843 			}
    844 		else if( ! isdigit((int)*nextch) )
    845 			break;
    846 		}
    847 	p = token;
    848 	i = n1;
    849 	while(i < nextch)
    850 		*p++ = *i++;
    851 	toklen = p - token;
    852 	*p = '\0';
    853 	if(havdbl) return(SDCON);
    854 	if(havdot || havexp) return(SRCON);
    855 	return(SICON);
    856 badchar:
    857 	s[0] = *nextch++;
    858 	return(SUNKNOWN);
    859 }
    860 
    861 /* KEYWORD AND SPECIAL CHARACTER TABLES
    863 */
    864 
    865 struct punctlist puncts[ ] =
    866 	{
    867 {	'(', SLPAR, },
    868 {	')', SRPAR, },
    869 {	'=', SEQUALS, },
    870 {	',', SCOMMA, },
    871 {	'+', SPLUS, },
    872 {	'-', SMINUS, },
    873 {	'*', SSTAR, },
    874 {	'/', SSLASH, },
    875 {	'$', SCURRENCY, },
    876 {	':', SCOLON, },
    877 {	0, 0 }, } ;
    878 
    879 /*
    880 LOCAL struct fmtlist  fmts[ ] =
    881 	{
    882 	'(', SLPAR,
    883 	')', SRPAR,
    884 	'/', SSLASH,
    885 	',', SCOMMA,
    886 	'-', SMINUS,
    887 	':', SCOLON,
    888 	0, 0 } ;
    889 */
    890 
    891 LOCAL struct dotlist  dots[ ] =
    892 	{
    893 {	"and.", SAND, },
    894 {	"or.", SOR, },
    895 {	"not.", SNOT, },
    896 {	"true.", STRUE, },
    897 {	"false.", SFALSE, },
    898 {	"eq.", SEQ, },
    899 {	"ne.", SNE, },
    900 {	"lt.", SLT, },
    901 {	"le.", SLE, },
    902 {	"gt.", SGT, },
    903 {	"ge.", SGE, },
    904 {	"neqv.", SNEQV, },
    905 {	"eqv.", SEQV, },
    906 {	0, 0 }, } ;
    907 
    908 LOCAL struct keylist  keys[ ] =
    909 	{
    910 {	"assign",  SASSIGN, },
    911 {	"automatic",  SAUTOMATIC, },
    912 {	"backspace",  SBACKSPACE, },
    913 {	"blockdata",  SBLOCK, },
    914 {	"call",  SCALL, },
    915 {	"character",  SCHARACTER, },
    916 {	"close",  SCLOSE, },
    917 {	"common",  SCOMMON, },
    918 {	"complex",  SCOMPLEX, },
    919 {	"continue",  SCONTINUE, },
    920 {	"data",  SDATA, },
    921 {	"dimension",  SDIMENSION, },
    922 {	"doubleprecision",  SDOUBLE, },
    923 {	"doublecomplex", SDCOMPLEX, },
    924 {	"elseif",  SELSEIF, },
    925 {	"else",  SELSE, },
    926 {	"endfile",  SENDFILE, },
    927 {	"endif",  SENDIF, },
    928 {	"end",  SEND, },
    929 {	"entry",  SENTRY, },
    930 {	"equivalence",  SEQUIV, },
    931 {	"external",  SEXTERNAL, },
    932 {	"format",  SFORMAT, },
    933 {	"function",  SFUNCTION, },
    934 {	"goto",  SGOTO, },
    935 {	"implicit",  SIMPLICIT, },
    936 {	"include",  SINCLUDE, },
    937 {	"inquire",  SINQUIRE, },
    938 {	"intrinsic",  SINTRINSIC, },
    939 {	"integer",  SINTEGER, },
    940 {	"logical",  SLOGICAL, },
    941 {	"open",  SOPEN, },
    942 {	"parameter",  SPARAM, },
    943 {	"pause",  SPAUSE, },
    944 {	"print",  SPRINT, },
    945 {	"program",  SPROGRAM, },
    946 {	"punch",  SPUNCH, },
    947 {	"read",  SREAD, },
    948 {	"real",  SREAL, },
    949 {	"return",  SRETURN, },
    950 {	"rewind",  SREWIND, },
    951 {	"save",  SSAVE, },
    952 {	"static",  SSTATIC, },
    953 {	"stop",  SSTOP, },
    954 {	"subroutine",  SSUBROUTINE, },
    955 {	"then",  STHEN, },
    956 {	"undefined", SUNDEFINED, },
    957 {	"write",  SWRITE, },
    958 {	0, 0 }, };
    959