1 /*
2 * ratfor - A ratfor pre-processor in C.
3 * Derived from a pre-processor distributed by the
4 * University of Arizona. Closely corresponds to the
5 * pre-processor described in the "SOFTWARE TOOLS" book.
6 *
7 * By: oz
8 *
9 * Not deived from AT&T code.
10 *
11 * This code is in the public domain. In other words, all rights
12 * are granted to all recipients, "public" at large.
13 *
14 * Modification history:
15 *
16 * June 1985
17 * - Ken Yap's mods for F77 output. Currently
18 * available thru #define F77.
19 * - Two minor bug-fixes for sane output.
20 * June 1985
21 * - Improve front-end with getopt().
22 * User may specify -l n for starting label.
23 * - Retrofit switch statement handling. This code
24 * is borrowed from the SWTOOLS Ratfor.
25 *
26 * 05-28-91 W. Bauske IBM
27 * - ported to RS/6000
28 * - fixed line continuations
29 * - added -C option to leave comments in the source code
30 * - added % in column 1 to force copy to output
31 * - support both && and & for .and.
32 * - support both || and | for .or.
33 *
34 */
35
36 #include <stdio.h>
37 #include <unistd.h>
38
39 #if defined __stdc__ || defined __STDC__
40 #include <stdlib.h>
41 #endif
42
43 #include <string.h>
44
45 #include "ratdef.h"
46 #include "ratcom.h"
47
48 /* keywords: */
49
50 char sdo[3] = {
51 LETD,LETO,EOS};
52 char vdo[2] = {
53 LEXDO,EOS};
54
55 char sif[3] = {
56 LETI,LETF,EOS};
57 char vif[2] = {
58 LEXIF,EOS};
59
60 char selse[5] = {
61 LETE,LETL,LETS,LETE,EOS};
62 char velse[2] = {
63 LEXELSE,EOS};
64
65 #ifdef F77
66 char sthen[5] = {
67 LETT,LETH,LETE,LETN,EOS};
68
69 char sendif[6] = {
70 LETE,LETN,LETD,LETI,LETF,EOS};
71
72 #endif /* F77 */
73 char swhile[6] = {
74 LETW, LETH, LETI, LETL, LETE, EOS};
75 char vwhile[2] = {
76 LEXWHILE, EOS};
77
78 char ssbreak[6] = {
79 LETB, LETR, LETE, LETA, LETK, EOS};
80 char vbreak[2] = {
81 LEXBREAK, EOS};
82
83 char snext[5] = {
84 LETN,LETE, LETX, LETT, EOS};
85 char vnext[2] = {
86 LEXNEXT, EOS};
87
88 char sfor[4] = {
89 LETF,LETO, LETR, EOS};
90 char vfor[2] = {
91 LEXFOR, EOS};
92
93 char srept[7] = {
94 LETR, LETE, LETP, LETE, LETA, LETT, EOS};
95 char vrept[2] = {
96 LEXREPEAT, EOS};
97
98 char suntil[6] = {
99 LETU, LETN, LETT, LETI, LETL, EOS};
100 char vuntil[2] = {
101 LEXUNTIL, EOS};
102
103 char sswitch[7] = {
104 LETS, LETW, LETI, LETT, LETC, LETH, EOS};
105 char vswitch[2] = {
106 LEXSWITCH, EOS};
107
108 char scase[5] = {
109 LETC, LETA, LETS, LETE, EOS};
110 char vcase[2] = {
111 LEXCASE, EOS};
112
113 char sdefault[8] = {
114 LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS};
115 char vdefault[2] = {
116 LEXDEFAULT, EOS};
117
118 char sret[7] = {
119 LETR, LETE, LETT, LETU, LETR, LETN, EOS};
120 char vret[2] = {
121 LEXRETURN, EOS};
122
123 char sstr[7] = {
124 LETS, LETT, LETR, LETI, LETN, LETG, EOS};
125 char vstr[2] = {
126 LEXSTRING, EOS};
127
128 char deftyp[2] = {
129 DEFTYPE, EOS};
130
131 /* constant strings */
132
133 char *errmsg = "error at line ";
134 char *in = " in ";
135 char *ifnot = "if(.not.";
136 char *incl = "include";
137 char *fncn = "function";
138 char *def = "define";
139 char *bdef = "DEFINE";
140 char *contin = "continue";
141 char *rgoto = "goto ";
142 char *dat = "data ";
143 char *eoss = "EOS/";
144
145 extern S_CHAR ngetch();
146 char *progname;
147 int startlab = 23000; /* default start label */
148 int leaveC = NO; /* Flag for handling comments */
149
150 /*
151 * M A I N L I N E & I N I T
152 */
153
main(argc,argv)154 main(argc,argv)
155 int argc;
156 char *argv[];
157 {
158 int c, errflg = 0;
159 extern int optind77;
160 extern char *optarg;
161
162 progname = argv[0];
163
164 while ((c=getopt(argc, argv, "Chl:n:o:6:")) != EOF)
165 switch (c) {
166 case 'C':
167 leaveC = YES; /* keep comments in src */
168 break;
169 case 'h':
170 /* not written yet */
171 break;
172 case 'l': /* user sets label */
173 startlab = atoi(optarg);
174 break;
175 case 'o':
176 if ((freopen(optarg, "w", stdout)) == NULL)
177 error("can't write %s\n", optarg);
178 break;
179 case '6':
180 /* not written yet */
181 break;
182 default:
183 ++errflg;
184 }
185
186 if (errflg) {
187 fprintf(stderr,
188 "usage: %s [-C][-hx][-l n][-o file][-6x] [file...]\n",progname);
189 exit(1);
190 }
191
192 /*
193 * present version can only process one file, sadly.
194 */
195 if (optind >= argc)
196 infile[0] = stdin;
197 else if ((infile[0] = fopen(argv[optind], "r")) == NULL)
198 error("cannot read %s\n", argv[optind]);
199
200 initvars();
201
202 parse(); /* call parser.. */
203
204 exit(0);
205 }
206
207 /*
208 * initialise
209 */
initvars()210 initvars()
211 {
212 int i;
213
214 outp = 0; /* output character pointer */
215 level = 0; /* file control */
216 linect[0] = 1; /* line count of first file */
217 fnamp = 0;
218 fnames[0] = EOS;
219 bp = -1; /* pushback buffer pointer */
220 fordep = 0; /* for stack */
221 swtop = 0; /* switch stack index */
222 swlast = 1; /* switch stack index */
223 for( i = 0; i <= 126; i++)
224 tabptr[i] = 0;
225 install(def, deftyp); /* default definitions */
226 install(bdef, deftyp);
227 fcname[0] = EOS; /* current function name */
228 label = startlab; /* next generated label */
229 printf("C Output from Public domain Ratfor, version 1.0\n");
230 }
231
232 /*
233 * P A R S E R
234 */
235
parse()236 parse()
237 {
238 S_CHAR lexstr[MAXTOK];
239 int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, i, token;
240
241 sp = 0;
242 lextyp[0] = EOF;
243 for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
244 if (token == LEXIF)
245 ifcode(&lab);
246 else if (token == LEXDO)
247 docode(&lab);
248 else if (token == LEXWHILE)
249 whilec(&lab);
250 else if (token == LEXFOR)
251 forcod(&lab);
252 else if (token == LEXREPEAT)
253 repcod(&lab);
254 else if (token == LEXSWITCH)
255 swcode(&lab);
256 else if (token == LEXCASE || token == LEXDEFAULT) {
257 for (i = sp; i >= 0; i--)
258 if (lextyp[i] == LEXSWITCH)
259 break;
260 if (i < 0)
261 synerr("illegal case of default.");
262 else
263 cascod(labval[i], token);
264 }
265 else if (token == LEXDIGITS)
266 labelc(lexstr);
267 else if (token == LEXELSE) {
268 if (lextyp[sp] == LEXIF)
269 elseif(labval[sp]);
270 else
271 synerr("illegal else.");
272 }
273 if (token == LEXIF || token == LEXELSE || token == LEXWHILE
274 || token == LEXFOR || token == LEXREPEAT
275 || token == LEXDO || token == LEXDIGITS
276 || token == LEXSWITCH || token == LBRACE) {
277 sp++; /* beginning of statement */
278 if (sp > MAXSTACK)
279 baderr("stack overflow in parser.");
280 lextyp[sp] = token; /* stack type and value */
281 labval[sp] = lab;
282 }
283 else if (token != LEXCASE && token != LEXDEFAULT) {
284 /*
285 * end of statement - prepare to unstack
286 */
287 if (token == RBRACE) {
288 if (lextyp[sp] == LBRACE)
289 sp--;
290 else if (lextyp[sp] == LEXSWITCH) {
291 swend(labval[sp]);
292 sp--;
293 }
294 else
295 synerr("illegal right brace.");
296 }
297 else if (token == LEXOTHER)
298 otherc(lexstr);
299 else if (token == LEXBREAK || token == LEXNEXT)
300 brknxt(sp, lextyp, labval, token);
301 else if (token == LEXRETURN)
302 retcod();
303 else if (token == LEXSTRING)
304 strdcl();
305 token = lex(lexstr); /* peek at next token */
306 pbstr(lexstr);
307 unstak(&sp, lextyp, labval, token);
308 }
309 }
310 if (sp != 0)
311 synerr("unexpected EOF.");
312 }
313
314 /*
315 * L E X I C A L A N A L Y S E R
316 */
317
318 /*
319 * alldig - return YES if str is all digits
320 *
321 */
322 int
alldig(str)323 alldig(str)
324 S_CHAR str[];
325 {
326 int i,j;
327
328 j = NO;
329 if (str[0] == EOS)
330 return(j);
331 for (i = 0; str[i] != EOS; i++)
332 if (type(str[i]) != DIGIT)
333 return(j);
334 j = YES;
335 return(j);
336 }
337
338
339 /*
340 * balpar - copy balanced paren string
341 *
342 */
balpar()343 balpar()
344 {
345 S_CHAR token[MAXTOK];
346 int t,nlpar;
347
348 if (gnbtok(token, MAXTOK) != LPAREN) {
349 synerr("missing left paren.");
350 return;
351 }
352 outstr(token);
353 nlpar = 1;
354 do {
355 t = gettok(token, MAXTOK);
356 if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
357 pbstr(token);
358 break;
359 }
360 if (t == NEWLINE) /* delete newlines */
361 token[0] = EOS;
362 else if (t == LPAREN)
363 nlpar++;
364 else if (t == RPAREN)
365 nlpar--;
366 /* else nothing special */
367 outstr(token);
368 }
369 while (nlpar > 0);
370 if (nlpar != 0)
371 synerr("missing parenthesis in condition.");
372 }
373
374 /*
375 * deftok - get token; process macro calls and invocations
376 *
377 */
378 int
deftok(token,toksiz,fd)379 deftok(token, toksiz, fd)
380 S_CHAR token[];
381 int toksiz;
382 FILE *fd;
383 {
384 S_CHAR defn[MAXDEF];
385 int t;
386
387 for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
388 if (t != ALPHA) /* non-alpha */
389 break;
390 if (look(token, defn) == NO) /* undefined */
391 break;
392 if (defn[0] == DEFTYPE) { /* get definition */
393 getdef(token, toksiz, defn, MAXDEF, fd);
394 install(token, defn);
395 }
396 else
397 pbstr(defn); /* push replacement onto input */
398 }
399 if (t == ALPHA) /* convert to single case */
400 fold(token);
401 return(t);
402 }
403
404
405 /*
406 * eatup - process rest of statement; interpret continuations
407 *
408 */
eatup()409 eatup()
410 {
411
412 S_CHAR ptoken[MAXTOK], token[MAXTOK];
413 int nlpar, t;
414
415 nlpar = 0;
416 do {
417 t = gettok(token, MAXTOK);
418 if (t == SEMICOL || t == NEWLINE)
419 break;
420 if (t == RBRACE || t == LBRACE) {
421 pbstr(token);
422 break;
423 }
424 if (t == EOF) {
425 synerr("unexpected EOF.");
426 pbstr(token);
427 break;
428 }
429 if (t == COMMA || t == PLUS
430 || t == MINUS || t == STAR || t == LPAREN
431 || t == AND || t == BAR || t == BANG
432 || t == EQUALS || t == UNDERLINE ) {
433 while (gettok(ptoken, MAXTOK) == NEWLINE)
434 ;
435 pbstr(ptoken);
436 if (t == UNDERLINE)
437 token[0] = EOS;
438 }
439 if (t == LPAREN)
440 nlpar++;
441 else if (t == RPAREN)
442 nlpar--;
443 outstr(token);
444
445 } while (nlpar >= 0);
446
447 if (nlpar != 0)
448 synerr("unbalanced parentheses.");
449 }
450
451 /*
452 * getdef (for no arguments) - get name and definition
453 *
454 */
getdef(token,toksiz,defn,defsiz,fd)455 getdef(token, toksiz, defn, defsiz, fd)
456 S_CHAR token[];
457 int toksiz;
458 S_CHAR defn[];
459 int defsiz;
460 FILE *fd;
461 {
462 int i, nlpar, t;
463 S_CHAR c, ptoken[MAXTOK];
464
465 skpblk(fd);
466 /*
467 * define(name,defn) or
468 * define name defn
469 *
470 */
471 if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
472 t = BLANK; /* define name defn */
473 pbstr(ptoken);
474 }
475 skpblk(fd);
476 if (gtok(token, toksiz, fd) != ALPHA)
477 baderr("non-alphanumeric name.");
478 skpblk(fd);
479 c = (S_CHAR) gtok(ptoken, MAXTOK, fd);
480 if (t == BLANK) { /* define name defn */
481 pbstr(ptoken);
482 i = 0;
483 do {
484 c = ngetch(&c, fd);
485 if (i > defsiz)
486 baderr("definition too long.");
487 defn[i++] = c;
488 }
489 while (c != SHARP && c != NEWLINE && c != (S_CHAR)EOF && c != PERCENT);
490 if (c == SHARP || c == PERCENT)
491 putbak(c);
492 }
493 else if (t == LPAREN) { /* define (name, defn) */
494 if (c != COMMA)
495 baderr("missing comma in define.");
496 /* else got (name, */
497 nlpar = 0;
498 for (i = 0; nlpar >= 0; i++)
499 if (i > defsiz)
500 baderr("definition too long.");
501 else if (ngetch(&defn[i], fd) == (S_CHAR)EOF)
502 baderr("missing right paren.");
503 else if (defn[i] == LPAREN)
504 nlpar++;
505 else if (defn[i] == RPAREN)
506 nlpar--;
507 /* else normal character in defn[i] */
508 }
509 else
510 baderr("getdef is confused.");
511 defn[i-1] = EOS;
512 }
513
514 /*
515 * gettok - get token. handles file inclusion and line numbers
516 *
517 */
518 int
gettok(token,toksiz)519 gettok(token, toksiz)
520 S_CHAR token[];
521 int toksiz;
522 {
523 int t, i;
524 int tok;
525 S_CHAR name[MAXNAME];
526
527 for ( ; level >= 0; level--) {
528 for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
529 tok = deftok(token, toksiz, infile[level])) {
530 if (equal(token, fncn) == YES) {
531 skpblk(infile[level]);
532 t = deftok(fcname, MAXNAME, infile[level]);
533 pbstr(fcname);
534 if (t != ALPHA)
535 synerr("missing function name.");
536 putbak(BLANK);
537 return(tok);
538 }
539 else if (equal(token, incl) == NO)
540 return(tok);
541 for (i = 0 ;; i = strlen((char *) (&name[0]))) {
542 t = deftok(&name[i], MAXNAME, infile[level]);
543 if (t == NEWLINE || t == SEMICOL) {
544 pbstr(&name[i]);
545 break;
546 }
547 }
548 name[i] = EOS;
549 /*WSB 6-25-91
550 if (name[1] == SQUOTE) {
551 outtab();
552 outstr(token);
553 outstr(name);
554 outdon();
555 eatup();
556 return(tok);
557 }
558 */
559 if (level >= NFILES)
560 synerr("includes nested too deeply.");
561 else {
562 /**/
563 name[i-1]=EOS;
564 infile[level+1] = fopen((char*)&name[2], "r");
565 /*WSB 6-25-91
566 infile[level+1] = fopen(name, "r");
567 */
568 linect[level+1] = 1;
569 if (infile[level+1] == NULL)
570 synerr("can't open include.");
571 else {
572 level++;
573 if (fnamp + i <= MAXFNAMES) {
574 scopy(name, 0, fnames, fnamp);
575 fnamp = fnamp + i; /* push file name stack */
576 }
577 }
578 }
579 }
580 if (level > 0) { /* close include and pop file name stack */
581 fclose(infile[level]);
582 for (fnamp--; fnamp > 0; fnamp--)
583 if (fnames[fnamp-1] == EOS)
584 break;
585 }
586 }
587 token[0] = EOF; /* in case called more than once */
588 token[1] = EOS;
589 tok = EOF;
590 return(tok);
591 }
592
593 /*
594 * gnbtok - get nonblank token
595 *
596 */
597 int
gnbtok(token,toksiz)598 gnbtok(token, toksiz)
599 S_CHAR token[];
600 int toksiz;
601 {
602 int tok;
603
604 skpblk(infile[level]);
605 tok = gettok(token, toksiz);
606 return(tok);
607 }
608
609 /*
610 * gtok - get token for Ratfor
611 *
612 */
613 int
gtok(lexstr,toksiz,fd)614 gtok(lexstr, toksiz, fd)
615 S_CHAR lexstr[];
616 int toksiz;
617 FILE *fd;
618 { int i, b, n, tok;
619 S_CHAR c;
620 c = ngetch(&lexstr[0], fd);
621 if (c == BLANK || c == TAB) {
622 lexstr[0] = BLANK;
623 while (c == BLANK || c == TAB) /* compress many blanks to one */
624 c = ngetch(&c, fd);
625 if (c == PERCENT)
626 {
627 outasis(fd); /* copy direct to output if % */
628 c = NEWLINE;
629 }
630 if (c == SHARP) {
631 if(leaveC == YES)
632 {
633 outcmnt(fd); /* copy comments to output */
634 c = NEWLINE;
635 }
636 else
637 while (ngetch(&c, fd) != NEWLINE) /* strip comments */
638 ;
639 }
640 /*
641 if (c == UNDERLINE)
642 if(ngetch(&c, fd) == NEWLINE)
643 while(ngetch(&c, fd) == NEWLINE)
644 ;
645 else
646 {
647 putbak(c);
648 c = UNDERLINE;
649 }
650 */
651 if (c != NEWLINE)
652 putbak(c);
653 else
654 lexstr[0] = NEWLINE;
655 lexstr[1] = EOS;
656 return((int)lexstr[0]);
657 }
658 i = 0;
659 tok = type(c);
660 if (tok == LETTER) { /* alpha */
661 for (i = 0; i < toksiz - 3; i++) {
662 tok = type(ngetch(&lexstr[i+1], fd));
663 /* Test for DOLLAR added by BM, 7-15-80 */
664 if (tok != LETTER && tok != DIGIT
665 && tok != UNDERLINE && tok!=DOLLAR
666 && tok != PERIOD)
667 break;
668 }
669 putbak(lexstr[i+1]);
670 tok = ALPHA;
671 }
672 else if (tok == DIGIT) { /* digits */
673 b = c - DIG0; /* in case alternate base number */
674 for (i = 0; i < toksiz - 3; i++) {
675 if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
676 break;
677 b = 10*b + lexstr[i+1] - DIG0;
678 }
679 if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {
680 /* n%ddd... */
681 for (n = 0;; n = b*n + c - DIG0) {
682 c = ngetch(&lexstr[0], fd);
683 if (c >= LETA && c <= LETZ)
684 c = c - LETA + DIG9 + 1;
685 else if (c >= BIGA && c <= BIGZ)
686 c = c - BIGA + DIG9 + 1;
687 if (c < DIG0 || c >= DIG0 + b)
688 break;
689 }
690 putbak(lexstr[0]);
691 i = itoc(n, lexstr, toksiz);
692 }
693 else
694 putbak(lexstr[i+1]);
695 tok = DIGIT;
696 }
697 #ifdef SQUAREB
698 else if (c == LBRACK) { /* allow [ for { */
699 lexstr[0] = LBRACE;
700 tok = LBRACE;
701 }
702 else if (c == RBRACK) { /* allow ] for } */
703 lexstr[0] = RBRACE;
704 tok = RBRACE;
705 }
706 #endif
707 else if (c == SQUOTE || c == DQUOTE) {
708 for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
709 if (lexstr[i] == UNDERLINE)
710 if (ngetch(&c, fd) == NEWLINE) {
711 while (c == NEWLINE || c == BLANK || c == TAB)
712 c = ngetch(&c, fd);
713 lexstr[i] = c;
714 }
715 else
716 putbak(c);
717 if (lexstr[i] == NEWLINE || i >= toksiz-1) {
718 synerr("missing quote.");
719 lexstr[i] = lexstr[0];
720 putbak(NEWLINE);
721 break;
722 }
723 }
724 }
725 else if (c == PERCENT) {
726 outasis(fd); /* direct copy of protected */
727 tok = NEWLINE;
728 }
729 else if (c == SHARP) {
730 if(leaveC == YES)
731 outcmnt(fd); /* copy comments to output */
732 else
733 while (ngetch(&lexstr[0], fd) != NEWLINE) /* strip comments */
734 ;
735 tok = NEWLINE;
736 }
737 else if (c == GREATER || c == LESS || c == NOT
738 || c == BANG || c == CARET || c == EQUALS
739 || c == AND || c == OR)
740 i = relate(lexstr, fd);
741 if (i >= toksiz-1)
742 synerr("token too long.");
743 lexstr[i+1] = EOS;
744 if (lexstr[0] == NEWLINE)
745 linect[level] = linect[level] + 1;
746
747 #if defined(CRAY) || defined(GNU)
748 /* cray cannot compare char and ints, since EOF is an int we check with feof */
749 if (feof(fd)) tok = EOF;
750 #endif
751
752 return(tok);
753 }
754
755 /*
756 * lex - return lexical type of token
757 *
758 */
759 int
lex(lexstr)760 lex(lexstr)
761 S_CHAR lexstr[];
762 {
763
764 int tok;
765
766 for (tok = gnbtok(lexstr, MAXTOK);
767 tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
768 ;
769 if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
770 return(tok);
771 if (tok == DIGIT)
772 tok = LEXDIGITS;
773 else if (equal(lexstr, sif) == YES)
774 tok = vif[0];
775 else if (equal(lexstr, selse) == YES)
776 tok = velse[0];
777 else if (equal(lexstr, swhile) == YES)
778 tok = vwhile[0];
779 else if (equal(lexstr, sdo) == YES)
780 tok = vdo[0];
781 else if (equal(lexstr, ssbreak) == YES)
782 tok = vbreak[0];
783 else if (equal(lexstr, snext) == YES)
784 tok = vnext[0];
785 else if (equal(lexstr, sfor) == YES)
786 tok = vfor[0];
787 else if (equal(lexstr, srept) == YES)
788 tok = vrept[0];
789 else if (equal(lexstr, suntil) == YES)
790 tok = vuntil[0];
791 else if (equal(lexstr, sswitch) == YES)
792 tok = vswitch[0];
793 else if (equal(lexstr, scase) == YES)
794 tok = vcase[0];
795 else if (equal(lexstr, sdefault) == YES)
796 tok = vdefault[0];
797 else if (equal(lexstr, sret) == YES)
798 tok = vret[0];
799 else if (equal(lexstr, sstr) == YES)
800 tok = vstr[0];
801 else
802 tok = LEXOTHER;
803 return(tok);
804 }
805
806 /*
807 * ngetch - get a (possibly pushed back) character
808 *
809 */
810 S_CHAR
ngetch(c,fd)811 ngetch(c, fd)
812 S_CHAR *c;
813 FILE *fd;
814 {
815
816 if (bp >= 0) {
817 *c = buf[bp];
818 bp--;
819 }
820 else
821 *c = (S_CHAR) getc(fd);
822
823 /*
824 * check for a continuation '_\n'
825 * also removes UNDERLINES from
826 * variable names
827 */
828 while ( *c == UNDERLINE)
829 {
830 if (bp >= 0) {
831 *c = buf[bp];
832 bp--;
833 }
834 else
835 *c = (S_CHAR) getc(fd);
836
837 if (*c != NEWLINE)
838 {
839 putbak(*c);
840 *c=UNDERLINE;
841 break;
842 }
843 else
844 {
845 while(*c == NEWLINE)
846 {
847 if (bp >= 0) {
848 *c = buf[bp];
849 bp--;
850 }
851 else
852 *c = (S_CHAR) getc(fd);
853 }
854 }
855 }
856
857 return(*c);
858 }
859 /*
860 * pbstr - push string back onto input
861 *
862 */
pbstr(in)863 pbstr(in)
864 S_CHAR in[];
865 {
866 int i;
867
868 for (i = strlen((char *) (&in[0])) - 1; i >= 0; i--)
869 putbak(in[i]);
870 }
871
872 /*
873 * putbak - push char back onto input
874 *
875 */
putbak(c)876 putbak(c)
877 S_CHAR c;
878 {
879
880 bp++;
881 if (bp > BUFSIZE)
882 baderr("too many characters pushed back.");
883 buf[bp] = c;
884 }
885
886
887 /*
888 * relate - convert relational shorthands into long form
889 *
890 */
891 int
relate(token,fd)892 relate(token, fd)
893 S_CHAR token[];
894 FILE *fd;
895 {
896
897 if (ngetch(&token[1], fd) != EQUALS) {
898 putbak(token[1]);
899 token[2] = LETT;
900 }
901 else
902 token[2] = LETE;
903 token[3] = PERIOD;
904 token[4] = EOS;
905 token[5] = EOS; /* for .not. and .and. */
906 if (token[0] == GREATER)
907 token[1] = LETG;
908 else if (token[0] == LESS)
909 token[1] = LETL;
910 else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
911 if (token[1] != EQUALS) {
912 token[2] = LETO;
913 token[3] = LETT;
914 token[4] = PERIOD;
915 }
916 token[1] = LETN;
917 }
918 else if (token[0] == EQUALS) {
919 if (token[1] != EQUALS) {
920 token[2] = EOS;
921 return(0);
922 }
923 token[1] = LETE;
924 token[2] = LETQ;
925 }
926 else if (token[0] == AND) { /* look for && or & */
927 if (ngetch(&token[1], fd) != AND)
928 putbak(token[1]);
929 token[1] = LETA;
930 token[2] = LETN;
931 token[3] = LETD;
932 token[4] = PERIOD;
933 }
934 else if (token[0] == OR) {
935 if (ngetch(&token[1], fd) != OR) /* look for || or | */
936 putbak(token[1]);
937 token[1] = LETO;
938 token[2] = LETR;
939 }
940 else /* can't happen */
941 token[1] = EOS;
942 token[0] = PERIOD;
943 return(strlen((char *) (&token[0]))-1);
944 }
945
946 /*
947 * skpblk - skip blanks and tabs in file fd
948 *
949 */
skpblk(fd)950 skpblk(fd)
951 FILE *fd;
952 {
953 S_CHAR c;
954
955 for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
956 ;
957 putbak(c);
958 }
959
960
961 /*
962 * type - return LETTER, DIGIT or char; works with ascii alphabet
963 *
964 */
965 int
type(c)966 type(c)
967 S_CHAR c;
968 {
969 int t;
970
971 if (c >= DIG0 && c <= DIG9)
972 t = DIGIT;
973 else if (c >= LETA && c <= LETZ)
974 t = LETTER;
975 else if (c >= BIGA && c <= BIGZ)
976 t = LETTER;
977 else
978 t = c;
979 return(t);
980 }
981
982 /*
983 * C O D E G E N E R A T I O N
984 */
985
986 /*
987 * brknxt - generate code for break n and next n; n = 1 is default
988 */
brknxt(sp,lextyp,labval,token)989 brknxt(sp, lextyp, labval, token)
990 int sp;
991 int lextyp[];
992 int labval[];
993 int token;
994 {
995 int i, n;
996 S_CHAR t, ptoken[MAXTOK];
997
998 n = 0;
999 t = gnbtok(ptoken, MAXTOK);
1000 if (alldig(ptoken) == YES) { /* have break n or next n */
1001 i = 0;
1002 n = ctoi(ptoken, &i) - 1;
1003 }
1004 else if (t != SEMICOL) /* default case */
1005 pbstr(ptoken);
1006 for (i = sp; i >= 0; i--)
1007 if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
1008 || lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
1009 if (n > 0) {
1010 n--;
1011 continue; /* seek proper level */
1012 }
1013 else if (token == LEXBREAK)
1014 outgo(labval[i]+1);
1015 else
1016 outgo(labval[i]);
1017 /* original value
1018 xfer = YES;
1019 */
1020 xfer = NO;
1021 return;
1022 }
1023 if (token == LEXBREAK)
1024 synerr("illegal break.");
1025 else
1026 synerr("illegal next.");
1027 return;
1028 }
1029
1030 /*
1031 * docode - generate code for beginning of do
1032 *
1033 */
docode(lab)1034 docode(lab)
1035 int *lab;
1036 {
1037 xfer = NO;
1038 outtab();
1039 outstr(sdo);
1040 *lab = labgen(2);
1041 outnum(*lab);
1042 eatup();
1043 outdon();
1044 }
1045
1046 /*
1047 * dostat - generate code for end of do statement
1048 *
1049 */
dostat(lab)1050 dostat(lab)
1051 int lab;
1052 {
1053 outcon(lab);
1054 outcon(lab+1);
1055 }
1056
1057 /*
1058 * elseif - generate code for end of if before else
1059 *
1060 */
elseif(lab)1061 elseif(lab)
1062 int lab;
1063 {
1064
1065 #ifdef F77
1066 outtab();
1067 outstr(selse);
1068 outdon();
1069 #else
1070 outgo(lab+1);
1071 outcon(lab);
1072 #endif /* F77 */
1073 }
1074
1075 /*
1076 * forcod - beginning of for statement
1077 *
1078 */
forcod(lab)1079 forcod(lab)
1080 int *lab;
1081 {
1082 S_CHAR t, token[MAXTOK];
1083 int i, j, nlpar,tlab;
1084
1085 tlab = *lab;
1086 tlab = labgen(3);
1087 outcon(0);
1088 if (gnbtok(token, MAXTOK) != LPAREN) {
1089 synerr("missing left paren.");
1090 return;
1091 }
1092 if (gnbtok(token, MAXTOK) != SEMICOL) { /* real init clause */
1093 pbstr(token);
1094 outtab();
1095 eatup();
1096 outdon();
1097 }
1098 if (gnbtok(token, MAXTOK) == SEMICOL) /* empty condition */
1099 outcon(tlab);
1100 else { /* non-empty condition */
1101 pbstr(token);
1102 outnum(tlab);
1103 outtab();
1104 outstr(ifnot);
1105 outch(LPAREN);
1106 nlpar = 0;
1107 while (nlpar >= 0) {
1108 t = gettok(token, MAXTOK);
1109 if (t == SEMICOL)
1110 break;
1111 if (t == LPAREN)
1112 nlpar++;
1113 else if (t == RPAREN)
1114 nlpar--;
1115 if (t == (S_CHAR)EOF) {
1116 pbstr(token);
1117 return;
1118 }
1119 if (t != NEWLINE && t != UNDERLINE)
1120 outstr(token);
1121 }
1122 outch(RPAREN);
1123 outch(RPAREN);
1124 outgo((tlab)+2);
1125 if (nlpar < 0)
1126 synerr("invalid for clause.");
1127 }
1128 fordep++; /* stack reinit clause */
1129 j = 0;
1130 for (i = 1; i < fordep; i++) /* find end *** should i = 1 ??? *** */
1131 j = j + strlen((char *) (&forstk[j])) + 1;
1132 forstk[j] = EOS; /* null, in case no reinit */
1133 nlpar = 0;
1134 t = gnbtok(token, MAXTOK);
1135 pbstr(token);
1136 while (nlpar >= 0) {
1137 t = gettok(token, MAXTOK);
1138 if (t == LPAREN)
1139 nlpar++;
1140 else if (t == RPAREN)
1141 nlpar--;
1142 if (t == (S_CHAR)EOF) {
1143 pbstr(token);
1144 break;
1145 }
1146 if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
1147 if ((j + ((int) strlen((char *) (&token[0])))) >=
1148 ((int) MAXFORSTK))
1149 baderr("for clause too long.");
1150 scopy(token, 0, forstk, j);
1151 j = j + strlen((char *) (&token[0]));
1152 }
1153 }
1154 tlab++; /* label for next's */
1155 *lab = tlab;
1156 }
1157
1158 /*
1159 * fors - process end of for statement
1160 *
1161 */
fors(lab)1162 fors(lab)
1163 int lab;
1164 {
1165 int i, j;
1166
1167 xfer = NO;
1168 outnum(lab);
1169 j = 0;
1170 for (i = 1; i < fordep; i++)
1171 j = j + strlen((char *) (&forstk[j])) + 1;
1172 if (((int) strlen((char *) (&forstk[j]))) > ((int) 0)) {
1173 outtab();
1174 outstr(&forstk[j]);
1175 outdon();
1176 }
1177 outgo(lab-1);
1178 outcon(lab+1);
1179 fordep--;
1180 }
1181
1182 /*
1183 * ifcode - generate initial code for if
1184 *
1185 */
ifcode(lab)1186 ifcode(lab)
1187 int *lab;
1188 {
1189
1190 xfer = NO;
1191 *lab = labgen(2);
1192 #ifdef F77
1193 ifthen();
1194 #else
1195 ifgo(*lab);
1196 #endif /* F77 */
1197 }
1198
1199 #ifdef F77
1200 /*
1201 * ifend - generate code for end of if
1202 *
1203 */
ifend()1204 ifend()
1205 {
1206 outtab();
1207 outstr(sendif);
1208 outdon();
1209 }
1210 #endif /* F77 */
1211
1212 /*
1213 * ifgo - generate "if(.not.(...))goto lab"
1214 *
1215 */
ifgo(lab)1216 ifgo(lab)
1217 int lab;
1218 {
1219
1220 outtab(); /* get to column 7 */
1221 outstr(ifnot); /* " if(.not. " */
1222 balpar(); /* collect and output condition */
1223 outch(RPAREN); /* " ) " */
1224 outgo(lab); /* " goto lab " */
1225 }
1226
1227 #ifdef F77
1228 /*
1229 * ifthen - generate "if((...))then"
1230 *
1231 */
ifthen()1232 ifthen()
1233 {
1234 outtab();
1235 outstr(sif);
1236 balpar();
1237 outstr(sthen);
1238 outdon();
1239 }
1240 #endif /* F77 */
1241
1242 /*
1243 * labelc - output statement number
1244 *
1245 */
labelc(lexstr)1246 labelc(lexstr)
1247 S_CHAR lexstr[];
1248 {
1249
1250 xfer = NO; /* can't suppress goto's now */
1251 if (strlen((char *) (&lexstr[0])) == 5) /* warn about 23xxx labels */
1252 if (atoi((char*)lexstr) >= startlab)
1253 synerr("warning: possible label conflict.");
1254 outstr(lexstr);
1255 outtab();
1256 }
1257
1258 /*
1259 * labgen - generate n consecutive labels, return first one
1260 *
1261 */
1262 int
labgen(n)1263 labgen(n)
1264 int n;
1265 {
1266 int i;
1267
1268 i = label;
1269 label = label + n;
1270 return(i);
1271 }
1272
1273 /*
1274 * otherc - output ordinary Fortran statement
1275 *
1276 */
otherc(lexstr)1277 otherc(lexstr)
1278 S_CHAR lexstr[];
1279 {
1280 xfer = NO;
1281 outtab();
1282 outstr(lexstr);
1283 eatup();
1284 outdon();
1285 }
1286
1287 /*
1288 * outch - put one char into output buffer
1289 *
1290 */
outch(c)1291 outch(c)
1292 S_CHAR c;
1293 {
1294 int i;
1295
1296 if (outp >= 72) { /* continuation card */
1297 outdon();
1298 for (i = 0; i < 6; i++)
1299 outbuf[i] = BLANK;
1300 outbuf[5]='*';
1301 outp = 6;
1302 }
1303 outbuf[outp] = c;
1304 outp++;
1305 }
1306
1307 /*
1308 * outcon - output "n continue"
1309 *
1310 */
outcon(n)1311 outcon(n)
1312 int n;
1313 {
1314 xfer = NO;
1315 if (n <= 0 && outp == 0)
1316 return; /* don't need unlabeled continues */
1317 if (n > 0)
1318 outnum(n);
1319 outtab();
1320 outstr(contin);
1321 outdon();
1322 }
1323
1324 /*
1325 * outdon - finish off an output line
1326 *
1327 */
outdon()1328 outdon()
1329 {
1330
1331 outbuf[outp] = NEWLINE;
1332 outbuf[outp+1] = EOS;
1333 printf("%s", outbuf);
1334 outp = 0;
1335 }
1336
1337 /*
1338 * outcmnt - copy comment to output
1339 *
1340 */
outcmnt(fd)1341 outcmnt(fd)
1342 FILE * fd;
1343 {
1344 S_CHAR c;
1345 S_CHAR comout[81];
1346 int i, comoutp=0;
1347
1348 comoutp=1;
1349 comout[0]='C';
1350 while((c=ngetch(&c,fd)) != NEWLINE) {
1351 if (comoutp > 79) {
1352 comout[80]=NEWLINE;
1353 comout[81]=EOS;
1354 printf("%s",comout);
1355 comoutp=0;
1356 comout[comoutp]='C';
1357 comoutp++;
1358 }
1359 comout[comoutp]=c;
1360 comoutp++;
1361 }
1362 comout[comoutp]=NEWLINE;
1363 comout[comoutp+1]=EOS;
1364 printf("%s",comout);
1365 }
1366
1367 /*
1368 * outasis - copy directly out
1369 *
1370 */
outasis(fd)1371 outasis(fd)
1372 FILE * fd;
1373 {
1374 S_CHAR c;
1375 while((c=ngetch(&c,fd)) != NEWLINE)
1376 outch(c);
1377 outdon();
1378 }
1379
1380 /*
1381 * outgo - output "goto n"
1382 *
1383 */
outgo(n)1384 outgo(n)
1385 int n;
1386 {
1387 if (xfer == YES)
1388 return;
1389 outtab();
1390 outstr(rgoto);
1391 outnum(n);
1392 outdon();
1393 }
1394
1395 /*
1396 * outnum - output decimal number
1397 *
1398 */
outnum(n)1399 outnum(n)
1400 int n;
1401 {
1402
1403 S_CHAR chars[MAXCHARS];
1404 int i, m;
1405
1406 m = abs(n);
1407 i = -1;
1408 do {
1409 i++;
1410 chars[i] = (m % 10) + DIG0;
1411 m = m / 10;
1412 }
1413 while (m > 0 && i < MAXCHARS);
1414 if (n < 0)
1415 outch(MINUS);
1416 for ( ; i >= 0; i--)
1417 outch(chars[i]);
1418 }
1419
1420
1421
1422 /*
1423 * outstr - output string
1424 *
1425 */
outstr(str)1426 outstr(str)
1427 S_CHAR str[];
1428 {
1429 int i;
1430
1431 for (i=0; str[i] != EOS; i++)
1432 outch(str[i]);
1433 }
1434
1435 /*
1436 * outtab - get past column 6
1437 *
1438 */
outtab()1439 outtab()
1440 {
1441 while (outp < 6)
1442 outch(BLANK);
1443 }
1444
1445
1446 /*
1447 * repcod - generate code for beginning of repeat
1448 *
1449 */
repcod(lab)1450 repcod(lab)
1451 int *lab;
1452 {
1453
1454 int tlab;
1455
1456 tlab = *lab;
1457 outcon(0); /* in case there was a label */
1458 tlab = labgen(3);
1459 outcon(tlab);
1460 *lab = ++tlab; /* label to go on next's */
1461 }
1462
1463 /*
1464 * retcod - generate code for return
1465 *
1466 */
retcod()1467 retcod()
1468 {
1469 S_CHAR token[MAXTOK], t;
1470
1471 t = gnbtok(token, MAXTOK);
1472 if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
1473 pbstr(token);
1474 outtab();
1475 outstr(fcname);
1476 outch(EQUALS);
1477 eatup();
1478 outdon();
1479 }
1480 else if (t == RBRACE)
1481 pbstr(token);
1482 outtab();
1483 outstr(sret);
1484 outdon();
1485 xfer = YES;
1486 }
1487
1488
1489 /* strdcl - generate code for string declaration */
strdcl()1490 strdcl()
1491 {
1492 S_CHAR t, name[MAXNAME], init[MAXTOK];
1493 int i, len;
1494
1495 t = gnbtok(name, MAXNAME);
1496 if (t != ALPHA)
1497 synerr("missing string name.");
1498 if (gnbtok(init, MAXTOK) != LPAREN) { /* make size same as initial value */
1499 len = strlen((char *) (&init[0])) + 1;
1500 if (init[1] == SQUOTE || init[1] == DQUOTE)
1501 len = len - 2;
1502 }
1503 else { /* form is string name(size) init */
1504 t = gnbtok(init, MAXTOK);
1505 i = 0;
1506 len = ctoi(init, &i);
1507 if (init[i] != EOS)
1508 synerr("invalid string size.");
1509 if (gnbtok(init, MAXTOK) != RPAREN)
1510 synerr("missing right paren.");
1511 else
1512 t = gnbtok(init, MAXTOK);
1513 }
1514 outtab();
1515 /*
1516 * outstr(int);
1517 */
1518 outstr(name);
1519 outch(LPAREN);
1520 outnum(len);
1521 outch(RPAREN);
1522 outdon();
1523 outtab();
1524 outstr(dat);
1525 len = strlen((char *)(&init[0])) + 1;
1526 if (init[0] == SQUOTE || init[0] == DQUOTE) {
1527 init[len-1] = EOS;
1528 scopy(init, 1, init, 0);
1529 len = len - 2;
1530 }
1531 for (i = 1; i <= len; i++) { /* put out variable names */
1532 outstr(name);
1533 outch(LPAREN);
1534 outnum(i);
1535 outch(RPAREN);
1536 if (i < len)
1537 outch(COMMA);
1538 else
1539 outch(SLASH);
1540 ;
1541 }
1542 for (i = 0; init[i] != EOS; i++) { /* put out init */
1543 outnum(init[i]);
1544 outch(COMMA);
1545 }
1546 pbstr(eoss); /* push back EOS for subsequent substitution */
1547 }
1548
1549
1550 /*
1551 * unstak - unstack at end of statement
1552 *
1553 */
unstak(sp,lextyp,labval,token)1554 unstak(sp, lextyp, labval, token)
1555 int *sp;
1556 int lextyp[];
1557 int labval[];
1558 S_CHAR token;
1559 {
1560 int tp;
1561
1562 tp = *sp;
1563 for ( ; tp > 0; tp--) {
1564 if (lextyp[tp] == LBRACE)
1565 break;
1566 if (lextyp[tp] == LEXSWITCH)
1567 break;
1568 if (lextyp[tp] == LEXIF && token == LEXELSE)
1569 break;
1570 if (lextyp[tp] == LEXIF)
1571 #ifdef F77
1572 ifend();
1573 #else
1574 outcon(labval[tp]);
1575 #endif /* F77 */
1576 else if (lextyp[tp] == LEXELSE) {
1577 if (*sp > 1)
1578 tp--;
1579 #ifdef F77
1580 ifend();
1581 #else
1582 outcon(labval[tp]+1);
1583 #endif /* F77 */
1584 }
1585 else if (lextyp[tp] == LEXDO)
1586 dostat(labval[tp]);
1587 else if (lextyp[tp] == LEXWHILE)
1588 whiles(labval[tp]);
1589 else if (lextyp[tp] == LEXFOR)
1590 fors(labval[tp]);
1591 else if (lextyp[tp] == LEXREPEAT)
1592 untils(labval[tp], token);
1593 }
1594 *sp = tp;
1595 }
1596
1597 /*
1598 * untils - generate code for until or end of repeat
1599 *
1600 */
untils(lab,token)1601 untils(lab, token)
1602 int lab;
1603 int token;
1604 {
1605 S_CHAR ptoken[MAXTOK];
1606
1607 xfer = NO;
1608 outnum(lab);
1609 if (token == LEXUNTIL) {
1610 lex(ptoken);
1611 ifgo(lab-1);
1612 }
1613 else
1614 outgo(lab-1);
1615 outcon(lab+1);
1616 }
1617
1618 /*
1619 * whilec - generate code for beginning of while
1620 *
1621 */
whilec(lab)1622 whilec(lab)
1623 int *lab;
1624 {
1625 int tlab;
1626
1627 tlab = *lab;
1628 outcon(0); /* unlabeled continue, in case there was a label */
1629 tlab = labgen(2);
1630 outnum(tlab);
1631 #ifdef F77
1632 ifthen();
1633 #else
1634 ifgo(tlab+1);
1635 #endif /* F77 */
1636 *lab = tlab;
1637 }
1638
1639 /*
1640 * whiles - generate code for end of while
1641 *
1642 */
whiles(lab)1643 whiles(lab)
1644 int lab;
1645 {
1646
1647 outgo(lab);
1648 #ifdef F77
1649 ifend();
1650 #endif /* F77 */
1651 outcon(lab+1);
1652 }
1653
1654 /*
1655 * E R R O R M E S S A G E S
1656 */
1657
1658 /*
1659 * baderr - print error message, then die
1660 */
baderr(msg)1661 baderr(msg)
1662 S_CHAR msg[];
1663 {
1664 synerr(msg);
1665 exit(1);
1666 }
1667
1668 /*
1669 * error - print error message with one parameter, then die
1670 */
error(msg,s)1671 error(msg, s)
1672 char *msg;
1673 S_CHAR *s;
1674 {
1675 fprintf(stderr, msg,s);
1676 exit(1);
1677 }
1678
1679 /*
1680 * synerr - report Ratfor syntax error
1681 */
synerr(msg)1682 synerr(msg)
1683 S_CHAR *msg;
1684 {
1685 S_CHAR lc[MAXCHARS];
1686 int i;
1687
1688 fprintf(stderr,errmsg);
1689 if (level >= 0)
1690 i = level;
1691 else
1692 i = 0; /* for EOF errors */
1693 itoc(linect[i], lc, MAXCHARS);
1694 fprintf(stderr,(char*)lc);
1695 for (i = fnamp - 1; i > 1; i = i - 1)
1696 if (fnames[i-1] == EOS) { /* print file name */
1697 fprintf(stderr,in);
1698 fprintf(stderr,(char*)&fnames[i]);
1699 break;
1700 }
1701 fprintf(stderr,": \n %s\n",msg);
1702 }
1703
1704
1705 /*
1706 * U T I L I T Y R O U T I N E S
1707 */
1708
1709 /*
1710 * ctoi - convert string at in[i] to int, increment i
1711 */
1712 int
ctoi(in,i)1713 ctoi(in, i)
1714 S_CHAR in[];
1715 int *i;
1716 {
1717 int k, j;
1718
1719 j = *i;
1720 while (in[j] == BLANK || in[j] == TAB)
1721 j++;
1722 for (k = 0; in[j] != EOS; j++) {
1723 if (in[j] < DIG0 || in[j] > DIG9)
1724 break;
1725 k = 10 * k + in[j] - DIG0;
1726 }
1727 *i = j;
1728 return(k);
1729 }
1730
1731 /*
1732 * fold - convert alphabetic token to single case
1733 *
1734 */
fold(token)1735 fold(token)
1736 S_CHAR token[];
1737 {
1738
1739 int i;
1740
1741 /* WARNING - this routine depends heavily on the */
1742 /* fact that letters have been mapped into internal */
1743 /* right-adjusted ascii. god help you if you */
1744 /* have subverted this mechanism. */
1745
1746 for (i = 0; token[i] != EOS; i++)
1747 if (token[i] >= BIGA && token[i] <= BIGZ)
1748 token[i] = token[i] - BIGA + LETA;
1749 }
1750
1751 /*
1752 * equal - compare str1 to str2; return YES if equal, NO if not
1753 *
1754 */
1755 int
equal(str1,str2)1756 equal(str1, str2)
1757 S_CHAR str1[];
1758 S_CHAR str2[];
1759 {
1760 int i;
1761
1762 for (i = 0; str1[i] == str2[i]; i++)
1763 if (str1[i] == EOS)
1764 return(YES);
1765 return(NO);
1766 }
1767
1768 /*
1769 * scopy - copy string at from[i] to to[j]
1770 *
1771 */
scopy(from,i,to,j)1772 scopy(from, i, to, j)
1773 S_CHAR from[];
1774 int i;
1775 S_CHAR to[];
1776 int j;
1777 {
1778 int k1, k2;
1779
1780 k2 = j;
1781 for (k1 = i; from[k1] != EOS; k1++) {
1782 to[k2] = from[k1];
1783 k2++;
1784 }
1785 to[k2] = EOS;
1786 }
1787
1788 #include "lookup.h"
1789 /*
1790 * look - look-up a definition
1791 *
1792 */
1793 int
look(name,defn)1794 look(name,defn)
1795 S_CHAR name[];
1796 S_CHAR defn[];
1797 {
1798 extern struct hashlist *lookup();
1799 struct hashlist *p;
1800
1801 if ((p = lookup(name)) == NULL)
1802 return(NO);
1803 (void) strcpy((char *) (&defn[0]),(char *) (&((p->def)[0])));
1804 return(YES);
1805 }
1806
1807 /*
1808 * itoc - special version of itoa
1809 */
1810 int
itoc(n,str,size)1811 itoc(n,str,size)
1812 int n;
1813 S_CHAR str[];
1814 int size;
1815 {
1816 int i,j,k,sign;
1817 S_CHAR c;
1818
1819 if ((sign = n) < 0)
1820 n = -n;
1821 i = 0;
1822 do {
1823 str[i++] = n % 10 + '0';
1824 }
1825 while ((n /= 10) > 0 && i < size-2);
1826 if (sign < 0 && i < size-1)
1827 str[i++] = '-';
1828 str[i] = EOS;
1829 /*
1830 * reverse the string and plug it back in
1831 */
1832 for (j = 0, k = strlen((char *) (&str[0])) - 1; j < k; j++, k--) {
1833 c = str[j];
1834 str[j] = str[k];
1835 str[k] = c;
1836 }
1837 return(i-1);
1838 }
1839
1840 /*
1841 * cascod - generate code for case or default label
1842 *
1843 */
cascod(lab,token)1844 cascod (lab, token)
1845 int lab;
1846 int token;
1847 {
1848 int t, l, lb, ub, i, j, junk;
1849 S_CHAR scrtok[MAXTOK];
1850
1851 if (swtop <= 0) {
1852 synerr ("illegal case or default.");
1853 return;
1854 }
1855 outgo(lab + 1); /* # terminate previous case */
1856 xfer = YES;
1857 l = labgen(1);
1858 if (token == LEXCASE) { /* # case n[,n]... : ... */
1859 while (caslab (&lb, &t) != EOF) {
1860 ub = lb;
1861 if (t == MINUS)
1862 junk = caslab (&ub, &t);
1863 if (lb > ub) {
1864 synerr ("illegal range in case label.");
1865 ub = lb;
1866 }
1867 if (swlast + 3 > MAXSWITCH)
1868 baderr ("switch table overflow.");
1869 for (i = swtop + 3; i < swlast; i = i + 3)
1870 if (lb <= swstak[i])
1871 break;
1872 else if (lb <= swstak[i+1])
1873 synerr ("duplicate case label.");
1874 if (i < swlast && ub >= swstak[i])
1875 synerr ("duplicate case label.");
1876 for (j = swlast; j > i; j--) /* # insert new entry */
1877 swstak[j+2] = swstak[j-1];
1878 swstak[i] = lb;
1879 swstak[i + 1] = ub;
1880 swstak[i + 2] = l;
1881 swstak[swtop + 1] = swstak[swtop + 1] + 1;
1882 swlast = swlast + 3;
1883 if (t == COLON)
1884 break;
1885 else if (t != COMMA)
1886 synerr ("illegal case syntax.");
1887 }
1888 }
1889 else { /* # default : ... */
1890 t = gnbtok (scrtok, MAXTOK);
1891 if (swstak[swtop + 2] != 0)
1892 baderr ("multiple defaults in switch statement.");
1893 else
1894 swstak[swtop + 2] = l;
1895 }
1896
1897 if (t == EOF)
1898 synerr ("unexpected EOF.");
1899 else if (t != COLON)
1900 baderr ("missing colon in case or default label.");
1901
1902 xfer = NO;
1903 outcon (l);
1904 }
1905
1906 /*
1907 * caslab - get one case label
1908 *
1909 */
1910 int
caslab(n,t)1911 caslab (n, t)
1912 int *n;
1913 int *t;
1914 {
1915 S_CHAR tok[MAXTOK];
1916 int i, s;
1917
1918 *t = gnbtok (tok, MAXTOK);
1919 while (*t == NEWLINE)
1920 *t = gnbtok (tok, MAXTOK);
1921 if (*t == EOF)
1922 return (*t);
1923 if (*t == MINUS)
1924 s = -1;
1925 else
1926 s = 1;
1927 if (*t == MINUS || *t == PLUS)
1928 *t = gnbtok (tok, MAXTOK);
1929 if (*t != DIGIT) {
1930 synerr ("invalid case label.");
1931 *n = 0;
1932 }
1933 else {
1934 i = 0;
1935 *n = s * ctoi (tok, &i);
1936 }
1937 *t = gnbtok (tok, MAXTOK);
1938 while (*t == NEWLINE)
1939 *t = gnbtok (tok, MAXTOK);
1940 }
1941
1942 /*
1943 * swcode - generate code for switch stmt.
1944 *
1945 */
swcode(lab)1946 swcode (lab)
1947 int *lab;
1948 {
1949 S_CHAR scrtok[MAXTOK];
1950
1951 *lab = labgen (2);
1952 if (swlast + 3 > MAXSWITCH)
1953 baderr ("switch table overflow.");
1954 swstak[swlast] = swtop;
1955 swstak[swlast + 1] = 0;
1956 swstak[swlast + 2] = 0;
1957 swtop = swlast;
1958 swlast = swlast + 3;
1959 xfer = NO;
1960 outtab(); /* # Innn=(e) */
1961 swvar(*lab);
1962 outch(EQUALS);
1963 balpar();
1964 outdon();
1965 outgo(*lab); /* # goto L */
1966 xfer = YES;
1967 while (gnbtok (scrtok, MAXTOK) == NEWLINE)
1968 ;
1969 if (scrtok[0] != LBRACE) {
1970 synerr ("missing left brace in switch statement.");
1971 pbstr (scrtok);
1972 }
1973 }
1974
1975 /*
1976 * swend - finish off switch statement; generate dispatch code
1977 *
1978 */
swend(lab)1979 swend(lab)
1980 int lab;
1981 {
1982 int lb, ub, n, i, j;
1983
1984 static char *sif = "if (";
1985 static char *slt = ".lt.1.or.";
1986 static char *sgt = ".gt.";
1987 static char *sgoto = "goto (";
1988 static char *seq = ".eq.";
1989 static char *sge = ".ge.";
1990 static char *sle = ".le.";
1991 static char *sand = ".and.";
1992
1993 lb = swstak[swtop + 3];
1994 ub = swstak[swlast - 2];
1995 n = swstak[swtop + 1];
1996 outgo(lab + 1); /* # terminate last case */
1997 if (swstak[swtop + 2] == 0)
1998 swstak[swtop + 2] = lab + 1; /* # default default label */
1999 xfer = NO;
2000 outcon (lab); /* L continue */
2001 /* output branch table */
2002 /*
2003 if (n >= CUTOFF && ub - lb < DENSITY * n) {
2004 if (lb != 0) { * L Innn=Innn-lb *
2005 outtab();
2006 swvar (lab);
2007 outch (EQUALS);
2008 swvar (lab);
2009 if (lb < 0)
2010 outch (PLUS);
2011 outnum (-lb + 1);
2012 outdon();
2013 }
2014 outtab(); * if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default *
2015 outstr (sif);
2016 swvar (lab);
2017 outstr (slt);
2018 swvar (lab);
2019 outstr (sgt);
2020 outnum (ub - lb + 1);
2021 outch (RPAREN);
2022 outgo (swstak[swtop + 2]);
2023 outtab();
2024 outstr (sgoto); * goto ... *
2025 j = lb;
2026 for (i = swtop + 3; i < swlast; i = i + 3) {
2027 * # fill in vacancies *
2028 for ( ; j < swstak[i]; j++) {
2029 outnum(swstak[swtop + 2]);
2030 outch(COMMA);
2031 }
2032 for (j = swstak[i + 1] - swstak[i]; j >= 0; j--)
2033 outnum(swstak[i + 2]); * # fill in range *
2034 j = swstak[i + 1] + 1;
2035 if (i < swlast - 3)
2036 outch(COMMA);
2037 }
2038 outch(RPAREN);
2039 outch(COMMA);
2040 swvar(lab);
2041 outdon();
2042 }
2043 else if (n > 0) { * # output linear search form *
2044 */
2045 if (n > 0) { /* # output linear search form */
2046 for (i = swtop + 3; i < swlast; i = i + 3) {
2047 outtab(); /* # if (Innn */
2048 outstr (sif);
2049 swvar (lab);
2050 if (swstak[i] == swstak[i+1]) {
2051 outstr (seq); /* # .eq....*/
2052 outnum (swstak[i]);
2053 }
2054 else {
2055 outstr (sge); /* # .ge.lb.and.Innn.le.ub */
2056 outnum (swstak[i]);
2057 outstr (sand);
2058 swvar (lab);
2059 outstr (sle);
2060 outnum (swstak[i + 1]);
2061 }
2062 outch (RPAREN); /* # ) goto ... */
2063 outgo (swstak[i + 2]);
2064 }
2065 if (lab + 1 != swstak[swtop + 2])
2066 outgo (swstak[swtop + 2]);
2067 }
2068 outcon (lab + 1); /* # L+1 continue */
2069 swlast = swtop; /* # pop switch stack */
2070 swtop = swstak[swtop];
2071 }
2072
2073 /*
2074 * swvar - output switch variable Innn, where nnn = lab
2075 */
swvar(lab)2076 swvar (lab)
2077 int lab;
2078 {
2079
2080 outch ('I');
2081 outnum (lab);
2082 }
2083