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