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