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