![[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 [Research Unix] / researchv10no / cmd / f2c|
Return to lex.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1992 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: #include "defs.h"
25: #include "tokdefs.h"
26: #include "p1defs.h"
27:
28: #ifdef NO_EOF_CHAR_CHECK
29: #undef EOF_CHAR
30: #else
31: #ifndef EOF_CHAR
32: #define EOF_CHAR 26 /* ASCII control-Z */
33: #endif
34: #endif
35:
36: #define BLANK ' '
37: #define MYQUOTE (2)
38: #define SEOF 0
39:
40: /* card types */
41:
42: #define STEOF 1
43: #define STINITIAL 2
44: #define STCONTINUE 3
45:
46: /* lex states */
47:
48: #define NEWSTMT 1
49: #define FIRSTTOKEN 2
50: #define OTHERTOKEN 3
51: #define RETEOS 4
52:
53:
54: LOCAL int stkey; /* Type of the current statement (DO, END, IF, etc) */
55: extern char token[]; /* holds the actual token text */
56: static int needwkey;
57: ftnint yystno;
58: flag intonly;
59: extern int new_dcl;
60: LOCAL long int stno;
61: LOCAL long int nxtstno; /* Statement label */
62: LOCAL int parlev; /* Parentheses level */
63: LOCAL int parseen;
64: LOCAL int expcom;
65: LOCAL int expeql;
66: LOCAL char *nextch;
67: LOCAL char *lastch;
68: LOCAL char *nextcd = NULL;
69: LOCAL char *endcd;
70: LOCAL long prevlin;
71: LOCAL long thislin;
72: LOCAL int code; /* Card type; INITIAL, CONTINUE or EOF */
73: LOCAL int lexstate = NEWSTMT;
74: LOCAL char *sbuf; /* Main buffer for Fortran source input. */
75: LOCAL char *send; /* Was = sbuf+20*66 with sbuf[1390]. */
76: LOCAL int maxcont;
77: LOCAL int nincl = 0; /* Current number of include files */
78: LOCAL long firstline;
79: LOCAL char *laststb, *stb0;
80: extern int addftnsrc;
81: static char **linestart;
82: LOCAL int ncont;
83: LOCAL char comstart[Table_size];
84: #define USC (unsigned char *)
85:
86: static char anum_buf[Table_size];
87: #define isalnum_(x) anum_buf[x]
88: #define isalpha_(x) (anum_buf[x] == 1)
89:
90: #define COMMENT_BUF_STORE 4088
91:
92: typedef struct comment_buf {
93: struct comment_buf *next;
94: char *last;
95: char buf[COMMENT_BUF_STORE];
96: } comment_buf;
97: static comment_buf *cbfirst, *cbcur;
98: static char *cbinit, *cbnext, *cblast;
99: static void flush_comments();
100: extern flag use_bs;
101:
102:
103: /* Comment buffering data
104:
105: Comments are kept in a list until the statement before them has
106: been parsed. This list is implemented with the above comment_buf
107: structure and the pointers cbnext and cblast.
108:
109: The comments are stored with terminating NULL, and no other
110: intervening space. The last few bytes of each block are likely to
111: remain unused.
112: */
113:
114: /* struct Inclfile holds the state information for each include file */
115: struct Inclfile
116: {
117: struct Inclfile *inclnext;
118: FILEP inclfp;
119: char *inclname;
120: int incllno;
121: char *incllinp;
122: int incllen;
123: int inclcode;
124: ftnint inclstno;
125: };
126:
127: LOCAL struct Inclfile *inclp = NULL;
128: struct Keylist {
129: char *keyname;
130: int keyval;
131: char notinf66;
132: };
133: struct Punctlist {
134: char punchar;
135: int punval;
136: };
137: struct Fmtlist {
138: char fmtchar;
139: int fmtval;
140: };
141: struct Dotlist {
142: char *dotname;
143: int dotval;
144: };
145: LOCAL struct Keylist *keystart[26], *keyend[26];
146:
147: /* KEYWORD AND SPECIAL CHARACTER TABLES
148: */
149:
150: static struct Punctlist puncts[ ] =
151: {
152: '(', SLPAR,
153: ')', SRPAR,
154: '=', SEQUALS,
155: ',', SCOMMA,
156: '+', SPLUS,
157: '-', SMINUS,
158: '*', SSTAR,
159: '/', SSLASH,
160: '$', SCURRENCY,
161: ':', SCOLON,
162: '<', SLT,
163: '>', SGT,
164: 0, 0 };
165:
166: LOCAL struct Dotlist dots[ ] =
167: {
168: "and.", SAND,
169: "or.", SOR,
170: "not.", SNOT,
171: "true.", STRUE,
172: "false.", SFALSE,
173: "eq.", SEQ,
174: "ne.", SNE,
175: "lt.", SLT,
176: "le.", SLE,
177: "gt.", SGT,
178: "ge.", SGE,
179: "neqv.", SNEQV,
180: "eqv.", SEQV,
181: 0, 0 };
182:
183: LOCAL struct Keylist keys[ ] =
184: {
185: { "assign", SASSIGN },
186: { "automatic", SAUTOMATIC, YES },
187: { "backspace", SBACKSPACE },
188: { "blockdata", SBLOCK },
189: { "call", SCALL },
190: { "character", SCHARACTER, YES },
191: { "close", SCLOSE, YES },
192: { "common", SCOMMON },
193: { "complex", SCOMPLEX },
194: { "continue", SCONTINUE },
195: { "data", SDATA },
196: { "dimension", SDIMENSION },
197: { "doubleprecision", SDOUBLE },
198: { "doublecomplex", SDCOMPLEX, YES },
199: { "elseif", SELSEIF, YES },
200: { "else", SELSE, YES },
201: { "endfile", SENDFILE },
202: { "endif", SENDIF, YES },
203: { "enddo", SENDDO, YES },
204: { "end", SEND },
205: { "entry", SENTRY, YES },
206: { "equivalence", SEQUIV },
207: { "external", SEXTERNAL },
208: { "format", SFORMAT },
209: { "function", SFUNCTION },
210: { "goto", SGOTO },
211: { "implicit", SIMPLICIT, YES },
212: { "include", SINCLUDE, YES },
213: { "inquire", SINQUIRE, YES },
214: { "intrinsic", SINTRINSIC, YES },
215: { "integer", SINTEGER },
216: { "logical", SLOGICAL },
217: { "namelist", SNAMELIST, YES },
218: { "none", SUNDEFINED, YES },
219: { "open", SOPEN, YES },
220: { "parameter", SPARAM, YES },
221: { "pause", SPAUSE },
222: { "print", SPRINT },
223: { "program", SPROGRAM, YES },
224: { "punch", SPUNCH, YES },
225: { "read", SREAD },
226: { "real", SREAL },
227: { "return", SRETURN },
228: { "rewind", SREWIND },
229: { "save", SSAVE, YES },
230: { "static", SSTATIC, YES },
231: { "stop", SSTOP },
232: { "subroutine", SSUBROUTINE },
233: { "then", STHEN, YES },
234: { "undefined", SUNDEFINED, YES },
235: { "while", SWHILE, YES },
236: { "write", SWRITE },
237: { 0, 0 }
238: };
239:
240: LOCAL void analyz(), crunch(), store_comment();
241: LOCAL int getcd(), getcds(), getkwd(), gettok();
242: LOCAL char *stbuf[3];
243:
244: inilex(name)
245: char *name;
246: {
247: stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
248: stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
249: stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
250: nincl = 0;
251: inclp = NULL;
252: doinclude(name);
253: lexstate = NEWSTMT;
254: return(NO);
255: }
256:
257:
258:
259: /* throw away the rest of the current line */
260: flline()
261: {
262: lexstate = RETEOS;
263: }
264:
265:
266:
267: char *lexline(n)
268: int *n;
269: {
270: *n = (lastch - nextch) + 1;
271: return(nextch);
272: }
273:
274:
275:
276:
277:
278: doinclude(name)
279: char *name;
280: {
281: FILEP fp;
282: struct Inclfile *t;
283:
284: if(inclp)
285: {
286: inclp->incllno = thislin;
287: inclp->inclcode = code;
288: inclp->inclstno = nxtstno;
289: if(nextcd)
290: inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
291: else
292: inclp->incllinp = 0;
293: }
294: nextcd = NULL;
295:
296: if(++nincl >= MAXINCLUDES)
297: Fatal("includes nested too deep");
298: if(name[0] == '\0')
299: fp = stdin;
300: else
301: fp = fopen(name, textread);
302: if (fp)
303: {
304: t = inclp;
305: inclp = ALLOC(Inclfile);
306: inclp->inclnext = t;
307: prevlin = thislin = 0;
308: infname = inclp->inclname = name;
309: infile = inclp->inclfp = fp;
310: }
311: else
312: {
313: fprintf(diagfile, "Cannot open file %s\n", name);
314: done(1);
315: }
316: }
317:
318:
319:
320:
321: LOCAL popinclude()
322: {
323: struct Inclfile *t;
324: register char *p;
325: register int k;
326:
327: if(infile != stdin)
328: clf(&infile, infname, 1); /* Close the input file */
329: free(infname);
330:
331: --nincl;
332: t = inclp->inclnext;
333: free( (charptr) inclp);
334: inclp = t;
335: if(inclp == NULL) {
336: infname = 0;
337: return(NO);
338: }
339:
340: infile = inclp->inclfp;
341: infname = inclp->inclname;
342: prevlin = thislin = inclp->incllno;
343: code = inclp->inclcode;
344: stno = nxtstno = inclp->inclstno;
345: if(inclp->incllinp)
346: {
347: endcd = nextcd = sbuf;
348: k = inclp->incllen;
349: p = inclp->incllinp;
350: while(--k >= 0)
351: *endcd++ = *p++;
352: free( (charptr) (inclp->incllinp) );
353: }
354: else
355: nextcd = NULL;
356: return(YES);
357: }
358:
359: static void
360: putlineno()
361: {
362: static long lastline;
363: static char *lastfile = "??", *lastfile0 = "?";
364: static char fbuf[P1_FILENAME_MAX];
365: extern int gflag;
366: register char *s0, *s1;
367:
368: if (gflag) {
369: if (lastline) {
370: if (lastfile != lastfile0) {
371: p1puts(P1_FILENAME, fbuf);
372: lastfile0 = lastfile;
373: }
374: p1_line_number(lastline);
375: }
376: lastline = firstline;
377: if (lastfile != infname)
378: if (lastfile = infname) {
379: strncpy(fbuf, lastfile, sizeof(fbuf));
380: fbuf[sizeof(fbuf)-1] = 0;
381: }
382: else
383: fbuf[0] = 0;
384: }
385: if (addftnsrc) {
386: if (laststb && *laststb) {
387: for(s1 = laststb; *s1; s1++) {
388: for(s0 = s1; *s1 != '\n'; s1++)
389: if (*s1 == '*' && s1[1] == '/')
390: *s1 = '+';
391: *s1 = 0;
392: p1puts(P1_FORTRAN, s0);
393: }
394: *laststb = 0; /* prevent trouble after EOF */
395: }
396: laststb = stb0;
397: }
398: }
399:
400:
401: yylex()
402: {
403: static int tokno;
404: int retval;
405:
406: switch(lexstate)
407: {
408: case NEWSTMT : /* need a new statement */
409: retval = getcds();
410: putlineno();
411: if(retval == STEOF) {
412: retval = SEOF;
413: break;
414: } /* if getcds() == STEOF */
415: crunch();
416: tokno = 0;
417: lexstate = FIRSTTOKEN;
418: yystno = stno;
419: stno = nxtstno;
420: toklen = 0;
421: retval = SLABEL;
422: break;
423:
424: first:
425: case FIRSTTOKEN : /* first step on a statement */
426: analyz();
427: lexstate = OTHERTOKEN;
428: tokno = 1;
429: retval = stkey;
430: break;
431:
432: case OTHERTOKEN : /* return next token */
433: if(nextch > lastch)
434: goto reteos;
435: ++tokno;
436: if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
437: goto first;
438:
439: if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
440: nextch[0]=='t' && nextch[1]=='o')
441: {
442: nextch+=2;
443: retval = STO;
444: break;
445: }
446: retval = gettok();
447: break;
448:
449: reteos:
450: case RETEOS:
451: lexstate = NEWSTMT;
452: retval = SEOS;
453: break;
454: default:
455: fatali("impossible lexstate %d", lexstate);
456: break;
457: }
458:
459: if (retval == SEOF)
460: flush_comments ();
461:
462: return retval;
463: }
464:
465: LOCAL void
466: contmax()
467: {
468: lineno = thislin;
469: many("continuation lines", 'C', maxcontin);
470: }
471:
472: /* Get Cards.
473:
474: Returns STEOF or STINITIAL, never STCONTINUE. Any continuation cards get
475: merged into one long card (hence the size of the buffer named sbuf) */
476:
477: LOCAL int
478: getcds()
479: {
480: register char *p, *q;
481:
482: flush_comments ();
483: top:
484: if(nextcd == NULL)
485: {
486: code = getcd( nextcd = sbuf, 1 );
487: stno = nxtstno;
488: prevlin = thislin;
489: }
490: if(code == STEOF)
491: if( popinclude() )
492: goto top;
493: else
494: return(STEOF);
495:
496: if(code == STCONTINUE)
497: {
498: lineno = thislin;
499: nextcd = NULL;
500: goto top;
501: }
502:
503: /* Get rid of unused space at the head of the buffer */
504:
505: if(nextcd > sbuf)
506: {
507: q = nextcd;
508: p = sbuf;
509: while(q < endcd)
510: *p++ = *q++;
511: endcd = p;
512: }
513:
514: /* Be aware that the input (i.e. the string at the address nextcd) is NOT
515: NULL-terminated */
516:
517: /* This loop merges all continuations into one long statement, AND puts the next
518: card to be read at the end of the buffer (i.e. it stores the look-ahead card
519: when there's room) */
520:
521: ncont = 0;
522: for(;;) {
523: nextcd = endcd;
524: if (ncont >= maxcont || nextcd+66 > send)
525: contmax();
526: linestart[ncont++] = nextcd;
527: if ((code = getcd(nextcd,0)) != STCONTINUE)
528: break;
529: if (ncont == 20 && noextflag) {
530: lineno = thislin;
531: errext("more than 19 continuation lines");
532: }
533: }
534: nextch = sbuf;
535: lastch = nextcd - 1;
536:
537: lineno = prevlin;
538: prevlin = thislin;
539: return(STINITIAL);
540: }
541:
542: static void
543: bang(a,b,c,d,e) /* save ! comments */
544: char *a, *b, *c;
545: register char *d, *e;
546: {
547: char buf[COMMENT_BUFFER_SIZE + 1];
548: register char *p, *pe;
549:
550: p = buf;
551: pe = buf + COMMENT_BUFFER_SIZE;
552: *pe = 0;
553: while(a < b)
554: if (!(*p++ = *a++))
555: p[-1] = 0;
556: if (b < c)
557: *p++ = '\t';
558: while(d < e) {
559: if (!(*p++ = *d++))
560: p[-1] = ' ';
561: if (p == pe) {
562: store_comment(buf);
563: p = buf;
564: }
565: }
566: if (p > buf) {
567: while(--p >= buf && *p == ' ');
568: p[1] = 0;
569: store_comment(buf);
570: }
571: }
572:
573:
574: /* getcd - Get next input card
575:
576: This function reads the next input card from global file pointer infile.
577: It assumes that b points to currently empty storage somewhere in sbuf */
578:
579: LOCAL int
580: getcd(b, nocont)
581: register char *b;
582: {
583: register int c;
584: register char *p, *bend;
585: int speclin; /* Special line - true when the line is allowed
586: to have more than 66 characters (e.g. the
587: "&" shorthand for continuation, use of a "\t"
588: to skip part of the label columns) */
589: static char a[6]; /* Statement label buffer */
590: static char *aend = a+6;
591: static char *stb, *stbend;
592: static int nst;
593: char *atend, *endcd0;
594: extern int warn72;
595: char buf72[24];
596: int amp, i;
597: char storage[COMMENT_BUFFER_SIZE + 1];
598: char *pointer;
599:
600: top:
601: endcd = b;
602: bend = b+66;
603: amp = speclin = NO;
604: atend = aend;
605:
606: /* Handle the continuation shorthand of "&" in the first column, which stands
607: for " x" */
608:
609: if( (c = getc(infile)) == '&')
610: {
611: a[0] = c;
612: a[1] = 0;
613: a[5] = 'x';
614: amp = speclin = YES;
615: bend = send;
616: p = aend;
617: }
618:
619: /* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
620:
621: else if(comstart[c & 0xfff])
622: {
623: if (feof (infile)
624: #ifdef EOF_CHAR
625: || c == EOF_CHAR
626: #endif
627: )
628: return STEOF;
629:
630: storage[COMMENT_BUFFER_SIZE] = c = '\0';
631: pointer = storage;
632: while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
633:
634: /* Handle obscure end of file conditions on many machines */
635:
636: if (feof (infile) && (c == '\377' || c == EOF)) {
637: pointer--;
638: break;
639: } /* if (feof (infile)) */
640:
641: if (c == '\0')
642: *(pointer - 1) = ' ';
643:
644: if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
645: store_comment (storage);
646: pointer = storage;
647: } /* if (pointer == BUFFER_SIZE) */
648: } /* while */
649:
650: if (pointer > storage) {
651: if (c == '\n')
652:
653: /* Get rid of the newline */
654:
655: pointer[-1] = 0;
656: else
657: *pointer = 0;
658:
659: store_comment (storage);
660: } /* if */
661:
662: if (feof (infile))
663: if (c != '\n') /* To allow the line index to
664: increment correctly */
665: return STEOF;
666:
667: ++thislin;
668: goto top;
669: }
670:
671: else if(c != EOF)
672: {
673:
674: /* Load buffer a with the statement label */
675:
676: /* a tab in columns 1-6 skips to column 7 */
677: ungetc(c, infile);
678: for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
679: if(c == '\t')
680:
681: /* The tab character translates into blank characters in the statement label */
682:
683: {
684: atend = p;
685: while(p < aend)
686: *p++ = BLANK;
687: speclin = YES;
688: bend = send;
689: }
690: else
691: *p++ = c;
692: }
693:
694: /* By now we've read either a continuation character or the statement label
695: field */
696:
697: if(c == EOF)
698: return(STEOF);
699:
700: /* The next 'if' block handles lines that have fewer than 7 characters */
701:
702: if(c == '\n')
703: {
704: while(p < aend)
705: *p++ = BLANK;
706:
707: /* Blank out the buffer on lines which are not longer than 66 characters */
708:
709: endcd0 = endcd;
710: if( ! speclin )
711: while(endcd < bend)
712: *endcd++ = BLANK;
713: }
714: else { /* read body of line */
715: if (warn72 & 2) {
716: speclin = YES;
717: bend = send;
718: }
719: while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
720: *endcd++ = c;
721: if(c == EOF)
722: return(STEOF);
723:
724: /* Drop any extra characters on the input card; this usually means those after
725: column 72 */
726:
727: if(c != '\n')
728: {
729: i = 0;
730: while( (c=getc(infile)) != '\n' && c != EOF)
731: if (i < 23)
732: buf72[i++] = c;
733: if (warn72 && i && !speclin) {
734: buf72[i] = 0;
735: if (i >= 23)
736: strcpy(buf72+20, "...");
737: lineno = thislin + 1;
738: errstr("text after column 72: %s", buf72);
739: }
740: if(c == EOF)
741: return(STEOF);
742: }
743:
744: endcd0 = endcd;
745: if( ! speclin )
746: while(endcd < bend)
747: *endcd++ = BLANK;
748: }
749:
750: /* The flow of control usually gets to this line (unless an earlier RETURN has
751: been taken) */
752:
753: ++thislin;
754:
755: /* Fortran 77 specifies that a 0 in column 6 */
756: /* does not signify continuation */
757:
758: if( !isspace(a[5]) && a[5]!='0') {
759: if (!amp)
760: for(p = a; p < aend;)
761: if (*p++ == '!' && p != aend)
762: goto initcheck;
763: if (addftnsrc && stb) {
764: if (stbend > stb + 7) { /* otherwise forget col 1-6 */
765: /* kludge around funny p1gets behavior */
766: *stb++ = '$';
767: if (amp)
768: *stb++ = '&';
769: else
770: for(p = a; p < atend;)
771: *stb++ = *p++;
772: }
773: if (endcd0 - b > stbend - stb) {
774: if (stb > stbend)
775: stb = stbend;
776: endcd0 = b + (stbend - stb);
777: }
778: for(p = b; p < endcd0;)
779: *stb++ = *p++;
780: *stb++ = '\n';
781: *stb = 0;
782: }
783: if (nocont) {
784: lineno = thislin;
785: errstr("illegal continuation card (starts \"%.6s\")",a);
786: }
787: else if (!amp && strncmp(a," ",5)) {
788: lineno = thislin;
789: errstr("labeled continuation line (starts \"%.6s\")",a);
790: }
791: return(STCONTINUE);
792: }
793: initcheck:
794: for(p=a; p<atend; ++p)
795: if( !isspace(*p) ) {
796: if (*p++ != '!')
797: goto initline;
798: bang(p, atend, aend, b, endcd);
799: goto top;
800: }
801: for(p = b ; p<endcd ; ++p)
802: if( !isspace(*p) ) {
803: if (*p++ != '!')
804: goto initline;
805: bang(a, a, a, p, endcd);
806: goto top;
807: }
808:
809: /* Skip over blank cards by reading the next one right away */
810:
811: goto top;
812:
813: initline:
814: if (addftnsrc) {
815: nst = (nst+1)%3;
816: if (!laststb && stb0)
817: laststb = stb0;
818: stb0 = stb = stbuf[nst];
819: *stb++ = '$'; /* kludge around funny p1gets behavior */
820: stbend = stb + sizeof(stbuf[0])-2;
821: for(p = a; p < atend;)
822: *stb++ = *p++;
823: if (atend < aend)
824: *stb++ = '\t';
825: for(p = b; p < endcd0;)
826: *stb++ = *p++;
827: *stb++ = '\n';
828: *stb = 0;
829: }
830:
831: /* Set nxtstno equal to the integer value of the statement label */
832:
833: nxtstno = 0;
834: bend = a + 5;
835: for(p = a ; p < bend ; ++p)
836: if( !isspace(*p) )
837: if(isdigit(*p))
838: nxtstno = 10*nxtstno + (*p - '0');
839: else if (*p == '!') {
840: if (!addftnsrc)
841: bang(p+1,atend,aend,b,endcd);
842: endcd = b;
843: break;
844: }
845: else {
846: lineno = thislin;
847: errstr(
848: "nondigit in statement label field \"%.5s\"", a);
849: nxtstno = 0;
850: break;
851: }
852: firstline = thislin;
853: return(STINITIAL);
854: }
855:
856:
857: /* crunch -- deletes all space characters, folds the backslash chars and
858: Hollerith strings, quotes the Fortran strings */
859:
860: LOCAL void
861: crunch()
862: {
863: register char *i, *j, *j0, *j1, *prvstr;
864: int k, ten, nh, nh0, quote;
865:
866: /* i is the next input character to be looked at
867: j is the next output character */
868:
869: new_dcl = needwkey = parlev = parseen = 0;
870: expcom = 0; /* exposed ','s */
871: expeql = 0; /* exposed equal signs */
872: j = sbuf;
873: prvstr = sbuf;
874: k = 0;
875: for(i=sbuf ; i<=lastch ; ++i)
876: {
877: if(isspace(*i) )
878: continue;
879: if (*i == '!') {
880: while(i >= linestart[k])
881: if (++k >= maxcont)
882: contmax();
883: j0 = linestart[k];
884: if (!addftnsrc)
885: bang(sbuf,sbuf,sbuf,i+1,j0);
886: i = j0-1;
887: continue;
888: }
889:
890: /* Keep everything in a quoted string */
891:
892: if(*i=='\'' || *i=='"')
893: {
894: int len = 0;
895:
896: quote = *i;
897: *j = MYQUOTE; /* special marker */
898: for(;;)
899: {
900: if(++i > lastch)
901: {
902: err("unbalanced quotes; closing quote supplied");
903: if (j >= lastch)
904: j = lastch - 1;
905: break;
906: }
907: if(*i == quote)
908: if(i<lastch && i[1]==quote) ++i;
909: else break;
910: else if(*i=='\\' && i<lastch && use_bs) {
911: ++i;
912: *i = escapes[*(unsigned char *)i];
913: }
914: if (len + 2 < MAXTOKENLEN)
915: *++j = *i;
916: else if (len + 2 == MAXTOKENLEN)
917: erri
918: ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
919: len++;
920: } /* for (;;) */
921:
922: j[1] = MYQUOTE;
923: j += 2;
924: prvstr = j;
925: }
926: else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */
927: {
928: j0 = j - 1;
929: if( ! isdigit(*j0)) goto copychar;
930: nh = *j0 - '0';
931: ten = 10;
932: j1 = prvstr;
933: if (j1+4 < j)
934: j1 = j-4;
935: for(;;) {
936: if (j0-- <= j1)
937: goto copychar;
938: if( ! isdigit(*j0 ) ) break;
939: nh += ten * (*j0-'0');
940: ten*=10;
941: }
942: /* a hollerith must be preceded by a punctuation mark.
943: '*' is possible only as repetition factor in a data statement
944: not, in particular, in character*2h
945: */
946:
947: if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
948: && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
949: goto copychar;
950: nh0 = nh;
951: if(i+nh > lastch || nh + 2 > MAXTOKENLEN)
952: {
953: erri("%dH too big", nh);
954: nh = lastch - i;
955: if (nh > MAXTOKENLEN - 2)
956: nh = MAXTOKENLEN - 2;
957: nh0 = -1;
958: }
959: j0[1] = MYQUOTE; /* special marker */
960: j = j0 + 1;
961: while(nh-- > 0)
962: {
963: if (++i > lastch) {
964: hol_overflow:
965: if (nh0 >= 0)
966: erri("escapes make %dH too big",
967: nh0);
968: break;
969: }
970: if(*i == '\\' && use_bs) {
971: if (++i > lastch)
972: goto hol_overflow;
973: *i = escapes[*(unsigned char *)i];
974: }
975: *++j = *i;
976: }
977: j[1] = MYQUOTE;
978: j+=2;
979: prvstr = j;
980: }
981: else {
982: if(*i == '(') parseen = ++parlev;
983: else if(*i == ')') --parlev;
984: else if(parlev == 0)
985: if(*i == '=') expeql = 1;
986: else if(*i == ',') expcom = 1;
987: copychar: /*not a string or space -- copy, shifting case if necessary */
988: if(shiftcase && isupper(*i))
989: *j++ = tolower(*i);
990: else *j++ = *i;
991: }
992: }
993: lastch = j - 1;
994: nextch = sbuf;
995: }
996:
997: LOCAL void
998: analyz()
999: {
1000: register char *i;
1001:
1002: if(parlev != 0)
1003: {
1004: err("unbalanced parentheses, statement skipped");
1005: stkey = SUNKNOWN;
1006: lastch = sbuf - 1; /* prevent double error msg */
1007: return;
1008: }
1009: if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
1010: {
1011: /* assignment or if statement -- look at character after balancing paren */
1012: parlev = 1;
1013: for(i=nextch+3 ; i<=lastch; ++i)
1014: if(*i == (MYQUOTE))
1015: {
1016: while(*++i != MYQUOTE)
1017: ;
1018: }
1019: else if(*i == '(')
1020: ++parlev;
1021: else if(*i == ')')
1022: {
1023: if(--parlev == 0)
1024: break;
1025: }
1026: if(i >= lastch)
1027: stkey = SLOGIF;
1028: else if(i[1] == '=')
1029: stkey = SLET;
1030: else if( isdigit(i[1]) )
1031: stkey = SARITHIF;
1032: else stkey = SLOGIF;
1033: if(stkey != SLET)
1034: nextch += 2;
1035: }
1036: else if(expeql) /* may be an assignment */
1037: {
1038: if(expcom && nextch<lastch &&
1039: nextch[0]=='d' && nextch[1]=='o')
1040: {
1041: stkey = SDO;
1042: nextch += 2;
1043: }
1044: else stkey = SLET;
1045: }
1046: else if (parseen && nextch + 7 < lastch
1047: && nextch[2] != 'u' /* screen out "double..." early */
1048: && nextch[0] == 'd' && nextch[1] == 'o'
1049: && ((nextch[2] >= '0' && nextch[2] <= '9')
1050: || nextch[2] == ','
1051: || nextch[2] == 'w'))
1052: {
1053: stkey = SDO;
1054: nextch += 2;
1055: needwkey = 1;
1056: }
1057: /* otherwise search for keyword */
1058: else {
1059: stkey = getkwd();
1060: if(stkey==SGOTO && lastch>=nextch)
1061: if(nextch[0]=='(')
1062: stkey = SCOMPGOTO;
1063: else if(isalpha_(* USC nextch))
1064: stkey = SASGOTO;
1065: }
1066: parlev = 0;
1067: }
1068:
1069:
1070:
1071: LOCAL int
1072: getkwd()
1073: {
1074: register char *i, *j;
1075: register struct Keylist *pk, *pend;
1076: int k;
1077:
1078: if(! isalpha_(* USC nextch) )
1079: return(SUNKNOWN);
1080: k = letter(nextch[0]);
1081: if(pk = keystart[k])
1082: for(pend = keyend[k] ; pk<=pend ; ++pk )
1083: {
1084: i = pk->keyname;
1085: j = nextch;
1086: while(*++i==*++j && *i!='\0')
1087: ;
1088: if(*i=='\0' && j<=lastch+1)
1089: {
1090: nextch = j;
1091: if(no66flag && pk->notinf66)
1092: errstr("Not a Fortran 66 keyword: %s",
1093: pk->keyname);
1094: return(pk->keyval);
1095: }
1096: }
1097: return(SUNKNOWN);
1098: }
1099:
1100: initkey()
1101: {
1102: register struct Keylist *p;
1103: register int i,j;
1104: register char *s;
1105:
1106: for(i = 0 ; i<26 ; ++i)
1107: keystart[i] = NULL;
1108:
1109: for(p = keys ; p->keyname ; ++p) {
1110: j = letter(p->keyname[0]);
1111: if(keystart[j] == NULL)
1112: keystart[j] = p;
1113: keyend[j] = p;
1114: }
1115: i = (maxcontin + 2) * 66;
1116: sbuf = (char *)ckalloc(i + 70);
1117: send = sbuf + i;
1118: maxcont = maxcontin + 1;
1119: linestart = (char **)ckalloc(maxcont*sizeof(char*));
1120: comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1;
1121: #ifdef EOF_CHAR
1122: comstart[EOF_CHAR] = 1;
1123: #endif
1124: s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
1125: while(i = *s++)
1126: anum_buf[i] = 1;
1127: s = "0123456789";
1128: while(i = *s++)
1129: anum_buf[i] = 2;
1130: }
1131:
1132: LOCAL int
1133: hexcheck(key)
1134: int key;
1135: {
1136: register int radix;
1137: register char *p;
1138: char *kind;
1139:
1140: switch(key) {
1141: case 'z':
1142: case 'Z':
1143: case 'x':
1144: case 'X':
1145: radix = 16;
1146: key = SHEXCON;
1147: kind = "hexadecimal";
1148: break;
1149: case 'o':
1150: case 'O':
1151: radix = 8;
1152: key = SOCTCON;
1153: kind = "octal";
1154: break;
1155: case 'b':
1156: case 'B':
1157: radix = 2;
1158: key = SBITCON;
1159: kind = "binary";
1160: break;
1161: default:
1162: err("bad bit identifier");
1163: return(SNAME);
1164: }
1165: for(p = token; *p; p++)
1166: if (hextoi(*p) >= radix) {
1167: errstr("invalid %s character", kind);
1168: break;
1169: }
1170: return key;
1171: }
1172:
1173: /* gettok -- moves the right amount of text from nextch into the token
1174: buffer. token initially contains garbage (leftovers from the prev token) */
1175:
1176: LOCAL int
1177: gettok()
1178: {
1179: int havdot, havexp, havdbl;
1180: int radix, val;
1181: struct Punctlist *pp;
1182: struct Dotlist *pd;
1183: register int ch;
1184:
1185: char *i, *j, *n1, *p;
1186:
1187: ch = * USC nextch;
1188: if(ch == (MYQUOTE))
1189: {
1190: ++nextch;
1191: p = token;
1192: while(*nextch != MYQUOTE)
1193: *p++ = *nextch++;
1194: toklen = p - token;
1195: *p = 0;
1196: /* allow octal, binary, hex constants of the form 'abc'x (etc.) */
1197: if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
1198: ++nextch;
1199: return hexcheck(val);
1200: }
1201: return (SHOLLERITH);
1202: }
1203:
1204: if(needkwd)
1205: {
1206: needkwd = 0;
1207: return( getkwd() );
1208: }
1209:
1210: for(pp=puncts; pp->punchar; ++pp)
1211: if(ch == pp->punchar) {
1212: val = pp->punval;
1213: if (++nextch <= lastch)
1214: switch(ch) {
1215: case '/':
1216: if (*nextch == '/') {
1217: nextch++;
1218: val = SCONCAT;
1219: }
1220: else if (new_dcl && parlev == 0)
1221: val = SSLASHD;
1222: return val;
1223: case '*':
1224: if (*nextch == '*') {
1225: nextch++;
1226: return SPOWER;
1227: }
1228: break;
1229: case '<':
1230: if (*nextch == '=') {
1231: nextch++;
1232: val = SLE;
1233: }
1234: if (*nextch == '>') {
1235: nextch++;
1236: val = SNE;
1237: }
1238: goto extchk;
1239: case '=':
1240: if (*nextch == '=') {
1241: nextch++;
1242: val = SEQ;
1243: goto extchk;
1244: }
1245: break;
1246: case '>':
1247: if (*nextch == '=') {
1248: nextch++;
1249: val = SGE;
1250: }
1251: extchk:
1252: NOEXT("Fortran 8x comparison operator");
1253: return val;
1254: }
1255: else if (ch == '/' && new_dcl && parlev == 0)
1256: return SSLASHD;
1257: switch(val) {
1258: case SLPAR:
1259: ++parlev;
1260: break;
1261: case SRPAR:
1262: --parlev;
1263: }
1264: return(val);
1265: }
1266: if(ch == '.')
1267: if(nextch >= lastch) goto badchar;
1268: else if(isdigit(nextch[1])) goto numconst;
1269: else {
1270: for(pd=dots ; (j=pd->dotname) ; ++pd)
1271: {
1272: for(i=nextch+1 ; i<=lastch ; ++i)
1273: if(*i != *j) break;
1274: else if(*i != '.') ++j;
1275: else {
1276: nextch = i+1;
1277: return(pd->dotval);
1278: }
1279: }
1280: goto badchar;
1281: }
1282: if( isalpha_(ch) )
1283: {
1284: p = token;
1285: *p++ = *nextch++;
1286: while(nextch<=lastch)
1287: if( isalnum_(* USC nextch) )
1288: *p++ = *nextch++;
1289: else break;
1290: toklen = p - token;
1291: *p = 0;
1292: if (needwkey) {
1293: needwkey = 0;
1294: if (toklen == 5
1295: && nextch <= lastch && *nextch == '(' /*)*/
1296: && !strcmp(token,"while"))
1297: return(SWHILE);
1298: }
1299: if(inioctl && nextch<=lastch && *nextch=='=')
1300: {
1301: ++nextch;
1302: return(SNAMEEQ);
1303: }
1304: if(toklen>8 && eqn(8,token,"function")
1305: && isalpha_(* USC (token+8)) &&
1306: nextch<lastch && nextch[0]=='(' &&
1307: (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
1308: {
1309: nextch -= (toklen - 8);
1310: return(SFUNCTION);
1311: }
1312:
1313: if(toklen > 50)
1314: {
1315: char buff[100];
1316: sprintf(buff, toklen >= 60
1317: ? "name %.56s... too long, truncated to %.*s"
1318: : "name %s too long, truncated to %.*s",
1319: token, 50, token);
1320: err(buff);
1321: toklen = 50;
1322: token[50] = '\0';
1323: }
1324: if(toklen==1 && *nextch==MYQUOTE) {
1325: val = token[0];
1326: ++nextch;
1327: for(p = token ; *nextch!=MYQUOTE ; )
1328: *p++ = *nextch++;
1329: ++nextch;
1330: toklen = p - token;
1331: *p = 0;
1332: return hexcheck(val);
1333: }
1334: return(SNAME);
1335: }
1336:
1337: if (isdigit(ch)) {
1338:
1339: /* Check for NAG's special hex constant */
1340:
1341: if (nextch[1] == '#'
1342: || nextch[2] == '#' && isdigit(nextch[1])) {
1343:
1344: radix = atoi (nextch);
1345: if (*++nextch != '#')
1346: nextch++;
1347: if (radix != 2 && radix != 8 && radix != 16) {
1348: erri("invalid base %d for constant, defaulting to hex",
1349: radix);
1350: radix = 16;
1351: } /* if */
1352: if (++nextch > lastch)
1353: goto badchar;
1354: for (p = token; hextoi(*nextch) < radix;) {
1355: *p++ = *nextch++;
1356: if (nextch > lastch)
1357: break;
1358: }
1359: toklen = p - token;
1360: *p = 0;
1361: return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
1362: SBITCON);
1363: }
1364: }
1365: else
1366: goto badchar;
1367: numconst:
1368: havdot = NO;
1369: havexp = NO;
1370: havdbl = NO;
1371: for(n1 = nextch ; nextch<=lastch ; ++nextch)
1372: {
1373: if(*nextch == '.')
1374: if(havdot) break;
1375: else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
1376: && isalpha_(* USC (nextch+2)))
1377: break;
1378: else havdot = YES;
1379: else if( !intonly && (*nextch=='d' || *nextch=='e') )
1380: {
1381: p = nextch;
1382: havexp = YES;
1383: if(*nextch == 'd')
1384: havdbl = YES;
1385: if(nextch<lastch)
1386: if(nextch[1]=='+' || nextch[1]=='-')
1387: ++nextch;
1388: if( ! isdigit(*++nextch) )
1389: {
1390: nextch = p;
1391: havdbl = havexp = NO;
1392: break;
1393: }
1394: for(++nextch ;
1395: nextch<=lastch && isdigit(* USC nextch);
1396: ++nextch);
1397: break;
1398: }
1399: else if( ! isdigit(* USC nextch) )
1400: break;
1401: }
1402: p = token;
1403: i = n1;
1404: while(i < nextch)
1405: *p++ = *i++;
1406: toklen = p - token;
1407: *p = 0;
1408: if(havdbl) return(SDCON);
1409: if(havdot || havexp) return(SRCON);
1410: return(SICON);
1411: badchar:
1412: sbuf[0] = *nextch++;
1413: return(SUNKNOWN);
1414: }
1415:
1416: /* Comment buffering code */
1417:
1418: static void
1419: store_comment(str)
1420: char *str;
1421: {
1422: int len;
1423: comment_buf *ncb;
1424:
1425: if (nextcd == sbuf) {
1426: flush_comments();
1427: p1_comment(str);
1428: return;
1429: }
1430: len = strlen(str) + 1;
1431: if (cbnext + len > cblast) {
1432: if (!cbcur || !(ncb = cbcur->next)) {
1433: ncb = (comment_buf *) Alloc(sizeof(comment_buf));
1434: if (cbcur) {
1435: cbcur->last = cbnext;
1436: cbcur->next = ncb;
1437: }
1438: else {
1439: cbfirst = ncb;
1440: cbinit = ncb->buf;
1441: }
1442: ncb->next = 0;
1443: }
1444: cbcur = ncb;
1445: cbnext = ncb->buf;
1446: cblast = cbnext + COMMENT_BUF_STORE;
1447: }
1448: strcpy(cbnext, str);
1449: cbnext += len;
1450: }
1451:
1452: static void
1453: flush_comments()
1454: {
1455: register char *s, *s1;
1456: register comment_buf *cb;
1457: if (cbnext == cbinit)
1458: return;
1459: cbcur->last = cbnext;
1460: for(cb = cbfirst;; cb = cb->next) {
1461: for(s = cb->buf; s < cb->last; s = s1) {
1462: /* compute s1 = new s value first, since */
1463: /* p1_comment may insert nulls into s */
1464: s1 = s + strlen(s) + 1;
1465: p1_comment(s);
1466: }
1467: if (cb == cbcur)
1468: break;
1469: }
1470: cbcur = cbfirst;
1471: cbnext = cbinit;
1472: cblast = cbnext + COMMENT_BUF_STORE;
1473: }
1474:
1475: void
1476: unclassifiable()
1477: {
1478: register char *s, *se;
1479:
1480: s = sbuf;
1481: se = lastch;
1482: if (se < sbuf)
1483: return;
1484: lastch = s - 1;
1485: if (se - s > 10)
1486: se = s + 10;
1487: for(; s < se; s++)
1488: if (*s == MYQUOTE) {
1489: se = s;
1490: break;
1491: }
1492: *se = 0;
1493: errstr("unclassifiable statement (starts \"%s\")", sbuf);
1494: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.