xref: /netbsd-src/external/bsd/pcc/dist/pcc/f77/fcom/lex.c (revision 3eb51a414323db7a1111282bc3c20ea6ba71c4f4)
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
inilex(char * name)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
flline()124 flline()
125 {
126 lexstate = RETEOS;
127 }
128 
129 
130 
lexline(n)131 char *lexline(n)
132 ftnint *n;
133 {
134 *n = (lastch - nextch) + 1;
135 return(nextch);
136 }
137 
138 
139 
140 
141 void
doinclude(char * name)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
popinclude()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
yylex()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
getcds()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
getcd(b)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
crunch()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
analyz()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
getkwd()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
initkey()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
gettok()642 gettok()
643 {
644 int havdot, havexp, havdbl;
645 int radix;
646 extern struct punctlist puncts[];
647 struct punctlist *pp;
648 #if 0
649 extern struct fmtlist fmts[];
650 #endif
651 struct dotlist *pd;
652 
653 char *i, *j, *n1, *p;
654 
655 	if(*nextch == (MYQUOTE))
656 		{
657 		++nextch;
658 		p = token;
659 		while(*nextch != MYQUOTE)
660 			*p++ = *nextch++;
661 		++nextch;
662 		toklen = p - token;
663 		*p = '\0';
664 		return (SHOLLERITH);
665 		}
666 /*
667 	if(stkey == SFORMAT)
668 		{
669 		for(pf = fmts; pf->fmtchar; ++pf)
670 			{
671 			if(*nextch == pf->fmtchar)
672 				{
673 				++nextch;
674 				if(pf->fmtval == SLPAR)
675 					++parlev;
676 				else if(pf->fmtval == SRPAR)
677 					--parlev;
678 				return(pf->fmtval);
679 				}
680 			}
681 		if( isdigit(*nextch) )
682 			{
683 			p = token;
684 			*p++ = *nextch++;
685 			while(nextch<=lastch && isdigit(*nextch) )
686 				*p++ = *nextch++;
687 			toklen = p - token;
688 			*p = '\0';
689 			if(nextch<=lastch && *nextch=='p')
690 				{
691 				++nextch;
692 				return(SSCALE);
693 				}
694 			else	return(SICON);
695 			}
696 		if( isalpha(*nextch) )
697 			{
698 			p = token;
699 			*p++ = *nextch++;
700 			while(nextch<=lastch &&
701 				(*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) ))
702 					*p++ = *nextch++;
703 			toklen = p - token;
704 			*p = '\0';
705 			return(SFIELD);
706 			}
707 		goto badchar;
708 		}
709  XXX ??? */
710 /* Not a format statement */
711 
712 if(needkwd)
713 	{
714 	needkwd = 0;
715 	return( getkwd() );
716 	}
717 
718 	for(pp=puncts; pp->punchar; ++pp)
719 		if(*nextch == pp->punchar)
720 			{
721 			if( (*nextch=='*' || *nextch=='/') &&
722 				nextch<lastch && nextch[1]==nextch[0])
723 					{
724 					if(*nextch == '*')
725 						yylval.num = SPOWER;
726 					else	yylval.num = SCONCAT;
727 					nextch+=2;
728 					}
729 			else	{yylval.num=pp->punval;
730 					if(yylval.num==SLPAR)
731 						++parlev;
732 					else if(yylval.num==SRPAR)
733 						--parlev;
734 					++nextch;
735 				}
736 			return(yylval.num);
737 			}
738 	if(*nextch == '.') {
739 		if(nextch >= lastch) goto badchar;
740 		else if(isdigit((int)nextch[1])) goto numconst;
741 		else	{
742 			for(pd=dots ; (j=pd->dotname) ; ++pd)
743 				{
744 				for(i=nextch+1 ; i<=lastch ; ++i)
745 					if(*i != *j) break;
746 					else if(*i != '.') ++j;
747 					else	{
748 						nextch = i+1;
749 						return(pd->dotval);
750 						}
751 				}
752 			goto badchar;
753 			}
754 	}
755 	if( isalpha((int)*nextch) )
756 		{
757 		p = token;
758 		*p++ = *nextch++;
759 		while(nextch<=lastch)
760 			if( isalpha((int)*nextch) || isdigit((int)*nextch) )
761 				*p++ = *nextch++;
762 			else break;
763 		toklen = p - token;
764 		*p = '\0';
765 		if(inioctl && nextch<=lastch && *nextch=='=')
766 			{
767 			++nextch;
768 			return(SNAMEEQ);
769 			}
770 		if(toklen>=8 && eqn(8, token, "function") &&
771 			nextch<lastch && *nextch=='(')
772 				{
773 				nextch -= (toklen - 8);
774 				return(SFUNCTION);
775 				}
776 		if(toklen > VL)
777 			{
778 			err2("name %s too long, truncated to %d", token, VL);
779 			toklen = VL;
780 			token[6] = '\0';
781 			}
782 		if(toklen==1 && *nextch==MYQUOTE)
783 			{
784 			switch(token[0])
785 				{
786 				case 'z':  case 'Z':
787 				case 'x':  case 'X':
788 					radix = 16; break;
789 				case 'o':  case 'O':
790 					radix = 8; break;
791 				case 'b':  case 'B':
792 					radix = 2; break;
793 				default:
794 					err("bad bit identifier");
795 					return(SFNAME);
796 				}
797 			++nextch;
798 			for(p = token ; *nextch!=MYQUOTE ; )
799 				if( hextoi(*p++ = *nextch++) >= radix)
800 					{
801 					err("invalid binary character");
802 					break;
803 					}
804 			++nextch;
805 			toklen = p - token;
806 			return( radix==16 ? SHEXCON : (radix==8 ? SOCTCON : SBITCON) );
807 			}
808 		return(SFNAME);
809 		}
810 	if( ! isdigit((int)*nextch) ) goto badchar;
811 numconst:
812 	havdot = NO;
813 	havexp = NO;
814 	havdbl = NO;
815 	for(n1 = nextch ; nextch<=lastch ; ++nextch)
816 		{
817 		if(*nextch == '.')
818 			if(havdot) break;
819 			else if(nextch+2<=lastch && isalpha((int)nextch[1])
820 				&& isalpha((int)nextch[2]))
821 					break;
822 			else	havdot = YES;
823 		else if(*nextch=='d' || *nextch=='e')
824 			{
825 			p = nextch;
826 			havexp = YES;
827 			if(*nextch == 'd')
828 				havdbl = YES;
829 			if(nextch<lastch)
830 				if(nextch[1]=='+' || nextch[1]=='-')
831 					++nextch;
832 			if( ! isdigit((int)*++nextch) )
833 				{
834 				nextch = p;
835 				havdbl = havexp = NO;
836 				break;
837 				}
838 			for(++nextch ;
839 				nextch<=lastch && isdigit((int)*nextch);
840 				++nextch);
841 			break;
842 			}
843 		else if( ! isdigit((int)*nextch) )
844 			break;
845 		}
846 	p = token;
847 	i = n1;
848 	while(i < nextch)
849 		*p++ = *i++;
850 	toklen = p - token;
851 	*p = '\0';
852 	if(havdbl) return(SDCON);
853 	if(havdot || havexp) return(SRCON);
854 	return(SICON);
855 badchar:
856 	s[0] = *nextch++;
857 	return(SUNKNOWN);
858 }
859 
860 /* KEYWORD AND SPECIAL CHARACTER TABLES
861 */
862 
863 struct punctlist puncts[ ] =
864 	{
865 {	'(', SLPAR, },
866 {	')', SRPAR, },
867 {	'=', SEQUALS, },
868 {	',', SCOMMA, },
869 {	'+', SPLUS, },
870 {	'-', SMINUS, },
871 {	'*', SSTAR, },
872 {	'/', SSLASH, },
873 {	'$', SCURRENCY, },
874 {	':', SCOLON, },
875 {	0, 0 }, } ;
876 
877 /*
878 LOCAL struct fmtlist  fmts[ ] =
879 	{
880 	'(', SLPAR,
881 	')', SRPAR,
882 	'/', SSLASH,
883 	',', SCOMMA,
884 	'-', SMINUS,
885 	':', SCOLON,
886 	0, 0 } ;
887 */
888 
889 LOCAL struct dotlist  dots[ ] =
890 	{
891 {	"and.", SAND, },
892 {	"or.", SOR, },
893 {	"not.", SNOT, },
894 {	"true.", STRUE, },
895 {	"false.", SFALSE, },
896 {	"eq.", SEQ, },
897 {	"ne.", SNE, },
898 {	"lt.", SLT, },
899 {	"le.", SLE, },
900 {	"gt.", SGT, },
901 {	"ge.", SGE, },
902 {	"neqv.", SNEQV, },
903 {	"eqv.", SEQV, },
904 {	0, 0 }, } ;
905 
906 LOCAL struct keylist  keys[ ] =
907 	{
908 {	"assign",  SASSIGN, },
909 {	"automatic",  SAUTOMATIC, },
910 {	"backspace",  SBACKSPACE, },
911 {	"blockdata",  SBLOCK, },
912 {	"call",  SCALL, },
913 {	"character",  SCHARACTER, },
914 {	"close",  SCLOSE, },
915 {	"common",  SCOMMON, },
916 {	"complex",  SCOMPLEX, },
917 {	"continue",  SCONTINUE, },
918 {	"data",  SDATA, },
919 {	"dimension",  SDIMENSION, },
920 {	"doubleprecision",  SDOUBLE, },
921 {	"doublecomplex", SDCOMPLEX, },
922 {	"elseif",  SELSEIF, },
923 {	"else",  SELSE, },
924 {	"endfile",  SENDFILE, },
925 {	"endif",  SENDIF, },
926 {	"end",  SEND, },
927 {	"entry",  SENTRY, },
928 {	"equivalence",  SEQUIV, },
929 {	"external",  SEXTERNAL, },
930 {	"format",  SFORMAT, },
931 {	"function",  SFUNCTION, },
932 {	"goto",  SGOTO, },
933 {	"implicit",  SIMPLICIT, },
934 {	"include",  SINCLUDE, },
935 {	"inquire",  SINQUIRE, },
936 {	"intrinsic",  SINTRINSIC, },
937 {	"integer",  SINTEGER, },
938 {	"logical",  SLOGICAL, },
939 {	"open",  SOPEN, },
940 {	"parameter",  SPARAM, },
941 {	"pause",  SPAUSE, },
942 {	"print",  SPRINT, },
943 {	"program",  SPROGRAM, },
944 {	"punch",  SPUNCH, },
945 {	"read",  SREAD, },
946 {	"real",  SREAL, },
947 {	"return",  SRETURN, },
948 {	"rewind",  SREWIND, },
949 {	"save",  SSAVE, },
950 {	"static",  SSTATIC, },
951 {	"stop",  SSTOP, },
952 {	"subroutine",  SSUBROUTINE, },
953 {	"then",  STHEN, },
954 {	"undefined", SUNDEFINED, },
955 {	"write",  SWRITE, },
956 {	0, 0 }, };
957