1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)lex.c 5.5 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * lex.c
14 *
15 * Lexical scanner routines for the f77 compiler, pass 1, 4.2 BSD.
16 *
17 * University of Utah CS Dept modification history:
18 *
19 * $Log: lex.c,v $
20 * Revision 5.4 86/01/07 14:01:13 donn
21 * Fix the scanning for character constants in gettok() so that it handles
22 * the case when an error has occurred and there is no closing quote.
23 *
24 * Revision 5.3 85/11/25 00:24:06 donn
25 * 4.3 beta
26 *
27 * Revision 5.2 85/08/10 04:45:41 donn
28 * Jerry Berkman's changes to ifdef 66 code and handle -r8/double flag.
29 *
30 * Revision 5.1 85/08/10 03:48:20 donn
31 * 4.3 alpha
32 *
33 * Revision 1.2 84/10/27 02:20:09 donn
34 * Fixed bug where the input file and the name field of the include file
35 * structure shared -- when the input file name was freed, the include file
36 * name got stomped on, leading to peculiar error messages.
37 *
38 */
39
40 #include "defs.h"
41 #include "tokdefs.h"
42 #include "pathnames.h"
43
44 # define BLANK ' '
45 # define MYQUOTE (2)
46 # define SEOF 0
47
48 /* card types */
49
50 # define STEOF 1
51 # define STINITIAL 2
52 # define STCONTINUE 3
53
54 /* lex states */
55
56 #define NEWSTMT 1
57 #define FIRSTTOKEN 2
58 #define OTHERTOKEN 3
59 #define RETEOS 4
60
61
62 LOCAL int stkey;
63 LOCAL int lastend = 1;
64 ftnint yystno;
65 flag intonly;
66 LOCAL long int stno;
67 LOCAL long int nxtstno;
68 LOCAL int parlev;
69 LOCAL int expcom;
70 LOCAL int expeql;
71 LOCAL char *nextch;
72 LOCAL char *lastch;
73 LOCAL char *nextcd = NULL;
74 LOCAL char *endcd;
75 LOCAL int prevlin;
76 LOCAL int thislin;
77 LOCAL int code;
78 LOCAL int lexstate = NEWSTMT;
79 LOCAL char s[1390];
80 LOCAL char *send = s+20*66;
81 LOCAL int nincl = 0;
82 LOCAL char *newname = NULL;
83
84 struct Inclfile
85 {
86 struct Inclfile *inclnext;
87 FILEP inclfp;
88 char *inclname;
89 int incllno;
90 char *incllinp;
91 int incllen;
92 int inclcode;
93 ftnint inclstno;
94 } ;
95
96 LOCAL struct Inclfile *inclp = NULL;
97 LOCAL struct Keylist { char *keyname; int keyval; char notinf66; } ;
98 LOCAL struct Punctlist { char punchar; int punval; };
99 LOCAL struct Fmtlist { char fmtchar; int fmtval; };
100 LOCAL struct Dotlist { char *dotname; int dotval; };
101 LOCAL struct Keylist *keystart[26], *keyend[26];
102
103
104
105
inilex(name)106 inilex(name)
107 char *name;
108 {
109 nincl = 0;
110 inclp = NULL;
111 doinclude(name);
112 lexstate = NEWSTMT;
113 return(NO);
114 }
115
116
117
118 /* throw away the rest of the current line */
flline()119 flline()
120 {
121 lexstate = RETEOS;
122 }
123
124
125
lexline(n)126 char *lexline(n)
127 int *n;
128 {
129 *n = (lastch - nextch) + 1;
130 return(nextch);
131 }
132
133
134
135
136
doinclude(name)137 doinclude(name)
138 char *name;
139 {
140 FILEP fp;
141 struct Inclfile *t;
142 char temp[100];
143 register char *lastslash, *s;
144
145 if(inclp)
146 {
147 inclp->incllno = thislin;
148 inclp->inclcode = code;
149 inclp->inclstno = nxtstno;
150 if(nextcd)
151 inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
152 else
153 inclp->incllinp = 0;
154 }
155 nextcd = NULL;
156
157 if(++nincl >= MAXINCLUDES)
158 fatal("includes nested too deep");
159 if(name[0] == '\0')
160 fp = stdin;
161 else if(name[0]=='/' || inclp==NULL)
162 fp = fopen(name, "r");
163 else {
164 lastslash = NULL;
165 for(s = inclp->inclname ; *s ; ++s)
166 if(*s == '/')
167 lastslash = s;
168 if(lastslash)
169 {
170 *lastslash = '\0';
171 sprintf(temp, "%s/%s", inclp->inclname, name);
172 *lastslash = '/';
173 }
174 else
175 strcpy(temp, name);
176
177 if( (fp = fopen(temp, "r")) == NULL )
178 {
179 sprintf(temp, "%s/%s", _PATH_INCLUDES, name);
180 fp = fopen(temp, "r");
181 }
182 if(fp)
183 name = copys(temp);
184 }
185
186 if( fp )
187 {
188 t = inclp;
189 inclp = ALLOC(Inclfile);
190 inclp->inclnext = t;
191 prevlin = thislin = 0;
192 inclp->inclname = name;
193 infname = copys(name);
194 infile = inclp->inclfp = fp;
195 }
196 else
197 {
198 fprintf(diagfile, "Cannot open file %s", name);
199 done(1);
200 }
201 }
202
203
204
205
popinclude()206 LOCAL popinclude()
207 {
208 struct Inclfile *t;
209 register char *p;
210 register int k;
211
212 if(infile != stdin)
213 clf(&infile);
214 free(infname);
215
216 --nincl;
217 t = inclp->inclnext;
218 free(inclp->inclname);
219 free( (charptr) inclp);
220 inclp = t;
221 if(inclp == NULL)
222 return(NO);
223
224 infile = inclp->inclfp;
225 infname = copys(inclp->inclname);
226 prevlin = thislin = inclp->incllno;
227 code = inclp->inclcode;
228 stno = nxtstno = inclp->inclstno;
229 if(inclp->incllinp)
230 {
231 endcd = nextcd = s;
232 k = inclp->incllen;
233 p = inclp->incllinp;
234 while(--k >= 0)
235 *endcd++ = *p++;
236 free( (charptr) (inclp->incllinp) );
237 }
238 else
239 nextcd = NULL;
240 return(YES);
241 }
242
243
244
245
yylex()246 yylex()
247 {
248 static int tokno;
249
250 switch(lexstate)
251 {
252 case NEWSTMT : /* need a new statement */
253 if(getcds() == STEOF)
254 return(SEOF);
255 lastend = stkey == SEND;
256 crunch();
257 tokno = 0;
258 lexstate = FIRSTTOKEN;
259 yystno = stno;
260 stno = nxtstno;
261 toklen = 0;
262 return(SLABEL);
263
264 first:
265 case FIRSTTOKEN : /* first step on a statement */
266 analyz();
267 lexstate = OTHERTOKEN;
268 tokno = 1;
269 return(stkey);
270
271 case OTHERTOKEN : /* return next token */
272 if(nextch > lastch)
273 goto reteos;
274 ++tokno;
275 if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
276 goto first;
277
278 if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
279 nextch[0]=='t' && nextch[1]=='o')
280 {
281 nextch+=2;
282 return(STO);
283 }
284 return(gettok());
285
286 reteos:
287 case RETEOS:
288 lexstate = NEWSTMT;
289 return(SEOS);
290 }
291 fatali("impossible lexstate %d", lexstate);
292 /* NOTREACHED */
293 }
294
getcds()295 LOCAL getcds()
296 {
297 register char *p, *q;
298
299 if (newname)
300 {
301 free(infname);
302 infname = newname;
303 newname = NULL;
304 }
305
306 top:
307 if(nextcd == NULL)
308 {
309 code = getcd( nextcd = s );
310 stno = nxtstno;
311 if (newname)
312 {
313 free(infname);
314 infname = newname;
315 newname = NULL;
316 }
317 prevlin = thislin;
318 }
319 if(code == STEOF)
320 if( popinclude() )
321 goto top;
322 else
323 return(STEOF);
324
325 if(code == STCONTINUE)
326 {
327 if (newname)
328 {
329 free(infname);
330 infname = newname;
331 newname = NULL;
332 }
333 lineno = thislin;
334 err("illegal continuation card ignored");
335 nextcd = NULL;
336 goto top;
337 }
338
339 if(nextcd > s)
340 {
341 q = nextcd;
342 p = s;
343 while(q < endcd)
344 *p++ = *q++;
345 endcd = p;
346 }
347 for(nextcd = endcd ;
348 nextcd+66<=send && (code = getcd(nextcd))==STCONTINUE ;
349 nextcd = endcd )
350 ;
351 nextch = s;
352 lastch = nextcd - 1;
353 if(nextcd >= send)
354 nextcd = NULL;
355 lineno = prevlin;
356 prevlin = thislin;
357 return(STINITIAL);
358 }
359
getcd(b)360 LOCAL getcd(b)
361 register char *b;
362 {
363 register int c;
364 register char *p, *bend;
365 int speclin;
366 static char a[6];
367 static char *aend = a+6;
368 int num;
369
370 top:
371 endcd = b;
372 bend = b+66;
373 speclin = NO;
374
375 if( (c = getc(infile)) == '&')
376 {
377 a[0] = BLANK;
378 a[5] = 'x';
379 speclin = YES;
380 bend = send;
381 }
382 else if(c=='c' || c=='C' || c=='*')
383 {
384 while( (c = getc(infile)) != '\n')
385 if(c == EOF)
386 return(STEOF);
387 ++thislin;
388 goto top;
389 }
390 else if(c == '#')
391 {
392 c = getc(infile);
393 while (c == BLANK || c == '\t')
394 c = getc(infile);
395
396 num = 0;
397 while (isdigit(c))
398 {
399 num = 10*num + c - '0';
400 c = getc(infile);
401 }
402 thislin = num - 1;
403
404 while (c == BLANK || c == '\t')
405 c = getc(infile);
406
407 if (c == '"')
408 {
409 char fname[1024];
410 int len = 0;
411
412 c = getc(infile);
413 while (c != '"' && c != '\n')
414 {
415 fname[len++] = c;
416 c = getc(infile);
417 }
418 fname[len++] = '\0';
419
420 if (newname)
421 free(newname);
422 newname = (char *) ckalloc(len);
423 strcpy(newname, fname);
424 }
425
426 while (c != '\n')
427 if (c == EOF)
428 return (STEOF);
429 else
430 c = getc(infile);
431 goto top;
432 }
433
434 else if(c != EOF)
435 {
436 /* a tab in columns 1-6 skips to column 7 */
437 ungetc(c, infile);
438 for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
439 if(c == '\t')
440 {
441 while(p < aend)
442 *p++ = BLANK;
443 speclin = YES;
444 bend = send;
445 }
446 else
447 *p++ = c;
448 }
449 if(c == EOF)
450 return(STEOF);
451 if(c == '\n')
452 {
453 while(p < aend)
454 *p++ = BLANK;
455 if( ! speclin )
456 while(endcd < bend)
457 *endcd++ = BLANK;
458 }
459 else { /* read body of line */
460 while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
461 *endcd++ = c;
462 if(c == EOF)
463 return(STEOF);
464 if(c != '\n')
465 {
466 while( (c=getc(infile)) != '\n')
467 if(c == EOF)
468 return(STEOF);
469 }
470
471 if( ! speclin )
472 while(endcd < bend)
473 *endcd++ = BLANK;
474 }
475 ++thislin;
476 if( !isspace(a[5]) && a[5]!='0')
477 return(STCONTINUE);
478 for(p=a; p<aend; ++p)
479 if( !isspace(*p) ) goto initline;
480 for(p = b ; p<endcd ; ++p)
481 if( !isspace(*p) ) goto initline;
482 goto top;
483
484 initline:
485 nxtstno = 0;
486 for(p = a ; p<a+5 ; ++p)
487 if( !isspace(*p) )
488 if(isdigit(*p))
489 nxtstno = 10*nxtstno + (*p - '0');
490 else {
491 if (newname)
492 {
493 free(infname);
494 infname = newname;
495 newname = NULL;
496 }
497 lineno = thislin;
498 err("nondigit in statement number field");
499 nxtstno = 0;
500 break;
501 }
502 return(STINITIAL);
503 }
504
crunch()505 LOCAL crunch()
506 {
507 register char *i, *j, *j0, *j1, *prvstr;
508 int ten, nh, quote;
509
510 /* i is the next input character to be looked at
511 j is the next output character */
512 parlev = 0;
513 expcom = 0; /* exposed ','s */
514 expeql = 0; /* exposed equal signs */
515 j = s;
516 prvstr = s;
517 for(i=s ; i<=lastch ; ++i)
518 {
519 if(isspace(*i) )
520 continue;
521 if(*i=='\'' || *i=='"')
522 {
523 quote = *i;
524 *j = MYQUOTE; /* special marker */
525 for(;;)
526 {
527 if(++i > lastch)
528 {
529 err("unbalanced quotes; closing quote supplied");
530 break;
531 }
532 if(*i == quote)
533 if(i<lastch && i[1]==quote) ++i;
534 else break;
535 else if(*i=='\\' && i<lastch)
536 switch(*++i)
537 {
538 case 't':
539 *i = '\t'; break;
540 case 'b':
541 *i = '\b'; break;
542 case 'n':
543 *i = '\n'; break;
544 case 'f':
545 *i = '\f'; break;
546 case 'v':
547 *i = '\v'; break;
548 case '0':
549 *i = '\0'; break;
550 default:
551 break;
552 }
553 *++j = *i;
554 }
555 j[1] = MYQUOTE;
556 j += 2;
557 prvstr = j;
558 }
559 else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */
560 {
561 if( ! isdigit(j[-1])) goto copychar;
562 nh = j[-1] - '0';
563 ten = 10;
564 j1 = prvstr - 1;
565 if (j1<j-5) j1=j-5;
566 for(j0=j-2 ; j0>j1; -- j0)
567 {
568 if( ! isdigit(*j0 ) ) break;
569 nh += ten * (*j0-'0');
570 ten*=10;
571 }
572 if(j0 <= j1) goto copychar;
573 /* a hollerith must be preceded by a punctuation mark.
574 '*' is possible only as repetition factor in a data statement
575 not, in particular, in character*2h
576 */
577
578 if( !(*j0=='*'&&s[0]=='d') && *j0!='/' && *j0!='(' &&
579 *j0!=',' && *j0!='=' && *j0!='.')
580 goto copychar;
581 if(i+nh > lastch)
582 {
583 erri("%dH too big", nh);
584 nh = lastch - i;
585 }
586 j0[1] = MYQUOTE; /* special marker */
587 j = j0 + 1;
588 while(nh-- > 0)
589 {
590 if(*++i == '\\')
591 switch(*++i)
592 {
593 case 't':
594 *i = '\t'; break;
595 case 'b':
596 *i = '\b'; break;
597 case 'n':
598 *i = '\n'; break;
599 case 'f':
600 *i = '\f'; break;
601 case '0':
602 *i = '\0'; break;
603 default:
604 break;
605 }
606 *++j = *i;
607 }
608 j[1] = MYQUOTE;
609 j+=2;
610 prvstr = j;
611 }
612 else {
613 if(*i == '(') ++parlev;
614 else if(*i == ')') --parlev;
615 else if(parlev == 0)
616 if(*i == '=') expeql = 1;
617 else if(*i == ',') expcom = 1;
618 copychar: /*not a string or space -- copy, shifting case if necessary */
619 if(shiftcase && isupper(*i))
620 *j++ = tolower(*i);
621 else *j++ = *i;
622 }
623 }
624 lastch = j - 1;
625 nextch = s;
626 }
627
analyz()628 LOCAL analyz()
629 {
630 register char *i;
631
632 if(parlev != 0)
633 {
634 err("unbalanced parentheses, statement skipped");
635 stkey = SUNKNOWN;
636 return;
637 }
638 if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
639 {
640 /* assignment or if statement -- look at character after balancing paren */
641 parlev = 1;
642 for(i=nextch+3 ; i<=lastch; ++i)
643 if(*i == (MYQUOTE))
644 {
645 while(*++i != MYQUOTE)
646 ;
647 }
648 else if(*i == '(')
649 ++parlev;
650 else if(*i == ')')
651 {
652 if(--parlev == 0)
653 break;
654 }
655 if(i >= lastch)
656 stkey = SLOGIF;
657 else if(i[1] == '=')
658 stkey = SLET;
659 else if( isdigit(i[1]) )
660 stkey = SARITHIF;
661 else stkey = SLOGIF;
662 if(stkey != SLET)
663 nextch += 2;
664 }
665 else if(expeql) /* may be an assignment */
666 {
667 if(expcom && nextch<lastch &&
668 nextch[0]=='d' && nextch[1]=='o')
669 {
670 stkey = SDO;
671 nextch += 2;
672 }
673 else stkey = SLET;
674 }
675 /* otherwise search for keyword */
676 else {
677 stkey = getkwd();
678 if(stkey==SGOTO && lastch>=nextch)
679 if(nextch[0]=='(')
680 stkey = SCOMPGOTO;
681 else if(isalpha(nextch[0]))
682 stkey = SASGOTO;
683 }
684 parlev = 0;
685 }
686
687
688
getkwd()689 LOCAL getkwd()
690 {
691 register char *i, *j;
692 register struct Keylist *pk, *pend;
693 int k;
694
695 if(! isalpha(nextch[0]) )
696 return(SUNKNOWN);
697 k = nextch[0] - 'a';
698 if(pk = keystart[k])
699 for(pend = keyend[k] ; pk<=pend ; ++pk )
700 {
701 i = pk->keyname;
702 j = nextch;
703 while(*++i==*++j && *i!='\0')
704 ;
705 if(*i=='\0' && j<=lastch+1)
706 {
707 nextch = j;
708 #ifdef ONLY66
709 if(no66flag && pk->notinf66)
710 errstr("Not a Fortran 66 keyword: %s",
711 pk->keyname);
712 #endif
713 return(pk->keyval);
714 }
715 }
716 return(SUNKNOWN);
717 }
718
719
720
initkey()721 initkey()
722 {
723 extern struct Keylist keys[];
724 register struct Keylist *p;
725 register int i,j;
726
727 for(i = 0 ; i<26 ; ++i)
728 keystart[i] = NULL;
729
730 for(p = keys ; p->keyname ; ++p)
731 {
732 j = p->keyname[0] - 'a';
733 if(keystart[j] == NULL)
734 keystart[j] = p;
735 keyend[j] = p;
736 }
737 }
738
gettok()739 LOCAL gettok()
740 {
741 int havdot, havexp, havdbl;
742 int radix, val;
743 extern struct Punctlist puncts[];
744 struct Punctlist *pp;
745 extern struct Fmtlist fmts[];
746 extern struct Dotlist dots[];
747 struct Dotlist *pd;
748
749 char *i, *j, *n1, *p;
750
751 if(*nextch == (MYQUOTE))
752 {
753 ++nextch;
754 p = token;
755 while(nextch <= lastch && *nextch != MYQUOTE)
756 *p++ = *nextch++;
757 ++nextch;
758 toklen = p - token;
759 *p = '\0';
760 return (SHOLLERITH);
761 }
762 /*
763 if(stkey == SFORMAT)
764 {
765 for(pf = fmts; pf->fmtchar; ++pf)
766 {
767 if(*nextch == pf->fmtchar)
768 {
769 ++nextch;
770 if(pf->fmtval == SLPAR)
771 ++parlev;
772 else if(pf->fmtval == SRPAR)
773 --parlev;
774 return(pf->fmtval);
775 }
776 }
777 if( isdigit(*nextch) )
778 {
779 p = token;
780 *p++ = *nextch++;
781 while(nextch<=lastch && isdigit(*nextch) )
782 *p++ = *nextch++;
783 toklen = p - token;
784 *p = '\0';
785 if(nextch<=lastch && *nextch=='p')
786 {
787 ++nextch;
788 return(SSCALE);
789 }
790 else return(SICON);
791 }
792 if( isalpha(*nextch) )
793 {
794 p = token;
795 *p++ = *nextch++;
796 while(nextch<=lastch &&
797 (*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) ))
798 *p++ = *nextch++;
799 toklen = p - token;
800 *p = '\0';
801 return(SFIELD);
802 }
803 goto badchar;
804 }
805 /* Not a format statement */
806
807 if(needkwd)
808 {
809 needkwd = 0;
810 return( getkwd() );
811 }
812
813 for(pp=puncts; pp->punchar; ++pp)
814 if(*nextch == pp->punchar)
815 {
816 if( (*nextch=='*' || *nextch=='/') &&
817 nextch<lastch && nextch[1]==nextch[0])
818 {
819 if(*nextch == '*')
820 val = SPOWER;
821 else val = SCONCAT;
822 nextch+=2;
823 }
824 else {
825 val = pp->punval;
826 if(val==SLPAR)
827 ++parlev;
828 else if(val==SRPAR)
829 --parlev;
830 ++nextch;
831 }
832 return(val);
833 }
834 if(*nextch == '.')
835 if(nextch >= lastch) goto badchar;
836 else if(isdigit(nextch[1])) goto numconst;
837 else {
838 for(pd=dots ; (j=pd->dotname) ; ++pd)
839 {
840 for(i=nextch+1 ; i<=lastch ; ++i)
841 if(*i != *j) break;
842 else if(*i != '.') ++j;
843 else {
844 nextch = i+1;
845 return(pd->dotval);
846 }
847 }
848 goto badchar;
849 }
850 if( isalpha(*nextch) )
851 {
852 p = token;
853 *p++ = *nextch++;
854 while(nextch<=lastch)
855 if( isalpha(*nextch) || isdigit(*nextch) )
856 *p++ = *nextch++;
857 else break;
858 toklen = p - token;
859 *p = '\0';
860 if(inioctl && nextch<=lastch && *nextch=='=')
861 {
862 ++nextch;
863 return(SNAMEEQ);
864 }
865 if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) &&
866 nextch<lastch && nextch[0]=='(' &&
867 (nextch[1]==')' | isalpha(nextch[1])) )
868 {
869 nextch -= (toklen - 8);
870 return(SFUNCTION);
871 }
872 if(toklen > VL)
873 {
874 char buff[30];
875 sprintf(buff, "name %s too long, truncated to %d",
876 token, VL);
877 err(buff);
878 toklen = VL;
879 token[VL] = '\0';
880 }
881 if(toklen==1 && *nextch==MYQUOTE)
882 {
883 switch(token[0])
884 {
885 case 'z': case 'Z':
886 case 'x': case 'X':
887 radix = 16; break;
888 case 'o': case 'O':
889 radix = 8; break;
890 case 'b': case 'B':
891 radix = 2; break;
892 default:
893 err("bad bit identifier");
894 return(SNAME);
895 }
896 ++nextch;
897 for(p = token ; *nextch!=MYQUOTE ; )
898 if ( *nextch == BLANK || *nextch == '\t')
899 nextch++;
900 else
901 {
902 if (isupper(*nextch))
903 *nextch = tolower(*nextch);
904 if (hextoi(*p++ = *nextch++) >= radix)
905 {
906 err("invalid binary character");
907 break;
908 }
909 }
910 ++nextch;
911 toklen = p - token;
912 return( radix==16 ? SHEXCON :
913 (radix==8 ? SOCTCON : SBITCON) );
914 }
915 return(SNAME);
916 }
917 if( ! isdigit(*nextch) ) goto badchar;
918 numconst:
919 havdot = NO;
920 havexp = NO;
921 havdbl = NO;
922 for(n1 = nextch ; nextch<=lastch ; ++nextch)
923 {
924 if(*nextch == '.')
925 if(havdot) break;
926 else if(nextch+2<=lastch && isalpha(nextch[1])
927 && isalpha(nextch[2]))
928 break;
929 else havdot = YES;
930 else if( !intonly && (*nextch=='d' || *nextch=='e') )
931 {
932 p = nextch;
933 havexp = YES;
934 if(*nextch == 'd')
935 havdbl = YES;
936 if(nextch<lastch)
937 if(nextch[1]=='+' || nextch[1]=='-')
938 ++nextch;
939 if( (nextch >= lastch) || ! isdigit(*++nextch) )
940 {
941 nextch = p;
942 havdbl = havexp = NO;
943 break;
944 }
945 for(++nextch ;
946 nextch<=lastch && isdigit(*nextch);
947 ++nextch);
948 break;
949 }
950 else if( ! isdigit(*nextch) )
951 break;
952 }
953 p = token;
954 i = n1;
955 while(i < nextch)
956 *p++ = *i++;
957 toklen = p - token;
958 *p = '\0';
959 if(havdbl) return(SDCON);
960 if(havdot || havexp) return( dblflag ? SDCON : SRCON);
961 return(SICON);
962 badchar:
963 s[0] = *nextch++;
964 return(SUNKNOWN);
965 }
966
967 /* KEYWORD AND SPECIAL CHARACTER TABLES
968 */
969
970 struct Punctlist puncts[ ] =
971 {
972 '(', SLPAR,
973 ')', SRPAR,
974 '=', SEQUALS,
975 ',', SCOMMA,
976 '+', SPLUS,
977 '-', SMINUS,
978 '*', SSTAR,
979 '/', SSLASH,
980 '$', SCURRENCY,
981 ':', SCOLON,
982 0, 0 } ;
983
984 /*
985 LOCAL struct Fmtlist fmts[ ] =
986 {
987 '(', SLPAR,
988 ')', SRPAR,
989 '/', SSLASH,
990 ',', SCOMMA,
991 '-', SMINUS,
992 ':', SCOLON,
993 0, 0 } ;
994 */
995
996 LOCAL struct Dotlist dots[ ] =
997 {
998 "and.", SAND,
999 "or.", SOR,
1000 "not.", SNOT,
1001 "true.", STRUE,
1002 "false.", SFALSE,
1003 "eq.", SEQ,
1004 "ne.", SNE,
1005 "lt.", SLT,
1006 "le.", SLE,
1007 "gt.", SGT,
1008 "ge.", SGE,
1009 "neqv.", SNEQV,
1010 "eqv.", SEQV,
1011 0, 0 } ;
1012
1013 LOCAL struct Keylist keys[ ] =
1014 {
1015 { "assign", SASSIGN },
1016 { "automatic", SAUTOMATIC, YES },
1017 { "backspace", SBACKSPACE },
1018 { "blockdata", SBLOCK },
1019 { "call", SCALL },
1020 { "character", SCHARACTER, YES },
1021 { "close", SCLOSE, YES },
1022 { "common", SCOMMON },
1023 { "complex", SCOMPLEX },
1024 { "continue", SCONTINUE },
1025 { "data", SDATA },
1026 { "dimension", SDIMENSION },
1027 { "doubleprecision", SDOUBLE },
1028 { "doublecomplex", SDCOMPLEX, YES },
1029 { "elseif", SELSEIF, YES },
1030 { "else", SELSE, YES },
1031 { "endfile", SENDFILE },
1032 { "endif", SENDIF, YES },
1033 { "end", SEND },
1034 { "entry", SENTRY, YES },
1035 { "equivalence", SEQUIV },
1036 { "external", SEXTERNAL },
1037 { "format", SFORMAT },
1038 { "function", SFUNCTION },
1039 { "goto", SGOTO },
1040 { "implicit", SIMPLICIT, YES },
1041 { "include", SINCLUDE, YES },
1042 { "inquire", SINQUIRE, YES },
1043 { "intrinsic", SINTRINSIC, YES },
1044 { "integer", SINTEGER },
1045 { "logical", SLOGICAL },
1046 #ifdef NAMELIST
1047 { "namelist", SNAMELIST, YES },
1048 #endif
1049 { "none", SUNDEFINED, YES },
1050 { "open", SOPEN, YES },
1051 { "parameter", SPARAM, YES },
1052 { "pause", SPAUSE },
1053 { "print", SPRINT },
1054 { "program", SPROGRAM, YES },
1055 { "punch", SPUNCH, YES },
1056 { "read", SREAD },
1057 { "real", SREAL },
1058 { "return", SRETURN },
1059 { "rewind", SREWIND },
1060 { "save", SSAVE, YES },
1061 { "static", SSTATIC, YES },
1062 { "stop", SSTOP },
1063 { "subroutine", SSUBROUTINE },
1064 { "then", STHEN, YES },
1065 { "undefined", SUNDEFINED, YES },
1066 { "write", SWRITE },
1067 { 0, 0 }
1068 };
1069