[net.sources] Ratfor in C

oz@yetti.UUCP (Ozan Yigit) (06/19/85)

The following is a C version of Ratfor. It is almost a direct
translation from a Ratfor in ratfor, distributed by the University
of Arizona. The code is full of peculiarities, indicative of such
a translation. The preprocessor seem to work well, but it probably
contains many bugs, some of which were discovered and fixed by
the software tools group for their own brand of ratfor. I have
used this particular pre-processor to create many other pre-processors,
including one for VMS DCL. So, if you need such a pre-processor,
and do not have fortran, or UN*X version of it, here it is !!!

Ps:  I would appreciate receiving any bug fixes you may have.

Oz	(whizzard of something or another, no doubt..)
	Usenet: [dacvax|allegra|ihnp4|linus]!utzoo!yetti!oz
	Bitnet: oz@[yuleo|yuyetti]

---------- CUT -------------------- CUT ------------------
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	ratfor.c
#	ratcom.h
#	ratdef.h
#	makefile
#	lookup.c
#	lookup.h
# This archive created: Wed Jun 19 15:01:06 1985
export PATH; PATH=/bin:$PATH
if test -f 'ratfor.c'
then
	echo shar: over-writing existing file "'ratfor.c'"
fi
cat << \SHAR_EOF > 'ratfor.c'
/*
 * ratfor
 *
 * A ratfor pre-processor in C. It is almost a direct
 * translation of a pre-processor distributed by the
 * University of Arizona. It closely corresponds to the
 * pre-processor described in the "SOFTWARE TOOLS" book.
 * It lacks the "case" construct available in the UNIX
 * version of ratfor.
 *
 * By:	Oz
 *	March 1984
 *
 */
#include <stdio.h>
#include "ratdef.h"
#include "ratcom.h"

/* keywords: */

char sdo[3] = {
	LETD,LETO,EOS};
char vdo[2] = {
	LEXDO,EOS};

char sif[3] = {
	LETI,LETF,EOS};
char vif[2] = {
	LEXIF,EOS};

char selse[5] = {
	LETE,LETL,LETS,LETE,EOS};
char velse[2] = {
	LEXELSE,EOS};

char swhile[6] = {
	LETW, LETH, LETI, LETL, LETE, EOS};
char vwhile[2] = {
	LEXWHILE, EOS};

char sbreak[6] = {
	LETB, LETR, LETE, LETA, LETK, EOS};
char vbreak[2] = {
	LEXBREAK, EOS};

char snext[5] = {
	LETN,LETE, LETX, LETT, EOS};
char vnext[2] = {
	LEXNEXT, EOS};

char sfor[4] = {
	LETF,LETO, LETR, EOS};
char vfor[2] = {
	LEXFOR, EOS};

char srept[7] = {
	LETR, LETE, LETP, LETE, LETA, LETT, EOS};
char vrept[2] = {
	LEXREPEAT, EOS};

char suntil[6] = {
	LETU, LETN, LETT, LETI, LETL, EOS};
char vuntil[2] = {
	LEXUNTIL, EOS};

char sret[7] = {
	LETR, LETE, LETT, LETU, LETR, LETN, EOS};
char vret[2] = {
	LEXRETURN, EOS};

char sstr[7] = {
	LETS, LETT, LETR, LETI, LETN, LETG, EOS};
char vstr[2] = {
	LEXSTRING, EOS};
char deftyp[2] = {
	DEFTYPE, EOS};

/* constant strings */

char *errmsg = "error at line ";
char *in     = " in ";
char *ifnot  = "if(.not.";
char *incl   = "include";
char *fncn   = "function";
char *def    = "define";
char *bdef   = "DEFINE";
char *contin = "continue";
char *rgoto  = "goto ";
char *dat    = "data ";
char *eoss   = "EOS/";

extern char ngetch();

/* ------------------------------ */
/* M A I N   L I N E  &  I N I T  */
/* ------------------------------ */

main(argc,argv)
int argc;
char *argv[];
{
	int i;
	char *p;

	if (argc == 1)
		usage();
	if ((infile[0] = fopen(argv[1], "r")) == NULL) {
		fprintf(stderr,"%s: cannot open.\n",argv[1]);
		exit(1);
	}
	if (p = argv[2])
		if ((freopen(p, "w", stdout)) == NULL) {
			fprintf(stderr,"%s: cannot create.\n",p);
			exit(1);
	}

/*
 * initialise our stuff..
 *
 */
	outp = 0;		/* output character pointer */
	level = 0;		/* file control */
	linect[0] = 1;		/* line count of first file */
	fnamp = 0;
	fnames[0] = EOS;
	bp = -1;		/* pushback buffer pointer */
	fordep = 0;		/* for stack */
	for( i = 0; i <= 126; i++)
		tabptr[i] = 0;
	install(def, deftyp);	/* default definitions */
	install(bdef, deftyp);
	fcname[0] = EOS;	/* current function name */
	label = 23000;		/* next generated label */

	parse();		/* call parser.. */
	exit(1);
}


/* ------------------------------ */
/* P A R S E R 			  */
/* ------------------------------ */

parse()
{
	char lexstr[MAXTOK];
	int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, token;

	sp = 0;
	lextyp[0] = EOF;
	for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
		if (token == LEXIF)
			ifcode(&lab);
		else if (token == LEXDO)
			docode(&lab);
		else if (token == LEXWHILE)
			whilec(&lab);
		else if (token == LEXFOR)
			forcod(&lab);
		else if (token == LEXREPEAT)
			repcod(&lab);
		else if (token == LEXDIGITS)
			labelc(lexstr);
		else if (token == LEXELSE) {
			if (lextyp[sp] == LEXIF)
				elseif(labval[sp]);
			else
				synerr("illegal else.");
		}
		if (token == LEXIF || token == LEXELSE || token == LEXWHILE
		    || token == LEXFOR || token == LEXREPEAT
		    || token == LEXDO || token == LEXDIGITS 
		    || token == LBRACE) {
			sp++;         /* beginning of statement */
			if (sp > MAXSTACK)
				baderr("stack overflow in parser.");
			lextyp[sp] = token;     /* stack type and value */
			labval[sp] = lab;
		}
		else {      /* end of statement - prepare to unstack */
			if (token == RBRACE) {
				if (lextyp[sp] == LBRACE)
					sp--;
				else
					synerr("illegal right brace.");
			}
			else if (token == LEXOTHER)
				otherc(lexstr);
			else if (token == LEXBREAK || token == LEXNEXT)
				brknxt(sp, lextyp, labval, token);
			else if (token == LEXRETURN)
				retcod();
		 	else if (token == LEXSTRING)
				strdcl();
			token = lex(lexstr);      /* peek at next token */
			pbstr(lexstr);
			unstak(&sp, lextyp, labval, token);
		}
	}
	if (sp != 0)
		synerr("unexpected EOF.");
}


/* ------------------------------ */
/* L E X I C A L  A N A L Y S E R */
/* ------------------------------ */

/*
 *  alldig - return YES if str is all digits
 *
 */
int
alldig(str)
char str[];
{
	int i,j;

	j = NO;
	if (str[0] == EOS)
		return(j);
	for (i = 0; str[i] != EOS; i++)
		if (type(str[i]) != DIGIT)
			return(j);
	j = YES;
	return(j);
}


/*
 * balpar - copy balanced paren string
 *
 */
balpar()
{
	char token[MAXTOK];
	int t,nlpar;

	if (gnbtok(token, MAXTOK) != LPAREN) {
		synerr("missing left paren.");
		return;
	}
	outstr(token);
	nlpar = 1;
	do {
		t = gettok(token, MAXTOK);
		if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
			pbstr(token);
			break;
		}
		if (t == NEWLINE)      /* delete newlines */
			token[0] = EOS;
		else if (t == LPAREN)
			nlpar++;
		else if (t == RPAREN)
			nlpar--;
		/* else nothing special */
		outstr(token);
	} 
	while (nlpar > 0);
	if (nlpar != 0)
		synerr("missing parenthesis in condition.");
}

/*
 * deftok - get token; process macro calls and invocations
 *
 */
int
deftok(token, toksiz, fd)
char token[];
int toksiz;
FILE *fd;
{
	char defn[MAXDEF];
	int t;

	for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
		if (t != ALPHA)   /* non-alpha */
			break;
		if (look(token, defn) == NO)   /* undefined */
			break;
		if (defn[0] == DEFTYPE) {   /* get definition */
			getdef(token, toksiz, defn, MAXDEF, fd);
			install(token, defn);
		}
		else
			pbstr(defn);   /* push replacement onto input */
	}
	if (t == ALPHA)   /* convert to single case */
		fold(token);
	return(t);
}


/*
 * eatup - process rest of statement; interpret continuations
 *
 */
eatup()
{

	char ptoken[MAXTOK], token[MAXTOK];
	int nlpar, t;

	nlpar = 0;
	do {
		t = gettok(token, MAXTOK);
		if (t == SEMICOL || t == NEWLINE)
			break;
		if (t == RBRACE || t == LBRACE) {
			pbstr(token);
			break;
		}
		if (t == EOF) {
			synerr("unexpected EOF.");
			pbstr(token);
			break;
		}
		if (t == COMMA || t == PLUS 
			       || t == MINUS || t == STAR || t == LPAREN
		               || t == AND || t == BAR || t == BANG
			       || t == EQUALS || t == UNDERLINE ) {
			while (gettok(ptoken, MAXTOK) == NEWLINE)
				;
			pbstr(ptoken);
			if (t == UNDERLINE)
				token[0] = EOS;
		}
		if (t == LPAREN)
			nlpar++;
		else if (t == RPAREN)
			nlpar--;
		outstr(token);

	} while (nlpar >= 0);

	if (nlpar != 0)
		synerr("unbalanced parentheses.");
}

/*
 * getdef (for no arguments) - get name and definition
 *
 */
getdef(token, toksiz, defn, defsiz, fd)
char token[];
int toksiz;
char defn[];
int defsiz;
FILE *fd;
{
	int i, nlpar, t;
	char c, ptoken[MAXTOK];

	skpblk(fd);
	/*
	 * define(name,defn) or
	 * define name defn
	 *
	 */
	if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
		t = BLANK;              /* define name defn */
		pbstr(ptoken);
	}
	skpblk(fd);
	if (gtok(token, toksiz, fd) != ALPHA)
		baderr("non-alphanumeric name.");
	skpblk(fd);
	c = (char) gtok(ptoken, MAXTOK, fd);
	if (t == BLANK) {         /* define name defn */
		pbstr(ptoken);
		i = 0;
		do {
			c = ngetch(&c, fd);
			if (i > defsiz)
				baderr("definition too long.");
			defn[i++] = c;
		} 
		while (c != SHARP && c != NEWLINE && c != EOF);
		if (c == SHARP)
			putbak(c);
	}
	else if (t == LPAREN) {   /* define (name, defn) */
		if (c != COMMA)
			baderr("missing comma in define.");
		/* else got (name, */
		nlpar = 0;
		for (i = 0; nlpar >= 0; i++)
			if (i > defsiz)
				baderr("definition too long.");
			else if (ngetch(&defn[i], fd) == EOF)
				baderr("missing right paren.");
			else if (defn[i] == LPAREN)
				nlpar++;
			else if (defn[i] == RPAREN)
				nlpar--;
		/* else normal character in defn[i] */
	}
	else
		baderr("getdef is confused.");
	defn[i-1] = EOS;
}

/*
 * gettok - get token. handles file inclusion and line numbers
 *
 */
int
gettok(token, toksiz)
char token[];
int toksiz;
{
	int t, i;
	int tok;
	char name[MAXNAME];

	for ( ; level >= 0; level--) {
		for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
		     tok = deftok(token, toksiz, infile[level])) {
			    if (equal(token, fncn) == YES) {
				skpblk(infile[level]);
				t = deftok(fcname, MAXNAME, infile[level]);
				pbstr(fcname);
				if (t != ALPHA)
					synerr("missing function name.");
				putbak(BLANK);
				return(tok);
			}
			else if (equal(token, incl) == NO)
				return(tok);
			for (i = 0 ;; i = strlen(name)) {
				t = deftok(&name[i], MAXNAME, infile[level]);
				if (t == NEWLINE || t == SEMICOL) {
					pbstr(&name[i]);
					break;
				}
			}
			name[i] = EOS;
			if (name[1] == SQUOTE) {
				outtab();
				outstr(token);
				outstr(name);
				outdon();
				eatup();
				return(tok);
			}
			if (level >= NFILES)
				synerr("includes nested too deeply.");
			else {
				infile[level+1] = fopen(name, "r");
				linect[level+1] = 1;
				if (infile[level+1] == NULL)
					synerr("can't open include.");
				else {
					level++;
					if (fnamp + i <= MAXFNAMES) {
						scopy(name, 0, fnames, fnamp);
						fnamp = fnamp + i;    /* push file name stack */
					}
				}
			}
		}
		if (level > 0) {      /* close include and pop file name stack */
			fclose(infile[level]);
			for (fnamp--; fnamp > 0; fnamp--)
				if (fnames[fnamp-1] == EOS)
					break;
		}
	}
	token[0] = EOF;   /* in case called more than once */
	token[1] = EOS;
	tok = EOF;
	return(tok);
}

/*
 * gnbtok - get nonblank token
 *
 */
int
gnbtok(token, toksiz)
char token[];
int toksiz;
{
	int tok;

	skpblk(infile[level]);
	tok = gettok(token, toksiz);
	return(tok);
}

/*
 * gtok - get token for Ratfor
 *
 */
int
gtok(lexstr, toksiz, fd)
char lexstr[];
int toksiz;
FILE *fd;
{
	int i, b, n, tok; 
	char c;
	c = ngetch(&lexstr[0], fd);
	if (c == BLANK || c == TAB) {
		lexstr[0] = BLANK;
		while (c == BLANK || c == TAB)    /* compress many blanks to one */
			c = ngetch(&c, fd);
		if (c == SHARP)
			while (ngetch(&c, fd) != NEWLINE)   /* strip comments */
				;
		if (c != NEWLINE)
			putbak(c);
		else
			lexstr[0] = NEWLINE;
		lexstr[1] = EOS;
		return((int)lexstr[0]);
	}
	i = 0;
	tok = type(c);
	if (tok == LETTER) {	/* alpha */
		for (i = 0; i < toksiz - 3; i++) {
			tok = type(ngetch(&lexstr[i+1], fd));
			/* Test for DOLLAR added by BM, 7-15-80 */
			if (tok != LETTER && tok != DIGIT 
			    && tok != UNDERLINE && tok!=DOLLAR
			    && tok != PERIOD)
				break;
		}
		putbak(lexstr[i+1]);
		tok = ALPHA;
	}
	else if (tok == DIGIT) {	/* digits */
		b = c - DIG0;	/* in case alternate base number */
		for (i = 0; i < toksiz - 3; i++) {
			if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
				break;
			b = 10*b + lexstr[i+1] - DIG0;
		}
		if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {   
			/* n%ddd... */
			for (n = 0;; n = b*n + c - DIG0) {
				c = ngetch(&lexstr[0], fd);
				if (c >= LETA && c <= LETZ)
					c = c - LETA + DIG9 + 1;
				else if (c >= BIGA && c <= BIGZ)
					c = c - BIGA + DIG9 + 1;
				if (c < DIG0 || c >= DIG0 + b)
					break;
			}
			putbak(lexstr[0]);
			i = itoc(n, lexstr, toksiz);
		}
		else
			putbak(lexstr[i+1]);
		tok = DIGIT;
	}
#ifdef SQUAREB
	else if (c == LBRACK) {   /* allow [ for { */
		lexstr[0] = LBRACE;
		tok = LBRACE;
	}
	else if (c == RBRACK) {   /* allow ] for } */
		lexstr[0] = RBRACE;
		tok = RBRACE;
	}
#endif
	else if (c == SQUOTE || c == DQUOTE) {
		for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
			if (lexstr[i] == UNDERLINE)
				if (ngetch(&c, fd) == NEWLINE) {
					while (c == NEWLINE || c == BLANK || c == TAB)
						c = ngetch(&c, fd);
					lexstr[i] = c;
				}
				else
					putbak(c);
			if (lexstr[i] == NEWLINE || i >= toksiz-1) {
				synerr("missing quote.");
				lexstr[i] = lexstr[0];
				putbak(NEWLINE);
				break;
			}
		}
	}
	else if (c == SHARP) {   /* strip comments */
		while (ngetch(&lexstr[0], fd) != NEWLINE)
			;
		tok = NEWLINE;
	}
	else if (c == GREATER || c == LESS || c == NOT 
		 || c == BANG || c == CARET || c == EQUALS 
		 || c == AND || c == OR)
		i = relate(lexstr, fd);
	if (i >= toksiz-1)
		synerr("token too long.");
	lexstr[i+1] = EOS;
	if (lexstr[0] == NEWLINE)
		linect[level] = linect[level] + 1;
	return(tok);
}

/*
 * lex - return lexical type of token
 *
 */
int
lex(lexstr)
char lexstr[];
{

	int tok;

	for (tok = gnbtok(lexstr, MAXTOK);
	     tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
		    ;
	if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
		return(tok);
	if (tok == DIGIT)
		tok = LEXDIGITS;
	else if (equal(lexstr, sif) == YES)
		tok = vif[0];
	else if (equal(lexstr, selse) == YES)
		tok = velse[0];
	else if (equal(lexstr, swhile) == YES)
		tok = vwhile[0];
	else if (equal(lexstr, sdo) == YES)
		tok = vdo[0];
	else if (equal(lexstr, sbreak) == YES)
		tok = vbreak[0];
	else if (equal(lexstr, snext) == YES)
		tok = vnext[0];
	else if (equal(lexstr, sfor) == YES)
		tok = vfor[0];
	else if (equal(lexstr, srept) == YES)
		tok = vrept[0];
	else if (equal(lexstr, suntil) == YES)
		tok = vuntil[0];
	else if (equal(lexstr, sret) == YES)
		tok = vret[0];
	else if (equal(lexstr, sstr) == YES)
		tok = vstr[0];
	else
		tok = LEXOTHER;
	return(tok);
}

/*
 * ngetch - get a (possibly pushed back) character
 *
 */
char
ngetch(c, fd)
char *c;
FILE *fd;
{

	if (bp >= 0) {
		*c = buf[bp];
		bp--;
	}
	else
		*c = (char) getc(fd);
	
	return(*c);
}
/*
 * pbstr - push string back onto input
 *
 */
pbstr(in)
char in[];
{
	int i;

	for (i = strlen(in) - 1; i >= 0; i--)
		putbak(in[i]);
}

/*
 * putbak - push char back onto input
 *
 */
putbak(c)
char c;
{

	bp++;
	if (bp > BUFSIZE)
		baderr("too many characters pushed back.");
	buf[bp] = c;
}


/*
 * relate - convert relational shorthands into long form
 *
 */
int
relate(token, fd)
char token[];
FILE *fd;
{

	if (ngetch(&token[1], fd) != EQUALS) {
		putbak(token[1]);
		token[2] = LETT;
	}
	else
		token[2] = LETE;
	token[3] = PERIOD;
	token[4] = EOS;
	token[5] = EOS;	/* for .not. and .and. */
	if (token[0] == GREATER)
		token[1] = LETG;
	else if (token[0] == LESS)
		token[1] = LETL;
	else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
		if (token[1] != EQUALS) {
			token[2] = LETO;
			token[3] = LETT;
			token[4] = PERIOD;
		}
		token[1] = LETN;
	}
	else if (token[0] == EQUALS) {
		if (token[1] != EQUALS) {
			token[2] = EOS;
			return(0);
		}
		token[1] = LETE;
		token[2] = LETQ;
	}
	else if (token[0] == AND) {
		token[1] = LETA;
		token[2] = LETN;
		token[3] = LETD;
		token[4] = PERIOD;
	}
	else if (token[0] == OR) {
		token[1] = LETO;
		token[2] = LETR;
	}
	else   /* can't happen */
		token[1] = EOS;
	token[0] = PERIOD;
	return(strlen(token)-1);
}

/*
 * skpblk - skip blanks and tabs in file  fd
 *
 */
skpblk(fd)
FILE *fd;
{
	char c;

	for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
		;
	putbak(c);
}


/* 
 * type - return LETTER, DIGIT or char; works with ascii alphabet
 *
 */
int
type(c)
char c;
{
	int t;

	if (c >= DIG0 && c <= DIG9)
		t = DIGIT;
	else if (c >= LETA && c <= LETZ)
		t = LETTER;
	else if (c >= BIGA && c <= BIGZ)
		t = LETTER;
	else
		t = c;
	return(t);
}


/* ------------------------------ */
/* C O D E  G E N E R A T I O N   */
/* ------------------------------ */

/*
 * brknxt - generate code for break n and next n; n = 1 is default
 *
 */
brknxt(sp, lextyp, labval, token)
int sp;
int lextyp[];
int labval[];
int token;
{
	int i, n;
	char t, ptoken[MAXTOK];

	n = 0;
	t = gnbtok(ptoken, MAXTOK);
	if (alldig(ptoken) == YES) {     /* have break n or next n */
		i = 0;
		n = ctoi(ptoken, &i) - 1;
	}
	else if (t != SEMICOL)      /* default case */
		pbstr(ptoken);
	for (i = sp; i >= 0; i--)
		if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
		    || lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
			if (n > 0) {
				n--;
				continue;             /* seek proper level */
			}
			else if (token == LEXBREAK)
				outgo(labval[i]+1);
			else
				outgo(labval[i]);
			xfer = YES;
			return;
		}
	if (token == LEXBREAK)
		synerr("illegal break.");
	else
		synerr("illegal next.");
	return;
}

/*
 * docode - generate code for beginning of do
 *
 */
docode(lab)
int *lab;
{
	xfer = NO;
	outtab();
	outstr(sdo);
	*lab = labgen(2);
	outnum(*lab);
	eatup();
	outdon();
}

/*
 * dostat - generate code for end of do statement
 *
 */
dostat(lab)
int lab;
{
	outcon(lab);
	outcon(lab+1);
}

/*
 * elseif - generate code for end of if before else
 *
 */
elseif(lab)
int lab;
{

	outgo(lab+1);
	outcon(lab);
}

/*
 * forcod - beginning of for statement
 *
 */
forcod(lab)
int *lab;
{
	char t, token[MAXTOK];
	int i, j, nlpar,tlab;

	tlab = *lab;
	tlab = labgen(3);
	outcon(0);
	if (gnbtok(token, MAXTOK) != LPAREN) {
		synerr("missing left paren.");
		return;
	}
	if (gnbtok(token, MAXTOK) != SEMICOL) {   /* real init clause */
		pbstr(token);
		outtab();
		eatup();
		outdon();
	}
	if (gnbtok(token, MAXTOK) == SEMICOL)   /* empty condition */
		outcon(tlab);
	else {   /* non-empty condition */
		pbstr(token);
		outnum(tlab);
		outtab();
		outstr(ifnot);
		outch(LPAREN);
		nlpar = 0;
		while (nlpar >= 0) {
			t = gettok(token, MAXTOK);
			if (t == SEMICOL)
				break;
			if (t == LPAREN)
				nlpar++;
			else if (t == RPAREN)
				nlpar--;
			if (t == EOF) {
				pbstr(token);
				return;
			}
			if (t != NEWLINE && t != UNDERLINE)
				outstr(token);
		}
		outch(RPAREN);
		outch(RPAREN);
		outgo((tlab)+2);
		if (nlpar < 0)
			synerr("invalid for clause.");
	}
	fordep++;		/* stack reinit clause */
	j = 0;
	for (i = 1; i < fordep; i++)   /* find end *** should i = 1 ??? *** */
		j = j + strlen(&forstk[j]) + 1;
	forstk[j] = EOS;   /* null, in case no reinit */
	nlpar = 0;
	t = gnbtok(token, MAXTOK);
	pbstr(token);
	while (nlpar >= 0) {
		t = gettok(token, MAXTOK);
		if (t == LPAREN)
			nlpar++;
		else if (t == RPAREN)
			nlpar--;
		if (t == EOF) {
			pbstr(token);
			break;
		}
		if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
			if (j + strlen(token) >= MAXFORSTK)
				baderr("for clause too long.");
			scopy(token, 0, forstk, j);
			j = j + strlen(token);
		}
	}
	tlab++;   /* label for next's */
	*lab = tlab;
}

/*
 * fors - process end of for statement
 *
 */
fors(lab)
int lab;
{
	int i, j;

	xfer = NO;
	outnum(lab);
	j = 0;
	for (i = 1; i < fordep; i++)
		j = j + strlen(&forstk[j]) + 1;
	if (strlen(&forstk[j]) > 0) {
		outtab();
		outstr(&forstk[j]);
		outdon();
	}
	outgo(lab-1);
	outcon(lab+1);
	fordep--;
}

/*
 * ifcode - generate initial code for if
 *
 */
ifcode(lab)
int *lab;
{

	xfer = NO;
	*lab = labgen(2);
	ifgo(*lab);
}

/*
 * ifgo - generate "if(.not.(...))goto lab"
 *
 */
ifgo(lab)
int lab;
{

	outtab();      /* get to column 7 */
	outstr(ifnot);      /* " if(.not. " */
	balpar();      /* collect and output condition */
	outch(RPAREN);      /* " ) " */
	outgo(lab);         /* " goto lab " */
}


/*
 * labelc - output statement number
 *
 */
labelc(lexstr)
char lexstr[];
{

	xfer = NO;   /* can't suppress goto's now */
	if (strlen(lexstr) == 5)   /* warn about 23xxx labels */
		if (lexstr[0] == DIG2 && lexstr[1] == DIG3)
			synerr("warning: possible label conflict.");
	outstr(lexstr);
	outtab();
}

/*
 * labgen - generate  n  consecutive labels, return first one
 *
 */
int
labgen(n)
int n;
{
	int i;

	i = label;
	label = label + n;
	return(i);
}

/*
 * otherc - output ordinary Fortran statement
 *
 */
otherc(lexstr)
char lexstr[];
{
	xfer = NO;
	outtab();
	outstr(lexstr);
	eatup();
	outdon();
}

/*
 * outch - put one char into output buffer
 *
 */
outch(c)
char c;
{
	int i;

	if (outp >= 72) {   /* continuation card */
		outdon();
		/*** should output "-" for dcl continuation.. ***/
		for (i = 0; i < 6; i++)
			outbuf[i] = BLANK;
		outp = 6;
	}
	outbuf[outp] = c;
	outp++;
}

/*
 * outcon - output "n   continue"
 *
 */
outcon(n)
int n;
{
	xfer = NO;
	if (n <= 0 && outp == 0)
		return;            /* don't need unlabeled continues */
	if (n > 0)
		outnum(n);
	outtab();
	outstr(contin);
	outdon();
}

/*
 * outdon - finish off an output line
 *
 */
outdon()
{

	outbuf[outp] = NEWLINE;
	outbuf[outp+1] = EOS;
	printf(outbuf);
	outp = 0;
}

/*
 * outgo - output "goto  n"
 *
 */
outgo(n)
int n;
{
	if (xfer == YES)
		return;
	outtab();
	outstr(rgoto);
	outnum(n);
	outdon();
}

/*
 * outnum - output positive decimal number
 *
 */
outnum(n)
int n;
{

	char chars[MAXCHARS];
	int i, m;

	m = n;
	i = -1;
	do {
		i++;
		chars[i] = (m % 10) + DIG0;
		m = m / 10;
	} 
	while (m > 0 && i < MAXCHARS);
	for ( ; i >= 0; i--)
		outch(chars[i]);
}


 
/*
 * outstr - output string
 *
 */
outstr(str)
char str[];
{
	int i;

	for (i=0; str[i] != EOS; i++)
		outch(str[i]);
}

/*
 * outtab - get past column 6
 *
 */
outtab()
{
	while (outp < 6)
		outch(BLANK);
}


/*
 * repcod - generate code for beginning of repeat
 *
 */
repcod(lab)
int *lab;
{

	int tlab;

	tlab = *lab;
	outcon(0);   /* in case there was a label */
	tlab = labgen(3);
	outcon(tlab);
	*lab = ++tlab;		/* label to go on next's */
}

/*
 * retcod - generate code for return
 *
 */
retcod()
{
	char token[MAXTOK], t;

	t = gnbtok(token, MAXTOK);
	if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
		pbstr(token);
		outtab();
		outstr(fcname);
		outch(EQUALS);
		eatup();
		outdon();
	}
	else if (t == RBRACE)
		pbstr(token);
	outtab();
	outstr(sret);
	outdon();
	xfer = YES;
}


/* strdcl - generate code for string declaration */
strdcl()
{
	char t, name[MAXNAME], init[MAXTOK];
	int i, len;

	t = gnbtok(name, MAXNAME);
	if (t != ALPHA)
		synerr("missing string name.");
	if (gnbtok(init, MAXTOK) != LPAREN) {  /* make size same as initial value */
		len = strlen(init) + 1;
		if (init[1] == SQUOTE || init[1] == DQUOTE)
			len = len - 2;
	}
	else {	/* form is string name(size) init */
		t = gnbtok(init, MAXTOK);
		i = 0;
		len = ctoi(init, &i);
		if (init[i] != EOS)
			synerr("invalid string size.");
		if (gnbtok(init, MAXTOK) != RPAREN)
			synerr("missing right paren.");
		else
			t = gnbtok(init, MAXTOK);
	}
	outtab();
	/*
	*   outstr(int);
	*/
	outstr(name);
	outch(LPAREN);
	outnum(len);
	outch(RPAREN);
	outdon();
	outtab();
	outstr(dat);
	len = strlen(init) + 1;
	if (init[0] == SQUOTE || init[0] == DQUOTE) {
		init[len-1] = EOS;
		scopy(init, 1, init, 0);
		len = len - 2;
	}
	for (i = 1; i <= len; i++) {	/* put out variable names */
		outstr(name);
		outch(LPAREN);
		outnum(i);
		outch(RPAREN);
		if (i < len)
			outch(COMMA);
		else
			outch(SLASH);
		;
	}
	for (i = 0; init[i] != EOS; i++) {	/* put out init */
		outnum(init[i]);
		outch(COMMA);
	}
	pbstr(eoss);	/* push back EOS for subsequent substitution */
}


/*
 * unstak - unstack at end of statement
 *
 */
unstak(sp, lextyp, labval, token)
int *sp;
int lextyp[];
int labval[];
char token;
{
	int tp;

	tp = *sp;
	for ( ; tp > 0; tp--) {
		if (lextyp[tp] == LBRACE)
			break;
		if (lextyp[tp] == LEXIF && token == LEXELSE)
			break;
		if (lextyp[tp] == LEXIF)
			outcon(labval[tp]);
		else if (lextyp[tp] == LEXELSE) {
			if (*sp > 1)
				tp--;
			outcon(labval[tp]+1);
		}
		else if (lextyp[tp] == LEXDO)
			dostat(labval[tp]);
		else if (lextyp[tp] == LEXWHILE)
			whiles(labval[tp]);
		else if (lextyp[tp] == LEXFOR)
			fors(labval[tp]);
		else if (lextyp[tp] == LEXREPEAT)
			untils(labval[tp], token);
	}
	*sp = tp;
}

/*
 * untils - generate code for until or end of repeat
 *
 */
untils(lab, token)
int lab;
int token;
{
	char ptoken[MAXTOK];

	xfer = NO;
	outnum(lab);
	if (token == LEXUNTIL) {
		lex(ptoken);
		ifgo(lab-1);
	}
	else
		outgo(lab-1);
	outcon(lab+1);
}

/* 
 * whilec - generate code for beginning of while 
 *
 */
whilec(lab)
int *lab;
{
	int tlab;

	tlab = *lab;
	outcon(0);         /* unlabeled continue, in case there was a label */
	tlab = labgen(2);
	outnum(tlab);
	ifgo(tlab+1);
	*lab = tlab;
}

/* 
 * whiles - generate code for end of while 
 *
 */
whiles(lab)
int lab;
{

	outgo(lab);
	outcon(lab+1);
}


/* ------------------------------ */
/* E R R O R  M E S S A G E S     */
/* ------------------------------ */

/*
 *  baderr - print error message, then die
 *
 */
baderr(msg)
char msg[];
{
	synerr(msg);
	exit(1);
}


/* 
 * synerr - report Ratfor syntax error
 *
 */
synerr(msg)
char msg[];
{
	char lc[MAXCHARS];
	int i;

	fprintf(stderr,errmsg);
	if (level >= 0)
		i = level;
	else
		i = 0;   /* for EOF errors */
	itoc(linect[i], lc, MAXCHARS);
	fprintf(stderr,lc);
	for (i = fnamp - 1; i > 1; i = i - 1)
		if (fnames[i-1] == EOS) {   /* print file name */
			fprintf(stderr,in);
			fprintf(stderr,fnames[i]);
			break;
		}
	fprintf(stderr,": \n      %s\n",msg);
}

/*
 * usage
 *
 */
usage()
{
	fprintf(stderr,"usage: ratfor <input file> [output file]\n");
	exit(1);
}


/* ------------------------------ */
/* U T I L I T Y  R O U T I N E S */
/* ------------------------------ */

/*
 * ctoi - convert string at in[i] to int, increment i
 *
 */
int
ctoi(in, i)
char in[];
int *i;
{
	int k, j;

	j = *i;
	while (in[j] == BLANK || in[j] == TAB)
		j++;
	for (k = 0; in[j] != EOS; j++) {
		if (in[j] < DIG0 || in[j] > DIG9)
			break;
		k = 10 * k + in[j] - DIG0;
	}
	*i = j;
	return(k);
}

/*
 * fold - convert alphabetic token to single case
 *
 */
fold(token)
char token[];
{

	int i;

	/* WARNING - this routine depends heavily on the */
	/* fact that letters have been mapped into internal */
	/* right-adjusted ascii. god help you if you */
	/* have subverted this mechanism. */

	for (i = 0; token[i] != EOS; i++)
		if (token[i] >= BIGA && token[i] <= BIGZ)
			token[i] = token[i] - BIGA + LETA;
}

/*
 * equal - compare str1 to str2; return YES if equal, NO if not
 *
 */
int
equal(str1, str2)
char str1[];
char str2[];
{
	int i;

	for (i = 0; str1[i] == str2[i]; i++)
		if (str1[i] == EOS) {
			return(YES);
		}
	return(NO);
}

/*
 * scopy - copy string at from[i] to to[j]
 *
 */
scopy(from, i, to, j)
char from[];
int i;
char to[];
int j;
{
	int k1, k2;

	k2 = j;
	for (k1 = i; from[k1] != EOS; k1++) {
		to[k2] = from[k1];
		k2++;
	}
	to[k2] = EOS;
}

#include "lookup.h"
/*
 * look - look-up a definition
 *
 */
int
look(name,defn)
char name[];
char defn[];
{
	extern struct hashlist *lookup();
	struct hashlist *p;

	if ((p = lookup(name)) == NULL)
		return(NO);
	strcpy(defn,p->def);
	return(YES);
}

/*
 * itoc - special version of itoa
 *
 */
int
itoc(n,str,size)
int n;
char str[];
int size;
{

	int i,j,k,sign;
	char c;

	if ((sign = n) < 0)
		n = -n;
	i = 0;
	do {
		str[i++] = n % 10 + '0'; 
	} 
	while ((n /= 10) > 0 && i < size-2);
	if (sign < 0 && i < size-1)
		str[i++] = '-';
	str[i] = EOS;
	/*
	 * reverse the string and plug it back in
	 *
	 */
	for (j = 0, k = strlen(str) - 1; j < k; j++, k--) {
		c = str[j];
		str[j] = str[k];
		str[k] = c;
	}
	return(i-1);
}
SHAR_EOF
if test -f 'ratcom.h'
then
	echo shar: over-writing existing file "'ratcom.h'"
fi
cat << \SHAR_EOF > 'ratcom.h'
int bp;                 /*   next available char; init = 0 */
char buf[BUFSIZE];   /*   pushed-back chars */
char fcname[MAXNAME];   /*   text of current function name */
int fordep;   /*   current depth of for statements */
char forstk[MAXFORSTK];   /*   stack of reinit strings */
int xfer;      /*   YES if just made transfer, NO otherwise */
int label;    /*   next label returned by labgen */
int level ;  /*   level of file inclusion; init = 1 */
int linect[NFILES];   /*   line count on input file[level]; init = 1 */
FILE *infile[NFILES];   /*   file number[level]; init infile[1] = STDIN */
int fnamp;    /*   next free slot in fnames; init = 2 */
char fnames[MAXFNAMES]; /*   stack of include names; init fnames[1] = EOS */
int avail;   /*   first first location in table; init = 1 */
int tabptr[127];   /*   name pointers; init = 0 */
int outp;      /*   last position filled in outbuf; init = 0 */
char outbuf[74];   /*   output lines collected here */
char fname[MAXNAME][NFILES];    /*   file names */
int nfiles;     /*   number of files */
SHAR_EOF
if test -f 'ratdef.h'
then
	echo shar: over-writing existing file "'ratdef.h'"
fi
cat << \SHAR_EOF > 'ratdef.h'
#define ACCENT  96
#define AND     38
#define APPEND
#define ATSIGN  64
#define BACKSLASH       92
#define BACKSPACE       8
#define BANG    33
#define BAR     124
#define BIGA    65
#define BIGB    66
#define BIGC    67
#define BIGD    68
#define BIGE    69
#define BIGF    70
#define BIGG    71
#define BIGH    72
#define BIGI    73
#define BIGJ    74
#define BIGK    75
#define BIGL    76
#define BIGM    77
#define BIGN    78
#define BIGO    79
#define BIGP    80
#define BIGQ    81
#define BIGR    82
#define BIGS    83
#define BIGT    84
#define BIGU    85
#define BIGV    86
#define BIGW    87
#define BIGX    88
#define BIGY    89
#define BIGZ    90
#define BLANK   32
#define CARET   94
#define COLON   58
#define COMMA   44
#define CRLF    13
#define DIG0    48
#define DIG1    49
#define DIG2    50
#define DIG3    51
#define DIG4    52
#define DIG5    53
#define DIG6    54
#define DIG7    55
#define DIG8    56
#define DIG9    57
#define DOLLAR  36
#define DQUOTE  34
#define EOS     0
#define EQUALS  61
#define ESCAPE  ATSIGN
#define GREATER 62
#define HUGE    30000
#define LBRACE  123
#define LBRACK  91
#define LESS    60
#define LETA    97
#define LETB    98
#define LETC    99
#define LETD    100
#define LETE    101
#define LETF    102
#define LETG    103
#define LETH    104
#define LETI    105
#define LETJ    106
#define LETK    107
#define LETL    108
#define LETM    109
#define LETN    110
#define LETO    111
#define LETP    112
#define LETQ    113
#define LETR    114
#define LETS    115
#define LETT    116
#define LETU    117
#define LETV    118
#define LETW    119
#define LETX    120
#define LETY    121
#define LETZ    122
#define LPAREN  40
#define MINUS   45
#define NEWLINE 10
#define NO      0
#define NOT     126
#define OR      BAR	/* same as | */
#define PERCENT 37
#define PERIOD  46
#define PLUS    43
#define QMARK   63
#define RBRACE  125
#define RBRACK  93
#define RPAREN  41
#define SEMICOL 59
#define SHARP   35
#define SLASH   47
#define SQUOTE  39
#define STAR    42
#define TAB     9
#define TILDE   126
#define UNDERLINE       95
#define YES     1
      
#define LIMIT   134217728
#define LIM1    28
#define LIM2    -28

/*
 * lexical analyser symbols
 *
 */

#define LETTER		1
#define DIGIT   	2
#define ALPHA   	3
#define LEXBREAK   	4
#define LEXDIGITS   	5
#define LEXDO   	6
#define LEXELSE   	7
#define LEXFOR   	8
#define LEXIF   	9
#define LEXNEXT   	10
#define LEXOTHER   	11
#define LEXREPEAT   	12
#define LEXUNTIL   	13
#define LEXWHILE   	14
#define LEXRETURN   	15
#define LEXEND   	16
#define LEXSTOP   	17
#define LEXSTRING   	18
#define DEFTYPE   	19

#define MAXCHARS   	10   	/* characters for outnum */
#define MAXDEF   	200   	/* max chars in a defn */
#define MAXFORSTK   	200   	/* max space for for reinit clauses */
#define MAXFNAMES   	350  	/* max chars in filename stack NFILES*MAXNAME */
#define MAXNAME   	64   	/* file name size in gettok */
#define MAXSTACK   	100   	/* max stack depth for parser */
#define MAXTBL   	15000   /* max chars in all definitions */
#define MAXTOK   	132   	/* max chars in a token */
#define NFILES   	7   	/* max depth of file inclusion */

#define RADIX   	PERCENT /* % indicates alternate radix */
#define BUFSIZE   	300   	/* pushback buffer for ngetch and putbak */

SHAR_EOF
if test -f 'makefile'
then
	echo shar: over-writing existing file "'makefile'"
fi
cat << \SHAR_EOF > 'makefile'
CFLAGS = -O

ratfor: ratfor.o lookup.o
	cc -o ratfor ratfor.o lookup.o

ratfor.o: ratdef.h ratcom.h
lookup.o: lookup.h

clean:
	rm -f *.o core ratfor
SHAR_EOF
if test -f 'lookup.c'
then
	echo shar: over-writing existing file "'lookup.c'"
fi
cat << \SHAR_EOF > 'lookup.c'
#include <stdio.h>
#include "lookup.h"

static 
struct	hashlist *hashtab[HASHMAX];

/*
 * from K&R "The C Programming language"
 * Table lookup routines
 *
 * hash - for a hash value for string s
 *
 */
hash(s)
char *s;
{
	int	hashval;

	for (hashval = 0; *s != '\0';)
		hashval += *s++;
	return (hashval % HASHMAX);
}

/*
 * lookup - lookup for a string s in the hash table
 *
 */
struct hashlist
*lookup(s)
char *s;
{
	struct hashlist *np;

	for (np = hashtab[hash(s)]; np != NULL; np = np->next)
		if (strcmp(s, np->name) == 0)
			return(np);	/* found     */
	return(NULL);		/* not found */
}

/*
 * install - install a string name in hashtable and its value def
 *
 */
struct hashlist
*install(name,def)
char *name;
char *def;
{
	int hashval;
	struct hashlist *np, *lookup();
	char *strsave(), *malloc();

	if ((np = lookup(name)) == NULL) {	/* not found.. */
		np = (struct hashlist *) malloc(sizeof(*np));
		if (np == NULL)
			return(NULL);
		if ((np->name = strsave(name)) == NULL)
			return(NULL);
		hashval = hash(np->name);
		np->next = hashtab[hashval];
		hashtab[hashval] = np;
	} else					/* found..     */
		free(np->def);			/* free prev.  */
	if ((np->def = strsave(def)) == NULL)
		return(NULL);
	return(np);
}

/*
 * strsave - save string s somewhere
 *
 */
char
*strsave(s)
char *s;
{
	char *p, *malloc();

	if ((p = malloc(strlen(s)+1)) != NULL)
		strcpy(p, s);
	return(p);
}


SHAR_EOF
if test -f 'lookup.h'
then
	echo shar: over-writing existing file "'lookup.h'"
fi
cat << \SHAR_EOF > 'lookup.h'

/*
 * from K&R "The C Programming language"
 * Table lookup routines 
 * structure and definitions
 *
 */

					/* basic table entry */
struct hashlist {
	char	*name;
	char	*def;
	struct	hashlist *next;		/* next in chain     */
};

#define HASHMAX	100			/* size of hashtable */

					/* hash table itself */
SHAR_EOF
#	End of shell archive
exit 0

ken@boring.UUCP (06/26/85)

These context diffs follow Ozan Yigit's posting of Ratfor in C. There
are 2 bug fixes, and changes to make it generate Fortran-77 code for
if and while statements. A short test program and output are included.

Please send bug reports on the original code to Ozan, bug reports on
the added code to me.  Thanks for the posting, Ozan.

#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	ctxdiff
#	test.r
#	test.f
# This archive created: Wed Jun 26 13:29:08 1985
# By:	Ken Yap ()
export PATH; PATH=/bin:$PATH
if test -f 'ctxdiff'
then
	echo shar: will not over-write existing file "'ctxdiff'"
else
cat << \SHAR_EOF > 'ctxdiff'
*** ratfor.c	Tue Jun 25 14:49:59 1985
--- rat77.c	Wed Jun 26 13:19:13 1985
***************
*** 33,38
  char velse[2] = {
  	LEXELSE,EOS};
  
  char swhile[6] = {
  	LETW, LETH, LETI, LETL, LETE, EOS};
  char vwhile[2] = {

--- 33,44 -----
  char velse[2] = {
  	LEXELSE,EOS};
  
+ char sthen[5] = {
+ 	LETT,LETH,LETE,LETN,EOS};
+ 
+ char sendif[6] = {
+ 	LETE,LETN,LETD,LETI,LETF,EOS};
+ 
  char swhile[6] = {
  	LETW, LETH, LETI, LETL, LETE, EOS};
  char vwhile[2] = {
***************
*** 866,873
  int lab;
  {
  
! 	outgo(lab+1);
! 	outcon(lab);
  }
  
  /*

--- 872,880 -----
  int lab;
  {
  
! 	outtab();
! 	outstr(selse);
! 	outdon();
  }
  
  /*
***************
*** 986,992
  
  	xfer = NO;
  	*lab = labgen(2);
! 	ifgo(*lab);
  }
  
  /*

--- 993,999 -----
  
  	xfer = NO;
  	*lab = labgen(2);
! 	ifthen();
  }
  
  /*
***************
*** 990,995
  }
  
  /*
   * ifgo - generate "if(.not.(...))goto lab"
   *
   */

--- 997,1013 -----
  }
  
  /*
+  * ifend - generate code for end of if
+  *
+  */
+ ifend()
+ {
+ 	outtab();
+ 	outstr(sendif);
+ 	outdon();
+ }
+ 
+ /*
   * ifgo - generate "if(.not.(...))goto lab"
   *
   */
***************
*** 1004,1009
  	outgo(lab);         /* " goto lab " */
  }
  
  
  /*
   * labelc - output statement number

--- 1022,1033 -----
  	outgo(lab);         /* " goto lab " */
  }
  
+ /*
+  * ifthen - generate "if((...))then"
+  *
+  */
+ ifthen()
+ {
  
  	outtab();
  	outstr(sif);
***************
*** 1005,1010
  }
  
  
  /*
   * labelc - output statement number
   *

--- 1029,1041 -----
  ifthen()
  {
  
+ 	outtab();
+ 	outstr(sif);
+ 	balpar();
+ 	outstr(sthen);
+ 	outdon();
+ }
+ 
  /*
   * labelc - output statement number
   *
***************
*** 1096,1102
  
  	outbuf[outp] = NEWLINE;
  	outbuf[outp+1] = EOS;
! 	printf(outbuf);
  	outp = 0;
  }
  

--- 1127,1133 -----
  
  	outbuf[outp] = NEWLINE;
  	outbuf[outp+1] = EOS;
! 	printf("%s", outbuf);
  	outp = 0;
  }
  
***************
*** 1286,1293
  			break;
  		if (lextyp[tp] == LEXIF && token == LEXELSE)
  			break;
! 		if (lextyp[tp] == LEXIF)
! 			outcon(labval[tp]);
  		else if (lextyp[tp] == LEXELSE) {
  			if (*sp > 1)
  				tp--;

--- 1317,1325 -----
  			break;
  		if (lextyp[tp] == LEXIF && token == LEXELSE)
  			break;
! 		if (lextyp[tp] == LEXIF) {
! 			ifend();
! 		}
  		else if (lextyp[tp] == LEXELSE) {
  			if (*sp > 1)
  				tp--;
***************
*** 1291,1297
  		else if (lextyp[tp] == LEXELSE) {
  			if (*sp > 1)
  				tp--;
! 			outcon(labval[tp]+1);
  		}
  		else if (lextyp[tp] == LEXDO)
  			dostat(labval[tp]);

--- 1323,1329 -----
  		else if (lextyp[tp] == LEXELSE) {
  			if (*sp > 1)
  				tp--;
! 			ifend();
  		}
  		else if (lextyp[tp] == LEXDO)
  			dostat(labval[tp]);
***************
*** 1339,1345
  	outcon(0);         /* unlabeled continue, in case there was a label */
  	tlab = labgen(2);
  	outnum(tlab);
! 	ifgo(tlab+1);
  	*lab = tlab;
  }
  

--- 1371,1377 -----
  	outcon(0);         /* unlabeled continue, in case there was a label */
  	tlab = labgen(2);
  	outnum(tlab);
! 	ifthen();
  	*lab = tlab;
  }
  
***************
*** 1352,1357
  {
  
  	outgo(lab);
  	outcon(lab+1);
  }
  

--- 1384,1390 -----
  {
  
  	outgo(lab);
+ 	ifend();
  	outcon(lab+1);
  }
  
***************
*** 1392,1398
  	for (i = fnamp - 1; i > 1; i = i - 1)
  		if (fnames[i-1] == EOS) {   /* print file name */
  			fprintf(stderr,in);
! 			fprintf(stderr,fnames[i]);
  			break;
  		}
  	fprintf(stderr,": \n      %s\n",msg);

--- 1425,1431 -----
  	for (i = fnamp - 1; i > 1; i = i - 1)
  		if (fnames[i-1] == EOS) {   /* print file name */
  			fprintf(stderr,in);
! 			fprintf(stderr,&fnames[i]);
  			break;
  		}
  	fprintf(stderr,": \n      %s\n",msg);
SHAR_EOF
fi # end of overwriting check
if test -f 'test.r'
then
	echo shar: will not over-write existing file "'test.r'"
else
cat << \SHAR_EOF > 'test.r'
integer x,y
x=1; y=2
if(x == y)
	write(6,600)
else if(x > y)
	write(6,601)
else
	write(6,602)
x=1
while(x < 10){
	if(y != 2) break
	if(y != 2) next
	write(6,603)x
	x=x+1
	}
repeat
	x=x-1
until(x == 0)
for(x=0; x < 10; x=x+1)
	write(6,604)x
600 format('Wrong, x != y')
601 format('Also wrong, x < y')
602 format('Ok!')
603 format('x = ',i2)
604 format('x = ',i2)
end
SHAR_EOF
fi # end of overwriting check
if test -f 'test.f'
then
	echo shar: will not over-write existing file "'test.f'"
else
cat << \SHAR_EOF > 'test.f'
      integer x,y
      x=1
      y=2
      if(x .eq. y)then
      write(6,600)
      else
      if(x .gt. y)then
      write(6,601)
      else
      write(6,602)
      endif
      endif
      x=1
23004 if(x .lt. 10)then
      if(y .ne. 2)then
      goto 23005
      endif
      if(y .ne. 2)then
      goto 23004
      endif
      write(6,603)x
      x=x+1
      goto 23004
      endif
23005 continue
23010 continue
      x=x-1
23011 if(.not.(x .eq. 0))goto 23010
23012 continue
      x=0
23013 if(.not.(x .lt. 10))goto 23015
      write(6,604)x
23014 x=x+1
      goto 23013
23015 continue
600   format('Wrong, x != y')
601   format('Also wrong, x < y')
602   format('Ok!')
603   format('x = ',i2)
604   format('x = ',i2)
      end
SHAR_EOF
fi # end of overwriting check
#	End of shell archive
exit 0
-- 
UUCP: ..!{seismo,okstate,garfield,decvax,philabs}!mcvax!ken Voice: Ken!
Mail: Centrum voor Wiskunde en Informatica, Kruislaan 413, 1098 SJ, Amsterdam.

rlk@wlcrjs.UUCP (Richard L. Klappal) (07/12/85)

With the postings of the ratfor preprocessor and the mention of
PD YACC and LEX, I'm wondering if there is a public domain version
of struct available.  Lex, yacc, or C source (or ratfor/f77 for that
matter).

I'm looking for something to take unstructered source code and generate,
as much as possible, structured source code with unnecessary goto's 
removed.  (I have binary struct for f66->ratfor, but I'm looking
for the algorithms.)  I want to clean up some BASIC stuff that was
written with an eggbeater, than cut up and pasted back together
at random :-(.



Richard Klappal
UUCP:		..!ihnp4!wlcrjs!uklpl!rlk  | "Money is truthful.  If a man
MCIMail:	rklappal		   | speaks of his honor, make him
Compuserve:	74106,1021		   | pay cash."
USPS:		1 S 299 Danby Street	   | 
		Villa Park IL 60181	   |	Lazarus Long 
TEL:		(312) 620-4988		   |	    (aka R. Heinlein)
-------------------------------------------------------------------------