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