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