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