[net.sources] Ratfor in C - Repost

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

[munch... burp!!!!]

The following is a repost of the ratfor preprocessor in C. It now contains
a small set of bug fixes and is retrofitted with the switch stmt handling
logic. I understand that few people have already been hacking on the
initial release. I hope this release does not undermine any work that they
have put in. Changes are rather small, and well isolated. The C code to
handle switch (...) { case n[,m ...]: .... default: ... } is at the bottom
of ratfor.c. It should really be moved into the code generation portion,
for consistent code organization. The code for switch stmt is a very literal
translation of the one found in SWTOOLS ratfor. I am glad that even the
latest versions of ratfor corresponds to the very original one, down to the
function and variable names.. There is something to be said about growth
without losing consistency.

An example of a switch stmt:

switch(getjunk()) {
	case 2:	
		if (somecond)
			"COND true"
		else
			"COND false"
	case 3:
		"CASE 3 handled here.."
	case 4:
		"CASE 4 handled here.."
	case 5:
		"CASE 5 handled here.."
	default:
		"DEFAULT actions.."
}

This generates:

      I23000=(getjunk())
      goto 23000
23002 continue
      if(.not.(somecond))goto 23003
      "COND true"
      goto 23004
23003 continue
      "COND false"
23004 continue
      goto 23001
23005 continue
      "CASE 3 handled here.."
      goto 23001
23006 continue
      "CASE 4 handled here.."
      goto 23001
23007 continue
      "CASE 5 handled here.."
      goto 23001
23008 continue
      "DEFAULT actions.."
      goto 23001
23000 continue
      I23000=I23000-1
      if (I23000.lt.1.or.I23000.gt.4)goto 23008
      goto (23002,23005,23006,23007),I23000
23001 continue


Note that, unlike C, ratfor case statements BREAK automatically.

I have done just about as much as I can with ratfor in C. I do not
have time to maintain or bugfix it. Thus, It is up to the rest of
the netpeople to continue with it. However, I would appreciate receiving 
all the updates, fixes etc. One important point: Please avoid
the temptation of re-writing the parser and lexical analyser in
YACC and LEX, or any other such generators, unless they are in PUBLIC
domain. This version of ratfor should be usable and modifiable by those
who do not have YACC or LEX. (BTW: Where is GNU YACC ??? I am eagerly
awaiting!!)

NOTE: This version needs getopt(). (I presume everyone has it!!)

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

--------- chop --------------------------------------------------------
#!/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.doc
#	ratfor.c
#	lookup.c
#	lookup.h
#	ratdef.h
#	ratcom.h
#	makefile
# This archive created: Thu Jun 27 11:02:29 1985
export PATH; PATH=/bin:$PATH
echo shar: extracting "'ratfor.doc'" '(2471 characters)'
if test -f 'ratfor.doc'
then
	echo shar: over-writing existing file "'ratfor.doc'"
fi
sed 's/^X//' << \SHAR_EOF > 'ratfor.doc'
Xratfor - ratfor preprocessor
X     
Xsynopsis:
X        ratfor [-l n] [-o output] input
X     
XRatfor has the following syntax:
X     
Xprog:   stat
X        prog stat
X     
Xstat:   if (...) stat
X        if (...) stat else stat
X        while (...) stat
X        repeat stat
X        repeat stat until (...)
X        for (...;...;...) stat
X        do ... stat
X        switch (intexpr) { case val[,val]: stmt ... default: stmt }
X        break n
X        next n
X        return (...)
X        digits stat
X        { prog }  or  [ prog ]  or  $( prog $)
X        anything unrecognizable
X     
Xwhere stat is any Fortran or Ratfor statement, and intexpr is an
Xexpression that resolves into an integer value.  A statement is
Xterminated by an end-of-line or a semicolon.  The following translations
Xare also performed.
X     
X        <       .lt.    <=      .le.
X        ==      .eq.
X        !=      .ne.    ^=      .ne.    ~=      .ne.
X        >=      .ge.    >       .gt.
X        |       .or.    &       .and.
X        !       .not.   ^       .not.   ~       .not.
X     
XInteger constants in bases other that decimal may be specified as
Xn%dddd...  where n is a decimal number indicating the base and dddd...
Xare digits in that base.  For bases > 10, letters are used for digits
Xabove 9.  Examples:  8%77, 16%2ff, 2%0010011.  The number is converted
Xthe equivalent decimal value using multiplication; this may cause sign
Xproblems if the number has too many digits.
X     
XString literals ("..." or '...') can be continued across line boundaries
Xby ending the line to be continued with an underline.  The underline is
Xnot included as part of the literal.  Leading blanks and tabs on the
Xnext line are ignored; this facilitates consistent indentation.
X     
X        include file
X     
Xwill include the named file in the input.
X     
X        define (name,value)     or
X        define name value
X     
Xdefines name as a symbolic parameter with the indicated value.  Names of
Xsymbolic parameters may contain letters, digits, periods, and underline
Xcharacter but must begin with a letter (e.g.  B.FLAG).  Upper case is
Xnot equivalent to lower case in parameter names.
X     
X        string name "character string"          or
X        string name(size) "character string"
X     
Xdefines name to be an integer array long enough to accomodate the ascii
Xcodes for the given character string, one per word.  The last word of
Xname is initialized to the symbolic parameter EOS, and indicates the end
Xof string.
SHAR_EOF
if test 2471 -ne "`wc -c 'ratfor.doc'`"
then
	echo shar: error transmitting "'ratfor.doc'" '(should have been 2471 characters)'
fi
chmod +x 'ratfor.doc'
echo shar: extracting "'ratfor.c'" '(33223 characters)'
if test -f 'ratfor.c'
then
	echo shar: over-writing existing file "'ratfor.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'ratfor.c'
X/*
X * ratfor - A ratfor pre-processor in C. 
X * Almost a direct translation of a pre-processor distributed by the
X * University of Arizona. Closely corresponds to the
X * pre-processor described in the "SOFTWARE TOOLS" book.
X *
X * Lacks the "case" construct available in the UNIX version of ratfor.
X *
X * By:	Ozan Yigit, York University, Toronto, Canada
X *	March 1984
X *
X * Modification history:
X *
X * June 1985
X *	- Improve front-end with getopt().
X *	  User may specify -l n for starting label.
X *	- Retrofit switch statement handling. This code 
X *	  is stolen from the SWTOOLS Ratfor.
X *
X */
X
X#include <stdio.h>
X#include "ratdef.h"
X#include "ratcom.h"
X
X/* keywords: */
X
Xchar sdo[3] = {
X	LETD,LETO,EOS};
Xchar vdo[2] = {
X	LEXDO,EOS};
X
Xchar sif[3] = {
X	LETI,LETF,EOS};
Xchar vif[2] = {
X	LEXIF,EOS};
X
Xchar selse[5] = {
X	LETE,LETL,LETS,LETE,EOS};
Xchar velse[2] = {
X	LEXELSE,EOS};
X
Xchar swhile[6] = {
X	LETW, LETH, LETI, LETL, LETE, EOS};
Xchar vwhile[2] = {
X	LEXWHILE, EOS};
X
Xchar sbreak[6] = {
X	LETB, LETR, LETE, LETA, LETK, EOS};
Xchar vbreak[2] = {
X	LEXBREAK, EOS};
X
Xchar snext[5] = {
X	LETN,LETE, LETX, LETT, EOS};
Xchar vnext[2] = {
X	LEXNEXT, EOS};
X
Xchar sfor[4] = {
X	LETF,LETO, LETR, EOS};
Xchar vfor[2] = {
X	LEXFOR, EOS};
X
Xchar srept[7] = {
X	LETR, LETE, LETP, LETE, LETA, LETT, EOS};
Xchar vrept[2] = {
X	LEXREPEAT, EOS};
X
Xchar suntil[6] = {
X	LETU, LETN, LETT, LETI, LETL, EOS};
Xchar vuntil[2] = {
X	LEXUNTIL, EOS};
X
Xchar sswitch[7] = {
X	LETS, LETW, LETI, LETT, LETC, LETH, EOS};
Xchar vswitch[2] = {
X	LEXSWITCH, EOS};
X
Xchar scase[5] = {
X	LETC, LETA, LETS, LETE, EOS};
Xchar vcase[2] = {
X	LEXCASE, EOS};
X
Xchar sdefault[8] = {
X	LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS};
Xchar vdefault[2] = {
X	LEXDEFAULT, EOS};
X
Xchar sret[7] = {
X	LETR, LETE, LETT, LETU, LETR, LETN, EOS};
Xchar vret[2] = {
X	LEXRETURN, EOS};
X
Xchar sstr[7] = {
X	LETS, LETT, LETR, LETI, LETN, LETG, EOS};
Xchar vstr[2] = {
X	LEXSTRING, EOS};
X
Xchar deftyp[2] = {
X	DEFTYPE, EOS};
X
X/* constant strings */
X
Xchar *errmsg = "error at line ";
Xchar *in     = " in ";
Xchar *ifnot  = "if(.not.";
Xchar *incl   = "include";
Xchar *fncn   = "function";
Xchar *def    = "define";
Xchar *bdef   = "DEFINE";
Xchar *contin = "continue";
Xchar *rgoto  = "goto ";
Xchar *dat    = "data ";
Xchar *eoss   = "EOS/";
X
Xextern char ngetch();
Xchar *progname;
Xint startlab = 23000;		/* default start label */
X 
X/* 
X * M A I N   L I N E  &  I N I T
X */
X
Xmain(argc,argv)
Xint argc;
Xchar *argv[];
X{
X	int c, errflg = 0;
X	extern int optind;
X	extern char *optarg;
X
X	progname = argv[0];
X
X	while ((c=getopt(argc, argv, "Chn:o:6:")) != EOF)
X	switch (c) {
X		case 'C':
X				/* not written yet */
X			break;
X		case 'h':
X				/* not written yet */
X			break;
X		case 'l':	/* user sets label */
X			startlab = atoi(optarg);
X			break;
X		case 'o':
X			if ((freopen(optarg, "w", stdout)) == NULL)
X				error("can't write %s\n", optarg);
X			break;
X		case '6':
X				/* not written yet */
X			break;
X		default:
X			++errflg;
X	}
X	
X	if (errflg) {
X		fprintf(stderr,
X			"usage: %s [-C][-hx][-l n][-o file][-6x] [file...]\n");
X		exit(1);
X	}
X
X	/*
X	 * present version can only process one file, sadly.
X	 */
X	if (optind >= argc)
X		infile[0] = stdin;
X	else if ((infile[0] = fopen(argv[optind], "r")) == NULL)
X		error("cannot read %s\n", argv[optind]);
X
X	initvars();
X
X	parse();		/* call parser.. */
X
X	exit(1);
X}
X
X/*
X * initialise 
X */
Xinitvars()
X{
X	int i;
X
X	outp = 0;		/* output character pointer */
X	level = 0;		/* file control */
X	linect[0] = 1;		/* line count of first file */
X	fnamp = 0;
X	fnames[0] = EOS;
X	bp = -1;		/* pushback buffer pointer */
X	fordep = 0;		/* for stack */
X	swtop = 0;		/* switch stack index */
X	swlast = 1;		/* switch stack index */
X	for( i = 0; i <= 126; i++)
X		tabptr[i] = 0;
X	install(def, deftyp);	/* default definitions */
X	install(bdef, deftyp);
X	fcname[0] = EOS;	/* current function name */
X	label = startlab;	/* next generated label */
X}
X
X/*
X * P A R S E R
X */
X
Xparse()
X{
X	char lexstr[MAXTOK];
X	int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, i, token;
X
X	sp = 0;
X	lextyp[0] = EOF;
X	for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
X		if (token == LEXIF)
X			ifcode(&lab);
X		else if (token == LEXDO)
X			docode(&lab);
X		else if (token == LEXWHILE)
X			whilec(&lab);
X		else if (token == LEXFOR)
X			forcod(&lab);
X		else if (token == LEXREPEAT)
X			repcod(&lab);
X		else if (token == LEXSWITCH)
X			swcode(&lab);
X		else if (token == LEXCASE || token == LEXDEFAULT) {
X			for (i = sp; i >= 0; i--)
X				if (lextyp[i] == LEXSWITCH)
X					break;
X			if (i < 0)
X				synerr("illegal case of default.");
X			else
X				cascod(labval[i], token);
X		}
X		else if (token == LEXDIGITS)
X			labelc(lexstr);
X		else if (token == LEXELSE) {
X			if (lextyp[sp] == LEXIF)
X				elseif(labval[sp]);
X			else
X				synerr("illegal else.");
X		}
X		if (token == LEXIF || token == LEXELSE || token == LEXWHILE
X		    || token == LEXFOR || token == LEXREPEAT
X		    || token == LEXDO || token == LEXDIGITS 
X		    || token == LEXSWITCH || token == LBRACE) {
X			sp++;         /* beginning of statement */
X			if (sp > MAXSTACK)
X				baderr("stack overflow in parser.");
X			lextyp[sp] = token;     /* stack type and value */
X			labval[sp] = lab;
X		}
X		else if (token != LEXCASE && token != LEXDEFAULT) {
X			/* 
X		         * end of statement - prepare to unstack 
X			 */
X			if (token == RBRACE) {
X				if (lextyp[sp] == LBRACE)
X					sp--;
X				else if (lextyp[sp] == LEXSWITCH) {
X					swend(labval[sp]);
X					sp--;
X				}
X				else
X					synerr("illegal right brace.");
X			}
X			else if (token == LEXOTHER)
X				otherc(lexstr);
X			else if (token == LEXBREAK || token == LEXNEXT)
X				brknxt(sp, lextyp, labval, token);
X			else if (token == LEXRETURN)
X				retcod();
X		 	else if (token == LEXSTRING)
X				strdcl();
X			token = lex(lexstr);      /* peek at next token */
X			pbstr(lexstr);
X			unstak(&sp, lextyp, labval, token);
X		}
X	}
X	if (sp != 0)
X		synerr("unexpected EOF.");
X}
X
X/*
X * L E X I C A L  A N A L Y S E R
X */
X
X/*
X *  alldig - return YES if str is all digits
X *
X */
Xint
Xalldig(str)
Xchar str[];
X{
X	int i,j;
X
X	j = NO;
X	if (str[0] == EOS)
X		return(j);
X	for (i = 0; str[i] != EOS; i++)
X		if (type(str[i]) != DIGIT)
X			return(j);
X	j = YES;
X	return(j);
X}
X
X
X/*
X * balpar - copy balanced paren string
X *
X */
Xbalpar()
X{
X	char token[MAXTOK];
X	int t,nlpar;
X
X	if (gnbtok(token, MAXTOK) != LPAREN) {
X		synerr("missing left paren.");
X		return;
X	}
X	outstr(token);
X	nlpar = 1;
X	do {
X		t = gettok(token, MAXTOK);
X		if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
X			pbstr(token);
X			break;
X		}
X		if (t == NEWLINE)      /* delete newlines */
X			token[0] = EOS;
X		else if (t == LPAREN)
X			nlpar++;
X		else if (t == RPAREN)
X			nlpar--;
X		/* else nothing special */
X		outstr(token);
X	} 
X	while (nlpar > 0);
X	if (nlpar != 0)
X		synerr("missing parenthesis in condition.");
X}
X
X/*
X * deftok - get token; process macro calls and invocations
X *
X */
Xint
Xdeftok(token, toksiz, fd)
Xchar token[];
Xint toksiz;
XFILE *fd;
X{
X	char defn[MAXDEF];
X	int t;
X
X	for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
X		if (t != ALPHA)   /* non-alpha */
X			break;
X		if (look(token, defn) == NO)   /* undefined */
X			break;
X		if (defn[0] == DEFTYPE) {   /* get definition */
X			getdef(token, toksiz, defn, MAXDEF, fd);
X			install(token, defn);
X		}
X		else
X			pbstr(defn);   /* push replacement onto input */
X	}
X	if (t == ALPHA)   /* convert to single case */
X		fold(token);
X	return(t);
X}
X
X
X/*
X * eatup - process rest of statement; interpret continuations
X *
X */
Xeatup()
X{
X
X	char ptoken[MAXTOK], token[MAXTOK];
X	int nlpar, t;
X
X	nlpar = 0;
X	do {
X		t = gettok(token, MAXTOK);
X		if (t == SEMICOL || t == NEWLINE)
X			break;
X		if (t == RBRACE || t == LBRACE) {
X			pbstr(token);
X			break;
X		}
X		if (t == EOF) {
X			synerr("unexpected EOF.");
X			pbstr(token);
X			break;
X		}
X		if (t == COMMA || t == PLUS 
X			       || t == MINUS || t == STAR || t == LPAREN
X		               || t == AND || t == BAR || t == BANG
X			       || t == EQUALS || t == UNDERLINE ) {
X			while (gettok(ptoken, MAXTOK) == NEWLINE)
X				;
X			pbstr(ptoken);
X			if (t == UNDERLINE)
X				token[0] = EOS;
X		}
X		if (t == LPAREN)
X			nlpar++;
X		else if (t == RPAREN)
X			nlpar--;
X		outstr(token);
X
X	} while (nlpar >= 0);
X
X	if (nlpar != 0)
X		synerr("unbalanced parentheses.");
X}
X
X/*
X * getdef (for no arguments) - get name and definition
X *
X */
Xgetdef(token, toksiz, defn, defsiz, fd)
Xchar token[];
Xint toksiz;
Xchar defn[];
Xint defsiz;
XFILE *fd;
X{
X	int i, nlpar, t;
X	char c, ptoken[MAXTOK];
X
X	skpblk(fd);
X	/*
X	 * define(name,defn) or
X	 * define name defn
X	 *
X	 */
X	if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
X		t = BLANK;              /* define name defn */
X		pbstr(ptoken);
X	}
X	skpblk(fd);
X	if (gtok(token, toksiz, fd) != ALPHA)
X		baderr("non-alphanumeric name.");
X	skpblk(fd);
X	c = (char) gtok(ptoken, MAXTOK, fd);
X	if (t == BLANK) {         /* define name defn */
X		pbstr(ptoken);
X		i = 0;
X		do {
X			c = ngetch(&c, fd);
X			if (i > defsiz)
X				baderr("definition too long.");
X			defn[i++] = c;
X		} 
X		while (c != SHARP && c != NEWLINE && c != EOF);
X		if (c == SHARP)
X			putbak(c);
X	}
X	else if (t == LPAREN) {   /* define (name, defn) */
X		if (c != COMMA)
X			baderr("missing comma in define.");
X		/* else got (name, */
X		nlpar = 0;
X		for (i = 0; nlpar >= 0; i++)
X			if (i > defsiz)
X				baderr("definition too long.");
X			else if (ngetch(&defn[i], fd) == EOF)
X				baderr("missing right paren.");
X			else if (defn[i] == LPAREN)
X				nlpar++;
X			else if (defn[i] == RPAREN)
X				nlpar--;
X		/* else normal character in defn[i] */
X	}
X	else
X		baderr("getdef is confused.");
X	defn[i-1] = EOS;
X}
X
X/*
X * gettok - get token. handles file inclusion and line numbers
X *
X */
Xint
Xgettok(token, toksiz)
Xchar token[];
Xint toksiz;
X{
X	int t, i;
X	int tok;
X	char name[MAXNAME];
X
X	for ( ; level >= 0; level--) {
X		for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
X		     tok = deftok(token, toksiz, infile[level])) {
X			    if (equal(token, fncn) == YES) {
X				skpblk(infile[level]);
X				t = deftok(fcname, MAXNAME, infile[level]);
X				pbstr(fcname);
X				if (t != ALPHA)
X					synerr("missing function name.");
X				putbak(BLANK);
X				return(tok);
X			}
X			else if (equal(token, incl) == NO)
X				return(tok);
X			for (i = 0 ;; i = strlen(name)) {
X				t = deftok(&name[i], MAXNAME, infile[level]);
X				if (t == NEWLINE || t == SEMICOL) {
X					pbstr(&name[i]);
X					break;
X				}
X			}
X			name[i] = EOS;
X			if (name[1] == SQUOTE) {
X				outtab();
X				outstr(token);
X				outstr(name);
X				outdon();
X				eatup();
X				return(tok);
X			}
X			if (level >= NFILES)
X				synerr("includes nested too deeply.");
X			else {
X				infile[level+1] = fopen(name, "r");
X				linect[level+1] = 1;
X				if (infile[level+1] == NULL)
X					synerr("can't open include.");
X				else {
X					level++;
X					if (fnamp + i <= MAXFNAMES) {
X						scopy(name, 0, fnames, fnamp);
X						fnamp = fnamp + i;    /* push file name stack */
X					}
X				}
X			}
X		}
X		if (level > 0) {      /* close include and pop file name stack */
X			fclose(infile[level]);
X			for (fnamp--; fnamp > 0; fnamp--)
X				if (fnames[fnamp-1] == EOS)
X					break;
X		}
X	}
X	token[0] = EOF;   /* in case called more than once */
X	token[1] = EOS;
X	tok = EOF;
X	return(tok);
X}
X
X/*
X * gnbtok - get nonblank token
X *
X */
Xint
Xgnbtok(token, toksiz)
Xchar token[];
Xint toksiz;
X{
X	int tok;
X
X	skpblk(infile[level]);
X	tok = gettok(token, toksiz);
X	return(tok);
X}
X
X/*
X * gtok - get token for Ratfor
X *
X */
Xint
Xgtok(lexstr, toksiz, fd)
Xchar lexstr[];
Xint toksiz;
XFILE *fd;
X{
X	int i, b, n, tok; 
X	char c;
X	c = ngetch(&lexstr[0], fd);
X	if (c == BLANK || c == TAB) {
X		lexstr[0] = BLANK;
X		while (c == BLANK || c == TAB)    /* compress many blanks to one */
X			c = ngetch(&c, fd);
X		if (c == SHARP)
X			while (ngetch(&c, fd) != NEWLINE)   /* strip comments */
X				;
X		if (c != NEWLINE)
X			putbak(c);
X		else
X			lexstr[0] = NEWLINE;
X		lexstr[1] = EOS;
X		return((int)lexstr[0]);
X	}
X	i = 0;
X	tok = type(c);
X	if (tok == LETTER) {	/* alpha */
X		for (i = 0; i < toksiz - 3; i++) {
X			tok = type(ngetch(&lexstr[i+1], fd));
X			/* Test for DOLLAR added by BM, 7-15-80 */
X			if (tok != LETTER && tok != DIGIT 
X			    && tok != UNDERLINE && tok!=DOLLAR
X			    && tok != PERIOD)
X				break;
X		}
X		putbak(lexstr[i+1]);
X		tok = ALPHA;
X	}
X	else if (tok == DIGIT) {	/* digits */
X		b = c - DIG0;	/* in case alternate base number */
X		for (i = 0; i < toksiz - 3; i++) {
X			if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
X				break;
X			b = 10*b + lexstr[i+1] - DIG0;
X		}
X		if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {   
X			/* n%ddd... */
X			for (n = 0;; n = b*n + c - DIG0) {
X				c = ngetch(&lexstr[0], fd);
X				if (c >= LETA && c <= LETZ)
X					c = c - LETA + DIG9 + 1;
X				else if (c >= BIGA && c <= BIGZ)
X					c = c - BIGA + DIG9 + 1;
X				if (c < DIG0 || c >= DIG0 + b)
X					break;
X			}
X			putbak(lexstr[0]);
X			i = itoc(n, lexstr, toksiz);
X		}
X		else
X			putbak(lexstr[i+1]);
X		tok = DIGIT;
X	}
X#ifdef SQUAREB
X	else if (c == LBRACK) {   /* allow [ for { */
X		lexstr[0] = LBRACE;
X		tok = LBRACE;
X	}
X	else if (c == RBRACK) {   /* allow ] for } */
X		lexstr[0] = RBRACE;
X		tok = RBRACE;
X	}
X#endif
X	else if (c == SQUOTE || c == DQUOTE) {
X		for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
X			if (lexstr[i] == UNDERLINE)
X				if (ngetch(&c, fd) == NEWLINE) {
X					while (c == NEWLINE || c == BLANK || c == TAB)
X						c = ngetch(&c, fd);
X					lexstr[i] = c;
X				}
X				else
X					putbak(c);
X			if (lexstr[i] == NEWLINE || i >= toksiz-1) {
X				synerr("missing quote.");
X				lexstr[i] = lexstr[0];
X				putbak(NEWLINE);
X				break;
X			}
X		}
X	}
X	else if (c == SHARP) {   /* strip comments */
X		while (ngetch(&lexstr[0], fd) != NEWLINE)
X			;
X		tok = NEWLINE;
X	}
X	else if (c == GREATER || c == LESS || c == NOT 
X		 || c == BANG || c == CARET || c == EQUALS 
X		 || c == AND || c == OR)
X		i = relate(lexstr, fd);
X	if (i >= toksiz-1)
X		synerr("token too long.");
X	lexstr[i+1] = EOS;
X	if (lexstr[0] == NEWLINE)
X		linect[level] = linect[level] + 1;
X	return(tok);
X}
X
X/*
X * lex - return lexical type of token
X *
X */
Xint
Xlex(lexstr)
Xchar lexstr[];
X{
X
X	int tok;
X
X	for (tok = gnbtok(lexstr, MAXTOK);
X	     tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
X		    ;
X	if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
X		return(tok);
X	if (tok == DIGIT)
X		tok = LEXDIGITS;
X	else if (equal(lexstr, sif) == YES)
X		tok = vif[0];
X	else if (equal(lexstr, selse) == YES)
X		tok = velse[0];
X	else if (equal(lexstr, swhile) == YES)
X		tok = vwhile[0];
X	else if (equal(lexstr, sdo) == YES)
X		tok = vdo[0];
X	else if (equal(lexstr, sbreak) == YES)
X		tok = vbreak[0];
X	else if (equal(lexstr, snext) == YES)
X		tok = vnext[0];
X	else if (equal(lexstr, sfor) == YES)
X		tok = vfor[0];
X	else if (equal(lexstr, srept) == YES)
X		tok = vrept[0];
X	else if (equal(lexstr, suntil) == YES)
X		tok = vuntil[0];
X	else if (equal(lexstr, sswitch) == YES)
X		tok = vswitch[0];
X	else if (equal(lexstr, scase) == YES)
X		tok = vcase[0];
X	else if (equal(lexstr, sdefault) == YES)
X		tok = vdefault[0];
X	else if (equal(lexstr, sret) == YES)
X		tok = vret[0];
X	else if (equal(lexstr, sstr) == YES)
X		tok = vstr[0];
X	else
X		tok = LEXOTHER;
X	return(tok);
X}
X
X/*
X * ngetch - get a (possibly pushed back) character
X *
X */
Xchar
Xngetch(c, fd)
Xchar *c;
XFILE *fd;
X{
X
X	if (bp >= 0) {
X		*c = buf[bp];
X		bp--;
X	}
X	else
X		*c = (char) getc(fd);
X	
X	return(*c);
X}
X/*
X * pbstr - push string back onto input
X *
X */
Xpbstr(in)
Xchar in[];
X{
X	int i;
X
X	for (i = strlen(in) - 1; i >= 0; i--)
X		putbak(in[i]);
X}
X
X/*
X * putbak - push char back onto input
X *
X */
Xputbak(c)
Xchar c;
X{
X
X	bp++;
X	if (bp > BUFSIZE)
X		baderr("too many characters pushed back.");
X	buf[bp] = c;
X}
X
X
X/*
X * relate - convert relational shorthands into long form
X *
X */
Xint
Xrelate(token, fd)
Xchar token[];
XFILE *fd;
X{
X
X	if (ngetch(&token[1], fd) != EQUALS) {
X		putbak(token[1]);
X		token[2] = LETT;
X	}
X	else
X		token[2] = LETE;
X	token[3] = PERIOD;
X	token[4] = EOS;
X	token[5] = EOS;	/* for .not. and .and. */
X	if (token[0] == GREATER)
X		token[1] = LETG;
X	else if (token[0] == LESS)
X		token[1] = LETL;
X	else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
X		if (token[1] != EQUALS) {
X			token[2] = LETO;
X			token[3] = LETT;
X			token[4] = PERIOD;
X		}
X		token[1] = LETN;
X	}
X	else if (token[0] == EQUALS) {
X		if (token[1] != EQUALS) {
X			token[2] = EOS;
X			return(0);
X		}
X		token[1] = LETE;
X		token[2] = LETQ;
X	}
X	else if (token[0] == AND) {
X		token[1] = LETA;
X		token[2] = LETN;
X		token[3] = LETD;
X		token[4] = PERIOD;
X	}
X	else if (token[0] == OR) {
X		token[1] = LETO;
X		token[2] = LETR;
X	}
X	else   /* can't happen */
X		token[1] = EOS;
X	token[0] = PERIOD;
X	return(strlen(token)-1);
X}
X
X/*
X * skpblk - skip blanks and tabs in file  fd
X *
X */
Xskpblk(fd)
XFILE *fd;
X{
X	char c;
X
X	for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
X		;
X	putbak(c);
X}
X
X
X/* 
X * type - return LETTER, DIGIT or char; works with ascii alphabet
X *
X */
Xint
Xtype(c)
Xchar c;
X{
X	int t;
X
X	if (c >= DIG0 && c <= DIG9)
X		t = DIGIT;
X	else if (c >= LETA && c <= LETZ)
X		t = LETTER;
X	else if (c >= BIGA && c <= BIGZ)
X		t = LETTER;
X	else
X		t = c;
X	return(t);
X}
X
X/*
X * C O D E  G E N E R A T I O N 
X */
X
X/*
X * brknxt - generate code for break n and next n; n = 1 is default
X */
Xbrknxt(sp, lextyp, labval, token)
Xint sp;
Xint lextyp[];
Xint labval[];
Xint token;
X{
X	int i, n;
X	char t, ptoken[MAXTOK];
X
X	n = 0;
X	t = gnbtok(ptoken, MAXTOK);
X	if (alldig(ptoken) == YES) {     /* have break n or next n */
X		i = 0;
X		n = ctoi(ptoken, &i) - 1;
X	}
X	else if (t != SEMICOL)      /* default case */
X		pbstr(ptoken);
X	for (i = sp; i >= 0; i--)
X		if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
X		    || lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
X			if (n > 0) {
X				n--;
X				continue;             /* seek proper level */
X			}
X			else if (token == LEXBREAK)
X				outgo(labval[i]+1);
X			else
X				outgo(labval[i]);
X			xfer = YES;
X			return;
X		}
X	if (token == LEXBREAK)
X		synerr("illegal break.");
X	else
X		synerr("illegal next.");
X	return;
X}
X
X/*
X * docode - generate code for beginning of do
X *
X */
Xdocode(lab)
Xint *lab;
X{
X	xfer = NO;
X	outtab();
X	outstr(sdo);
X	*lab = labgen(2);
X	outnum(*lab);
X	eatup();
X	outdon();
X}
X
X/*
X * dostat - generate code for end of do statement
X *
X */
Xdostat(lab)
Xint lab;
X{
X	outcon(lab);
X	outcon(lab+1);
X}
X
X/*
X * elseif - generate code for end of if before else
X *
X */
Xelseif(lab)
Xint lab;
X{
X
X	outgo(lab+1);
X	outcon(lab);
X}
X
X/*
X * forcod - beginning of for statement
X *
X */
Xforcod(lab)
Xint *lab;
X{
X	char t, token[MAXTOK];
X	int i, j, nlpar,tlab;
X
X	tlab = *lab;
X	tlab = labgen(3);
X	outcon(0);
X	if (gnbtok(token, MAXTOK) != LPAREN) {
X		synerr("missing left paren.");
X		return;
X	}
X	if (gnbtok(token, MAXTOK) != SEMICOL) {   /* real init clause */
X		pbstr(token);
X		outtab();
X		eatup();
X		outdon();
X	}
X	if (gnbtok(token, MAXTOK) == SEMICOL)   /* empty condition */
X		outcon(tlab);
X	else {   /* non-empty condition */
X		pbstr(token);
X		outnum(tlab);
X		outtab();
X		outstr(ifnot);
X		outch(LPAREN);
X		nlpar = 0;
X		while (nlpar >= 0) {
X			t = gettok(token, MAXTOK);
X			if (t == SEMICOL)
X				break;
X			if (t == LPAREN)
X				nlpar++;
X			else if (t == RPAREN)
X				nlpar--;
X			if (t == EOF) {
X				pbstr(token);
X				return;
X			}
X			if (t != NEWLINE && t != UNDERLINE)
X				outstr(token);
X		}
X		outch(RPAREN);
X		outch(RPAREN);
X		outgo((tlab)+2);
X		if (nlpar < 0)
X			synerr("invalid for clause.");
X	}
X	fordep++;		/* stack reinit clause */
X	j = 0;
X	for (i = 1; i < fordep; i++)   /* find end *** should i = 1 ??? *** */
X		j = j + strlen(&forstk[j]) + 1;
X	forstk[j] = EOS;   /* null, in case no reinit */
X	nlpar = 0;
X	t = gnbtok(token, MAXTOK);
X	pbstr(token);
X	while (nlpar >= 0) {
X		t = gettok(token, MAXTOK);
X		if (t == LPAREN)
X			nlpar++;
X		else if (t == RPAREN)
X			nlpar--;
X		if (t == EOF) {
X			pbstr(token);
X			break;
X		}
X		if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
X			if (j + strlen(token) >= MAXFORSTK)
X				baderr("for clause too long.");
X			scopy(token, 0, forstk, j);
X			j = j + strlen(token);
X		}
X	}
X	tlab++;   /* label for next's */
X	*lab = tlab;
X}
X
X/*
X * fors - process end of for statement
X *
X */
Xfors(lab)
Xint lab;
X{
X	int i, j;
X
X	xfer = NO;
X	outnum(lab);
X	j = 0;
X	for (i = 1; i < fordep; i++)
X		j = j + strlen(&forstk[j]) + 1;
X	if (strlen(&forstk[j]) > 0) {
X		outtab();
X		outstr(&forstk[j]);
X		outdon();
X	}
X	outgo(lab-1);
X	outcon(lab+1);
X	fordep--;
X}
X
X/*
X * ifcode - generate initial code for if
X *
X */
Xifcode(lab)
Xint *lab;
X{
X
X	xfer = NO;
X	*lab = labgen(2);
X	ifgo(*lab);
X}
X
X/*
X * ifgo - generate "if(.not.(...))goto lab"
X *
X */
Xifgo(lab)
Xint lab;
X{
X
X	outtab();      /* get to column 7 */
X	outstr(ifnot);      /* " if(.not. " */
X	balpar();      /* collect and output condition */
X	outch(RPAREN);      /* " ) " */
X	outgo(lab);         /* " goto lab " */
X}
X
X
X/*
X * labelc - output statement number
X *
X */
Xlabelc(lexstr)
Xchar lexstr[];
X{
X
X	xfer = NO;   /* can't suppress goto's now */
X	if (strlen(lexstr) == 5)   /* warn about 23xxx labels */
X		if (atoi(lexstr) >= startlab)
X			synerr("warning: possible label conflict.");
X	outstr(lexstr);
X	outtab();
X}
X
X/*
X * labgen - generate  n  consecutive labels, return first one
X *
X */
Xint
Xlabgen(n)
Xint n;
X{
X	int i;
X
X	i = label;
X	label = label + n;
X	return(i);
X}
X
X/*
X * otherc - output ordinary Fortran statement
X *
X */
Xotherc(lexstr)
Xchar lexstr[];
X{
X	xfer = NO;
X	outtab();
X	outstr(lexstr);
X	eatup();
X	outdon();
X}
X
X/*
X * outch - put one char into output buffer
X *
X */
Xoutch(c)
Xchar c;
X{
X	int i;
X
X	if (outp >= 72) {   /* continuation card */
X		outdon();
X		/*** should output "-" for dcl continuation.. ***/
X		for (i = 0; i < 6; i++)
X			outbuf[i] = BLANK;
X		outp = 6;
X	}
X	outbuf[outp] = c;
X	outp++;
X}
X
X/*
X * outcon - output "n   continue"
X *
X */
Xoutcon(n)
Xint n;
X{
X	xfer = NO;
X	if (n <= 0 && outp == 0)
X		return;            /* don't need unlabeled continues */
X	if (n > 0)
X		outnum(n);
X	outtab();
X	outstr(contin);
X	outdon();
X}
X
X/*
X * outdon - finish off an output line
X *
X */
Xoutdon()
X{
X
X	outbuf[outp] = NEWLINE;
X	outbuf[outp+1] = EOS;
X	printf(outbuf);
X	outp = 0;
X}
X
X/*
X * outgo - output "goto  n"
X *
X */
Xoutgo(n)
Xint n;
X{
X	if (xfer == YES)
X		return;
X	outtab();
X	outstr(rgoto);
X	outnum(n);
X	outdon();
X}
X
X/*
X * outnum - output decimal number
X *
X */
Xoutnum(n)
Xint n;
X{
X
X	char chars[MAXCHARS];
X	int i, m;
X
X	m = abs(n);
X	i = -1;
X	do {
X		i++;
X		chars[i] = (m % 10) + DIG0;
X		m = m / 10;
X	} 
X	while (m > 0 && i < MAXCHARS);
X	if (n < 0)
X		outch(MINUS);
X	for ( ; i >= 0; i--)
X		outch(chars[i]);
X}
X
X
X 
X/*
X * outstr - output string
X *
X */
Xoutstr(str)
Xchar str[];
X{
X	int i;
X
X	for (i=0; str[i] != EOS; i++)
X		outch(str[i]);
X}
X
X/*
X * outtab - get past column 6
X *
X */
Xouttab()
X{
X	while (outp < 6)
X		outch(BLANK);
X}
X
X
X/*
X * repcod - generate code for beginning of repeat
X *
X */
Xrepcod(lab)
Xint *lab;
X{
X
X	int tlab;
X
X	tlab = *lab;
X	outcon(0);   /* in case there was a label */
X	tlab = labgen(3);
X	outcon(tlab);
X	*lab = ++tlab;		/* label to go on next's */
X}
X
X/*
X * retcod - generate code for return
X *
X */
Xretcod()
X{
X	char token[MAXTOK], t;
X
X	t = gnbtok(token, MAXTOK);
X	if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
X		pbstr(token);
X		outtab();
X		outstr(fcname);
X		outch(EQUALS);
X		eatup();
X		outdon();
X	}
X	else if (t == RBRACE)
X		pbstr(token);
X	outtab();
X	outstr(sret);
X	outdon();
X	xfer = YES;
X}
X
X
X/* strdcl - generate code for string declaration */
Xstrdcl()
X{
X	char t, name[MAXNAME], init[MAXTOK];
X	int i, len;
X
X	t = gnbtok(name, MAXNAME);
X	if (t != ALPHA)
X		synerr("missing string name.");
X	if (gnbtok(init, MAXTOK) != LPAREN) {  /* make size same as initial value */
X		len = strlen(init) + 1;
X		if (init[1] == SQUOTE || init[1] == DQUOTE)
X			len = len - 2;
X	}
X	else {	/* form is string name(size) init */
X		t = gnbtok(init, MAXTOK);
X		i = 0;
X		len = ctoi(init, &i);
X		if (init[i] != EOS)
X			synerr("invalid string size.");
X		if (gnbtok(init, MAXTOK) != RPAREN)
X			synerr("missing right paren.");
X		else
X			t = gnbtok(init, MAXTOK);
X	}
X	outtab();
X	/*
X	*   outstr(int);
X	*/
X	outstr(name);
X	outch(LPAREN);
X	outnum(len);
X	outch(RPAREN);
X	outdon();
X	outtab();
X	outstr(dat);
X	len = strlen(init) + 1;
X	if (init[0] == SQUOTE || init[0] == DQUOTE) {
X		init[len-1] = EOS;
X		scopy(init, 1, init, 0);
X		len = len - 2;
X	}
X	for (i = 1; i <= len; i++) {	/* put out variable names */
X		outstr(name);
X		outch(LPAREN);
X		outnum(i);
X		outch(RPAREN);
X		if (i < len)
X			outch(COMMA);
X		else
X			outch(SLASH);
X		;
X	}
X	for (i = 0; init[i] != EOS; i++) {	/* put out init */
X		outnum(init[i]);
X		outch(COMMA);
X	}
X	pbstr(eoss);	/* push back EOS for subsequent substitution */
X}
X
X
X/*
X * unstak - unstack at end of statement
X *
X */
Xunstak(sp, lextyp, labval, token)
Xint *sp;
Xint lextyp[];
Xint labval[];
Xchar token;
X{
X	int tp;
X
X	tp = *sp;
X	for ( ; tp > 0; tp--) {
X		if (lextyp[tp] == LBRACE)
X			break;
X		if (lextyp[tp] == LEXSWITCH)
X			break;
X		if (lextyp[tp] == LEXIF && token == LEXELSE)
X			break;
X		if (lextyp[tp] == LEXIF)
X			outcon(labval[tp]);
X		else if (lextyp[tp] == LEXELSE) {
X			if (*sp > 1)
X				tp--;
X			outcon(labval[tp]+1);
X		}
X		else if (lextyp[tp] == LEXDO)
X			dostat(labval[tp]);
X		else if (lextyp[tp] == LEXWHILE)
X			whiles(labval[tp]);
X		else if (lextyp[tp] == LEXFOR)
X			fors(labval[tp]);
X		else if (lextyp[tp] == LEXREPEAT)
X			untils(labval[tp], token);
X	}
X	*sp = tp;
X}
X
X/*
X * untils - generate code for until or end of repeat
X *
X */
Xuntils(lab, token)
Xint lab;
Xint token;
X{
X	char ptoken[MAXTOK];
X
X	xfer = NO;
X	outnum(lab);
X	if (token == LEXUNTIL) {
X		lex(ptoken);
X		ifgo(lab-1);
X	}
X	else
X		outgo(lab-1);
X	outcon(lab+1);
X}
X
X/* 
X * whilec - generate code for beginning of while 
X *
X */
Xwhilec(lab)
Xint *lab;
X{
X	int tlab;
X
X	tlab = *lab;
X	outcon(0);         /* unlabeled continue, in case there was a label */
X	tlab = labgen(2);
X	outnum(tlab);
X	ifgo(tlab+1);
X	*lab = tlab;
X}
X
X/* 
X * whiles - generate code for end of while 
X *
X */
Xwhiles(lab)
Xint lab;
X{
X
X	outgo(lab);
X	outcon(lab+1);
X}
X
X/*
X * E R R O R  M E S S A G E S 
X */
X
X/*
X *  baderr - print error message, then die
X */
Xbaderr(msg)
Xchar msg[];
X{
X	synerr(msg);
X	exit(1);
X}
X
X/*
X * error - print error message with one parameter, then die
X */
Xerror(msg, s)
Xchar *msg, *s;
X{
X	fprintf(stderr, msg,s);
X	exit(1);
X}
X
X/* 
X * synerr - report Ratfor syntax error
X */
Xsynerr(msg)
Xchar *msg;
X{
X	char lc[MAXCHARS];
X	int i;
X
X	fprintf(stderr,errmsg);
X	if (level >= 0)
X		i = level;
X	else
X		i = 0;   /* for EOF errors */
X	itoc(linect[i], lc, MAXCHARS);
X	fprintf(stderr,lc);
X	for (i = fnamp - 1; i > 1; i = i - 1)
X		if (fnames[i-1] == EOS) {   /* print file name */
X			fprintf(stderr,in);
X			fprintf(stderr,fnames[i]);
X			break;
X		}
X	fprintf(stderr,": \n      %s\n",msg);
X}
X
X
X/*
X * U T I L I T Y  R O U T I N E S
X */
X
X/*
X * ctoi - convert string at in[i] to int, increment i
X */
Xint
Xctoi(in, i)
Xchar in[];
Xint *i;
X{
X	int k, j;
X
X	j = *i;
X	while (in[j] == BLANK || in[j] == TAB)
X		j++;
X	for (k = 0; in[j] != EOS; j++) {
X		if (in[j] < DIG0 || in[j] > DIG9)
X			break;
X		k = 10 * k + in[j] - DIG0;
X	}
X	*i = j;
X	return(k);
X}
X
X/*
X * fold - convert alphabetic token to single case
X *
X */
Xfold(token)
Xchar token[];
X{
X
X	int i;
X
X	/* WARNING - this routine depends heavily on the */
X	/* fact that letters have been mapped into internal */
X	/* right-adjusted ascii. god help you if you */
X	/* have subverted this mechanism. */
X
X	for (i = 0; token[i] != EOS; i++)
X		if (token[i] >= BIGA && token[i] <= BIGZ)
X			token[i] = token[i] - BIGA + LETA;
X}
X
X/*
X * equal - compare str1 to str2; return YES if equal, NO if not
X *
X */
Xint
Xequal(str1, str2)
Xchar str1[];
Xchar str2[];
X{
X	int i;
X
X	for (i = 0; str1[i] == str2[i]; i++)
X		if (str1[i] == EOS)
X			return(YES);
X	return(NO);
X}
X
X/*
X * scopy - copy string at from[i] to to[j]
X *
X */
Xscopy(from, i, to, j)
Xchar from[];
Xint i;
Xchar to[];
Xint j;
X{
X	int k1, k2;
X
X	k2 = j;
X	for (k1 = i; from[k1] != EOS; k1++) {
X		to[k2] = from[k1];
X		k2++;
X	}
X	to[k2] = EOS;
X}
X
X#include "lookup.h"
X/*
X * look - look-up a definition
X *
X */
Xint
Xlook(name,defn)
Xchar name[];
Xchar defn[];
X{
X	extern struct hashlist *lookup();
X	struct hashlist *p;
X
X	if ((p = lookup(name)) == NULL)
X		return(NO);
X	(void) strcpy(defn,p->def);
X	return(YES);
X}
X
X/*
X * itoc - special version of itoa
X */
Xint
Xitoc(n,str,size)
Xint n;
Xchar str[];
Xint size;
X{
X	int i,j,k,sign;
X	char c;
X
X	if ((sign = n) < 0)
X		n = -n;
X	i = 0;
X	do {
X		str[i++] = n % 10 + '0'; 
X	} 
X	while ((n /= 10) > 0 && i < size-2);
X	if (sign < 0 && i < size-1)
X		str[i++] = '-';
X	str[i] = EOS;
X	/*
X	 * reverse the string and plug it back in
X	 */
X	for (j = 0, k = strlen(str) - 1; j < k; j++, k--) {
X		c = str[j];
X		str[j] = str[k];
X		str[k] = c;
X	}
X	return(i-1);
X}
X
X/*
X * cascod - generate code for case or default label
X *
X */
Xcascod (lab, token)
Xint lab;
Xint token;
X{
X	int t, l, lb, ub, i, j, junk;
X	char scrtok[MAXTOK];
X
X	if (swtop <= 0) {
X		synerr ("illegal case or default.");
X		return;
X	}
X	outgo(lab + 1);		/* # terminate previous case */
X	xfer = YES;
X	l = labgen(1);
X	if (token == LEXCASE) { 	/* # case n[,n]... : ... */
X		while (caslab (&lb, &t) != EOF) {
X			ub = lb;
X			if (t == MINUS)
X				junk = caslab (&ub, &t);
X			if (lb > ub) {
X				synerr ("illegal range in case label.");
X				ub = lb;
X			}
X			if (swlast + 3 > MAXSWITCH)
X				baderr ("switch table overflow.");
X			for (i = swtop + 3; i < swlast; i = i + 3)
X				if (lb <= swstak[i])
X					break;
X				else if (lb <= swstak[i+1])
X					synerr ("duplicate case label.");
X			if (i < swlast & ub >= swstak[i])
X				synerr ("duplicate case label.");
X			for (j = swlast; j > i; j--)   	/* # insert new entry */
X				swstak[j+2] = swstak[j-1];
X			swstak[i] = lb;
X			swstak[i + 1] = ub;
X			swstak[i + 2] = l;
X			swstak[swtop + 1] = swstak[swtop + 1]  +  1;
X			swlast = swlast + 3;
X			if (t == COLON)
X				break;
X			else if (t != COMMA)
X				synerr ("illegal case syntax.");
X		}
X	}
X	else {   					/* # default : ... */
X		t = gnbtok (scrtok, MAXTOK);
X		if (swstak[swtop + 2] != 0)
X			baderr ("multiple defaults in switch statement.");
X		else
X			swstak[swtop + 2] = l;
X	}
X
X	if (t == EOF)
X		synerr ("unexpected EOF.");
X	else if (t != COLON)
X		baderr ("missing colon in case or default label.");
X
X	xfer = NO;
X	outcon (l);
X}
X
X/*
X * caslab - get one case label
X *
X */
Xint
Xcaslab (n, t)
Xint *n; 
Xint *t;
X{
X	char tok[MAXTOK];
X	int i, s;
X
X	*t = gnbtok (tok, MAXTOK);
X	while (*t == NEWLINE)
X		*t = gnbtok (tok, MAXTOK);
X	if (*t == EOF)
X		return (*t);
X	if (*t == MINUS)
X		s = -1;
X	else
X		s = 1;
X	if (*t == MINUS || *t == PLUS)
X		*t = gnbtok (tok, MAXTOK);
X	if (*t != DIGIT) {
X		synerr ("invalid case label.");
X		*n = 0;
X	}
X	else {
X		i = 0;
X		*n = s * ctoi (tok, &i);
X	}
X	*t = gnbtok (tok, MAXTOK);
X	while (*t == NEWLINE)
X		*t = gnbtok (tok, MAXTOK);
X}
X
X/*
X * swcode - generate code for switch stmt.
X *
X */
Xswcode (lab)
Xint *lab;
X{
X	char scrtok[MAXTOK];
X
X	*lab = labgen (2);
X	if (swlast + 3 > MAXSWITCH)
X		baderr ("switch table overflow.");
X	swstak[swlast] = swtop;
X	swstak[swlast + 1] = 0;
X	swstak[swlast + 2] = 0;
X	swtop = swlast;
X	swlast = swlast + 3;
X	xfer = NO;
X	outtab();  	/* # Innn=(e) */
X	swvar(*lab);
X	outch(EQUALS);
X	balpar();
X	outdon();
X	outgo(*lab); 	/* # goto L */
X	xfer = YES;
X	while (gnbtok (scrtok, MAXTOK) == NEWLINE)
X		;
X	if (scrtok[0] != LBRACE) {
X		synerr ("missing left brace in switch statement.");
X		pbstr (scrtok);
X	}
X}
X
X/*
X * swend  - finish off switch statement; generate dispatch code
X *
X */
Xswend(lab)
Xint lab;
X{
X	int lb, ub, n, i, j;
X
Xstatic	char *sif   	= "if (";
Xstatic	char *slt   	= ".lt.1.or.";
Xstatic	char *sgt   	= ".gt.";
Xstatic	char *sgoto 	= "goto (";
Xstatic	char *seq   	= ".eq.";
Xstatic	char *sge   	= ".ge.";
Xstatic	char *sle   	= ".le.";
Xstatic	char *sand  	= ".and.";
X
X	lb = swstak[swtop + 3];
X	ub = swstak[swlast - 2];
X	n = swstak[swtop + 1];
X	outgo(lab + 1); 			/* # terminate last case */
X	if (swstak[swtop + 2] == 0)
X		swstak[swtop + 2] = lab + 1;	/* # default default label */
X	xfer = NO;
X	outcon (lab);  			/*  L   continue */
X	/* output branch table */
X	if (n >= CUTOFF & ub - lb < DENSITY * n) {  
X		if (lb != 0) {  		  /* L  Innn=Innn-lb */
X			outtab();
X			swvar  (lab);
X			outch (EQUALS);
X			swvar  (lab);
X			if (lb < 0)
X				outch (PLUS);
X			outnum (-lb + 1);
X			outdon();
X		}
X		outtab();  /*  if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default */
X		outstr (sif);
X		swvar  (lab);
X		outstr (slt);
X		swvar  (lab);
X		outstr (sgt);
X		outnum (ub - lb + 1);
X		outch (RPAREN);
X		outgo (swstak[swtop + 2]);
X		outtab();
X		outstr (sgoto);		/* goto ... */
X		j = lb;
X		for (i = swtop + 3; i < swlast; i = i + 3) {
X			/* # fill in vacancies */
X			for ( ; j < swstak[i]; j++) {
X				outnum(swstak[swtop + 2]);
X				outch(COMMA);
X			}
X			for (j = swstak[i + 1] - swstak[i]; j >= 0; j--)
X				outnum(swstak[i + 2]);	/* # fill in range */
X			j = swstak[i + 1] + 1;
X			if (i < swlast - 3) 
X				outch(COMMA);
X		}
X		outch(RPAREN);
X		outch(COMMA);
X		swvar(lab);
X		outdon();
X	}
X	else if (n > 0) { 		/* # output linear search form */
X		for (i = swtop + 3; i < swlast; i = i + 3) {
X			outtab();		/* # if (Innn */
X			outstr (sif);
X			swvar  (lab);
X			if (swstak[i] == swstak[i+1]) {
X				outstr (seq); 	/* #   .eq....*/
X				outnum (swstak[i]);
X			}
X			else {
X				outstr (sge);	/* #   .ge.lb.and.Innn.le.ub */
X				outnum (swstak[i]);
X				outstr (sand);
X				swvar  (lab);
X				outstr (sle);
X				outnum (swstak[i + 1]);
X			}
X			outch (RPAREN);		/* #    ) goto ... */
X			outgo (swstak[i + 2]);
X		}
X		if (lab + 1 != swstak[swtop + 2])
X			outgo (swstak[swtop + 2]);
X	}
X	outcon (lab + 1);   			/* # L+1  continue */
X	swlast = swtop;				/* # pop switch stack */
X	swtop = swstak[swtop];
X}
X
X/*
X * swvar  - output switch variable Innn, where nnn = lab
X */
Xswvar  (lab)
Xint lab;
X{
X
X	outch ('I');
X	outnum (lab);
X}
SHAR_EOF
if test 33223 -ne "`wc -c 'ratfor.c'`"
then
	echo shar: error transmitting "'ratfor.c'" '(should have been 33223 characters)'
fi
chmod +x 'ratfor.c'
echo shar: extracting "'lookup.c'" '(1397 characters)'
if test -f 'lookup.c'
then
	echo shar: over-writing existing file "'lookup.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'lookup.c'
X#include <stdio.h>
X#include "lookup.h"
X
Xstatic 
Xstruct	hashlist *hashtab[HASHMAX];
X
X/*
X * from K&R "The C Programming language"
X * Table lookup routines
X *
X * hash - for a hash value for string s
X *
X */
Xhash(s)
Xchar *s;
X{
X	int	hashval;
X
X	for (hashval = 0; *s != '\0';)
X		hashval += *s++;
X	return (hashval % HASHMAX);
X}
X
X/*
X * lookup - lookup for a string s in the hash table
X *
X */
Xstruct hashlist
X*lookup(s)
Xchar *s;
X{
X	struct hashlist *np;
X
X	for (np = hashtab[hash(s)]; np != NULL; np = np->next)
X		if (strcmp(s, np->name) == 0)
X			return(np);	/* found     */
X	return(NULL);		/* not found */
X}
X
X/*
X * install - install a string name in hashtable and its value def
X *
X */
Xstruct hashlist
X*install(name,def)
Xchar *name;
Xchar *def;
X{
X	int hashval;
X	struct hashlist *np, *lookup();
X	char *strsave(), *malloc();
X
X	if ((np = lookup(name)) == NULL) {	/* not found.. */
X		np = (struct hashlist *) malloc(sizeof(*np));
X		if (np == NULL)
X			return(NULL);
X		if ((np->name = strsave(name)) == NULL)
X			return(NULL);
X		hashval = hash(np->name);
X		np->next = hashtab[hashval];
X		hashtab[hashval] = np;
X	} else					/* found..     */
X		free(np->def);			/* free prev.  */
X	if ((np->def = strsave(def)) == NULL)
X		return(NULL);
X	return(np);
X}
X
X/*
X * strsave - save string s somewhere
X *
X */
Xchar
X*strsave(s)
Xchar *s;
X{
X	char *p, *malloc();
X
X	if ((p = malloc(strlen(s)+1)) != NULL)
X		strcpy(p, s);
X	return(p);
X}
X
X
SHAR_EOF
if test 1397 -ne "`wc -c 'lookup.c'`"
then
	echo shar: error transmitting "'lookup.c'" '(should have been 1397 characters)'
fi
chmod +x 'lookup.c'
echo shar: extracting "'lookup.h'" '(309 characters)'
if test -f 'lookup.h'
then
	echo shar: over-writing existing file "'lookup.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'lookup.h'
X
X/*
X * from K&R "The C Programming language"
X * Table lookup routines 
X * structure and definitions
X *
X */
X
X					/* basic table entry */
Xstruct hashlist {
X	char	*name;
X	char	*def;
X	struct	hashlist *next;		/* next in chain     */
X};
X
X#define HASHMAX	100			/* size of hashtable */
X
X					/* hash table itself */
SHAR_EOF
if test 309 -ne "`wc -c 'lookup.h'`"
then
	echo shar: error transmitting "'lookup.h'" '(should have been 309 characters)'
fi
chmod +x 'lookup.h'
echo shar: extracting "'ratdef.h'" '(3579 characters)'
if test -f 'ratdef.h'
then
	echo shar: over-writing existing file "'ratdef.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'ratdef.h'
X#define ACCENT  96
X#define AND     38
X#define APPEND
X#define ATSIGN  64
X#define BACKSLASH       92
X#define BACKSPACE       8
X#define BANG    33
X#define BAR     124
X#define BIGA    65
X#define BIGB    66
X#define BIGC    67
X#define BIGD    68
X#define BIGE    69
X#define BIGF    70
X#define BIGG    71
X#define BIGH    72
X#define BIGI    73
X#define BIGJ    74
X#define BIGK    75
X#define BIGL    76
X#define BIGM    77
X#define BIGN    78
X#define BIGO    79
X#define BIGP    80
X#define BIGQ    81
X#define BIGR    82
X#define BIGS    83
X#define BIGT    84
X#define BIGU    85
X#define BIGV    86
X#define BIGW    87
X#define BIGX    88
X#define BIGY    89
X#define BIGZ    90
X#define BLANK   32
X#define CARET   94
X#define COLON   58
X#define COMMA   44
X#define CRLF    13
X#define DIG0    48
X#define DIG1    49
X#define DIG2    50
X#define DIG3    51
X#define DIG4    52
X#define DIG5    53
X#define DIG6    54
X#define DIG7    55
X#define DIG8    56
X#define DIG9    57
X#define DOLLAR  36
X#define DQUOTE  34
X#define EOS     0
X#define EQUALS  61
X#define ESCAPE  ATSIGN
X#define GREATER 62
X#define HUGE    30000
X#define LBRACE  123
X#define LBRACK  91
X#define LESS    60
X#define LETA    97
X#define LETB    98
X#define LETC    99
X#define LETD    100
X#define LETE    101
X#define LETF    102
X#define LETG    103
X#define LETH    104
X#define LETI    105
X#define LETJ    106
X#define LETK    107
X#define LETL    108
X#define LETM    109
X#define LETN    110
X#define LETO    111
X#define LETP    112
X#define LETQ    113
X#define LETR    114
X#define LETS    115
X#define LETT    116
X#define LETU    117
X#define LETV    118
X#define LETW    119
X#define LETX    120
X#define LETY    121
X#define LETZ    122
X#define LPAREN  40
X#define MINUS   45
X#define NEWLINE 10
X#define NO      0
X#define NOT     126
X#define OR      BAR	/* same as | */
X#define PERCENT 37
X#define PERIOD  46
X#define PLUS    43
X#define QMARK   63
X#define RBRACE  125
X#define RBRACK  93
X#define RPAREN  41
X#define SEMICOL 59
X#define SHARP   35
X#define SLASH   47
X#define SQUOTE  39
X#define STAR    42
X#define TAB     9
X#define TILDE   126
X#define UNDERLINE       95
X#define YES     1
X      
X#define LIMIT   134217728
X#define LIM1    28
X#define LIM2    -28
X
X/*
X * lexical analyser symbols
X *
X */
X
X#define LETTER		1
X#define DIGIT   	2
X#define ALPHA   	3
X#define LEXBREAK   	4
X#define LEXDIGITS   	5
X#define LEXDO   	6
X#define LEXELSE   	7
X#define LEXFOR   	8
X#define LEXIF   	9
X#define LEXNEXT   	10
X#define LEXOTHER   	11
X#define LEXREPEAT   	12
X#define LEXUNTIL   	13
X#define LEXWHILE   	14
X#define LEXRETURN   	15
X#define LEXEND   	16
X#define LEXSTOP   	17
X#define LEXSTRING   	18
X#define LEXSWITCH	19
X#define LEXCASE		20
X#define LEXDEFAULT	21
X#define DEFTYPE   	22
X
X#define MAXCHARS   	10   	/* characters for outnum */
X#define MAXDEF   	200   	/* max chars in a defn */
X#define MAXSWITCH       300     /* max stack for switch statement */
X#define CUTOFF          3       /* min number of cases necessary to generate */
X                                /* a dispatch table */
X#define DENSITY         2
X#define MAXFORSTK   	200   	/* max space for for reinit clauses */
X#define MAXFNAMES   	350  	/* max chars in filename stack NFILES*MAXNAME */
X#define MAXNAME   	64   	/* file name size in gettok */
X#define MAXSTACK   	100   	/* max stack depth for parser */
X#define MAXTBL   	15000   /* max chars in all definitions */
X#define MAXTOK   	132   	/* max chars in a token */
X#define NFILES   	7   	/* max depth of file inclusion */
X
X#define RADIX   	PERCENT /* % indicates alternate radix */
X#define BUFSIZE   	300   	/* pushback buffer for ngetch and putbak */
X
SHAR_EOF
if test 3579 -ne "`wc -c 'ratdef.h'`"
then
	echo shar: error transmitting "'ratdef.h'" '(should have been 3579 characters)'
fi
chmod +x 'ratdef.h'
echo shar: extracting "'ratcom.h'" '(1206 characters)'
if test -f 'ratcom.h'
then
	echo shar: over-writing existing file "'ratcom.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'ratcom.h'
Xint bp;			/*   next available char; init = 0 */
Xchar buf[BUFSIZE];	/*   pushed-back chars */
Xchar fcname[MAXNAME];	/*   text of current function name */
Xint fordep;		/*   current depth of for statements */
Xchar forstk[MAXFORSTK];	/*   stack of reinit strings */
Xint swtop;		/*   current switch entry; init=0              */
Xint swlast;		/*   next available position; init=1           */
Xint swstak[MAXSWITCH];	/*   switch information stack                  */
Xint xfer;		/*   YES if just made transfer, NO otherwise */
Xint label;		/*   next label returned by labgen */
Xint level ;		/*   level of file inclusion; init = 1 */
Xint linect[NFILES];	/*   line count on input file[level]; init = 1 */
XFILE *infile[NFILES];	/*   file number[level]; init infile[1] = STDIN */
Xint fnamp;		/*   next free slot in fnames; init = 2 */
Xchar fnames[MAXFNAMES];	/*   stack of include names; init fnames[1] = EOS */
Xint avail;		/*   first first location in table; init = 1 */
Xint tabptr[127];	/*   name pointers; init = 0 */
Xint outp;		/*   last position filled in outbuf; init = 0 */
Xchar outbuf[74];	/*   output lines collected here */
Xchar fname[MAXNAME][NFILES];	/*   file names */
Xint nfiles;		/*   number of files */
SHAR_EOF
if test 1206 -ne "`wc -c 'ratcom.h'`"
then
	echo shar: error transmitting "'ratcom.h'" '(should have been 1206 characters)'
fi
chmod +x 'ratcom.h'
echo shar: extracting "'makefile'" '(151 characters)'
if test -f 'makefile'
then
	echo shar: over-writing existing file "'makefile'"
fi
sed 's/^X//' << \SHAR_EOF > 'makefile'
XCFLAGS = -O
X
Xratfor: ratfor.o lookup.o
X	cc -o ratfor ratfor.o lookup.o 
X
Xratfor.o: ratdef.h ratcom.h
Xlookup.o: lookup.h
X
Xclean:
X	rm -f *.o core ratfor
SHAR_EOF
if test 151 -ne "`wc -c 'makefile'`"
then
	echo shar: error transmitting "'makefile'" '(should have been 151 characters)'
fi
chmod +x 'makefile'
#	End of shell archive
exit 0

jeff@gatech.CSNET (Jeff Lee) (07/08/85)

> I have done just about as much as I can with ratfor in C. I do not
> have time to maintain or bugfix it. Thus, It is up to the rest of
> the netpeople to continue with it. However, I would appreciate receiving 
> all the updates, fixes etc. One important point: Please avoid
> the temptation of re-writing the parser and lexical analyser in
> YACC and LEX, or any other such generators, unless they are in PUBLIC
> domain. This version of ratfor should be usable and modifiable by those
> who do not have YACC or LEX. (BTW: Where is GNU YACC ??? I am eagerly
> awaiting!!)

There is supposedly a public domain version of YACC and LEX that is written
in RATFOR and distributed with the current version of the TOOLS. Does anyone
have this that could possibly post it? If it ever got posted then it probably
would not be long until a public domain C version would appear.

Just an idea...
-- 
Jeff Lee
CSNet:	Jeff @ GATech		ARPA:	Jeff%GATech.CSNet @ CSNet-Relay.ARPA
uucp:	...!{akgua,allegra,hplabs,ihnp4,linus,seismo,ulysses}!gatech!jeff