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