#!/bin/sh
# This is a shell archive (produced by GNU sharutils 4.1).
# To extract the files from this archive, save it to some FILE, remove
# everything before the `!/bin/sh' line above, then type `sh FILE'.
#
# Made on 1996-03-20 17:02 PST by <jon@oas>.
# Source directory was `/home/oas/jon/ratfor77'.
#
# Existing files will *not* be overwritten unless `-c' is specified.
#
# This shar contains:
# length mode       name
# ------ ---------- ------------------------------------------
#    476 -r--r--r-- BUGS
#   1145 -r--r--r-- GNUmakefile
#    736 -r--r--r-- README
#    996 -r--r--r-- getopt.c
#   1412 -r--r--r-- lookup.c
#    312 -r--r--r-- lookup.h
#  37223 -r--r--r-- rat4.c
#   1218 -r--r--r-- ratcom.h
#   3573 -r--r--r-- ratdef.h
#   2669 -r--r--r-- ratfor.man
#    366 -r--r--r-- test.r
#    985 -r--r--r-- testw.r
#
touch -am 1231235999 $$.touch >/dev/null 2>&1
if test ! -f 1231235999 && test -f $$.touch; then
  shar_touch=touch
else
  shar_touch=:
  echo
  echo 'WARNING: not restoring timestamps.  Consider getting and'
  echo "installing GNU \`touch', distributed in GNU File Utilities..."
  echo
fi
rm -f 1231235999 $$.touch
#
# ============= BUGS ==============
if test -f 'BUGS' && test X"$1" != X"-c"; then
  echo 'x - skipping BUGS (file already exists)'
else
  echo 'x - extracting BUGS (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'BUGS' &&
This is not a bug but a design error
in both AT&T ratfor
and this public domain ratfor:
X
The problem is with the switch statment.
It switches on an integer valued expression.
It should switch on an integer variable.
X
The reason is that
X	"implicit undefined"
X	"implicit null"
is unusable because the switch is done
on a new variable that is not declared or declarable
by the programmer who cannot guess its name.
X
Please let me know if you fix this.
X			jon@sep.stanford.edu.us
SHAR_EOF
  $shar_touch -am 0320165896 'BUGS' &&
  chmod 0444 'BUGS' ||
  echo 'restore of BUGS failed'
  shar_count="`wc -c < 'BUGS'`"
  test 476 -eq "$shar_count" ||
    echo "BUGS: original size 476, current size $shar_count"
fi
# ============= GNUmakefile ==============
if test -f 'GNUmakefile' && test X"$1" != X"-c"; then
  echo 'x - skipping GNUmakefile (file already exists)'
else
  echo 'x - extracting GNUmakefile (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'GNUmakefile' &&
#
#DEBUG := yes
# pd ratfor77 (oz)
#
# if F77 is defined, the output
# of ratfor is Fortran 77.
#
#	On sun4,		use S_CHAR="char"
#	On RS6000,		use S_CHAR="signed char"
#	On DEC3100,	maybe	use S_CHAR="signed char"
#	On CRAY,		use S_CHAR="char"
#	On GNU,		        use S_CHAR="char"
#
# Default definition of the makefile include files
# If you have kept the whole distribution together you won't need to set
# this yourself. If you have just taken a few directories you should set
# the envionment variable "MAKEINC" to point at the config directory.
#
ifndef MAKEINC
X    MAKEINC := ./../../config
endif
#
X
include $(MAKEINC)/Makefile.SEP.defs
X
# we don't want the standard SEP flags so override them
ifeq ($(GNU),yes)
CFLAGS := -c -DF77 -DS_CHAR=$(SIGNED_CHAR) -DGNU
else
CFLAGS := -c -DF77 -DS_CHAR=$(SIGNED_CHAR)
endif
X
all: $(SEPBINDIR)/ratfor77
X	@echo "making all in ratfor77 : done"
#
deinstall:
X	$(RM) $(SEPBINDIR)/ratfor77
X	@echo "deinstall in ratfor77 : done"
#
$(SEPBINDIR)/ratfor77:	$(addprefix $(MACHINETYPE)/, rat4.o lookup.o getopt.o )
X	 $(link.c)
X	$(INSTALL) $(INSTALLBIN) $(MACHINETYPE)/a.out $@
X
include $(MAKEINC)/Makefile.rules
X
SHAR_EOF
  $shar_touch -am 0320165896 'GNUmakefile' &&
  chmod 0444 'GNUmakefile' ||
  echo 'restore of GNUmakefile failed'
  shar_count="`wc -c < 'GNUmakefile'`"
  test 1145 -eq "$shar_count" ||
    echo "GNUmakefile: original size 1145, current size $shar_count"
fi
# ============= README ==============
if test -f 'README' && test X"$1" != X"-c"; then
  echo 'x - skipping README (file already exists)'
else
  echo 'x - extracting README (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'README' &&
X	This is a C version of ratfor, derived from a UofA ratfor
X	in ratfor. It was originally released to the net sometime
X	ago, and It is re-released for the benefit of those sites
X	who only get mod->comp.sources.
X
X	It now includes minor changes to produce F77 code as well.
X
X	This code *is* PD. You (public) have all the rights to the code.
X	[But this also means you (singular) do not have any *extra*
X	rights to the code, hence it is impossible for you to restrict
X	the use and distribution of this code in any way.]
X
X	I would, as usual, appreciate hearing about bug fixes and
X	improvements.
X
X	oz
X
X	Usenet: [decvax|ihnp4]!utzoo!yetti!oz ||
X		    ...seismo!mnetor!yetti!oz
X	Bitnet: oz@[yusol|yuyetti].BITNET
X	Phonet: [416] 736-5257 x 3976
SHAR_EOF
  $shar_touch -am 0320165896 'README' &&
  chmod 0444 'README' ||
  echo 'restore of README failed'
  shar_count="`wc -c < 'README'`"
  test 736 -eq "$shar_count" ||
    echo "README: original size 736, current size $shar_count"
fi
# ============= getopt.c ==============
if test -f 'getopt.c' && test X"$1" != X"-c"; then
  echo 'x - skipping getopt.c (file already exists)'
else
  echo 'x - extracting getopt.c (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'getopt.c' &&
/*
X * getopt - get option letter from argv
X */
X
#include <stdio.h>
#include <string.h>
X
char	*optarg;	/* Global argument pointer. */
int	optind77 = 0;	/* Global argv index. */
X
static char	*scan = NULL;	/* Private scan pointer. */
X
int
our_getopt(argc, argv, optstring)
int argc;
char *argv[];
char *optstring;
{
X	register char c;
X	register char *place;
X
X	optarg = NULL;
X
X	if (scan == NULL || *scan == '\0') {
X		if (optind77 == 0)
X			optind77++;
X
X		if (optind77 >= argc || argv[optind77][0] != '-' || argv[optind77][1] == '\0')
X			return(EOF);
X		if (strcmp(argv[optind77], "--")==0) {
X			optind77++;
X			return(EOF);
X		}
X
X		scan = argv[optind77]+1;
X		optind77++;
X	}
X
X	c = *scan++;
X	place = strchr(optstring, (int) c);
X
X	if (place == NULL || c == ':') {
X		fprintf(stderr, "%s: unknown option -%c\n", argv[0], c);
X		return('?');
X	}
X
X	place++;
X	if (*place == ':') {
X		if (*scan != '\0') {
X			optarg = scan;
X			scan = NULL;
X		} else {
X			optarg = argv[optind77];
X			optind77++;
X		}
X	}
X
X	return(c);
}
X
SHAR_EOF
  $shar_touch -am 0320165896 'getopt.c' &&
  chmod 0444 'getopt.c' ||
  echo 'restore of getopt.c failed'
  shar_count="`wc -c < 'getopt.c'`"
  test 996 -eq "$shar_count" ||
    echo "getopt.c: original size 996, current size $shar_count"
fi
# ============= lookup.c ==============
if test -f 'lookup.c' && test X"$1" != X"-c"; then
  echo 'x - skipping lookup.c (file already exists)'
else
  echo 'x - extracting lookup.c (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'lookup.c' &&
#include <stdio.h>
#include "lookup.h"
X
static
struct	hashlist *hashtab[HASHMAX];
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 */
hash(s)
S_CHAR *s;
{
X	int	hashval;
X
X	for (hashval = 0; *s != '\0';)
X		hashval += *s++;
X	return (hashval % HASHMAX);
}
X
/*
X * lookup - lookup for a string s in the hash table
X *
X */
struct hashlist
*lookup(s)
S_CHAR *s;
{
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 * install - install a string name in hashtable and its value def
X *
X */
struct hashlist
*install(name,def)
S_CHAR *name;
S_CHAR *def;
{
X	int hashval;
X	struct hashlist *np, *lookup();
X	S_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 * strsave - save string s somewhere
X *
X */
S_CHAR
*strsave(s)
S_CHAR *s;
{
X	S_CHAR *p, *malloc();
X
X	if ((p = malloc(strlen(s)+1)) != NULL)
X		strcpy(p, s);
X	return(p);
}
X
X
SHAR_EOF
  $shar_touch -am 0320165896 'lookup.c' &&
  chmod 0444 'lookup.c' ||
  echo 'restore of lookup.c failed'
  shar_count="`wc -c < 'lookup.c'`"
  test 1412 -eq "$shar_count" ||
    echo "lookup.c: original size 1412, current size $shar_count"
fi
# ============= lookup.h ==============
if test -f 'lookup.h' && test X"$1" != X"-c"; then
  echo 'x - skipping lookup.h (file already exists)'
else
  echo 'x - extracting lookup.h (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'lookup.h' &&
X
/*
X * from K&R "The C Programming language"
X * Table lookup routines
X * structure and definitions
X *
X */
X
X					/* basic table entry */
struct hashlist {
X	S_CHAR	*name;
X	S_CHAR	*def;
X	struct	hashlist *next;		/* next in chain     */
};
X
#define HASHMAX	100			/* size of hashtable */
X
X					/* hash table itself */
SHAR_EOF
  $shar_touch -am 0320165896 'lookup.h' &&
  chmod 0444 'lookup.h' ||
  echo 'restore of lookup.h failed'
  shar_count="`wc -c < 'lookup.h'`"
  test 312 -eq "$shar_count" ||
    echo "lookup.h: original size 312, current size $shar_count"
fi
# ============= rat4.c ==============
if test -f 'rat4.c' && test X"$1" != X"-c"; then
  echo 'x - skipping rat4.c (file already exists)'
else
  echo 'x - extracting rat4.c (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'rat4.c' &&
/*
X * ratfor - A ratfor pre-processor in C.
X * Derived from 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 * By: oz
X *
X * Not deived from AT&T code.
X *
X * This code is in the public domain. In other words, all rights
X * are granted to all recipients, "public" at large.
X *
X * Modification history:
X *
X * June 1985
X *	- Ken Yap's mods for F77 output. Currently
X *	  available thru #define F77.
X *	- Two minor bug-fixes for sane output.
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 borrowed from the SWTOOLS Ratfor.
X *
X * 05-28-91 W. Bauske IBM
X *	- ported to RS/6000
X *	- fixed line continuations
X *	- added -C option to leave comments in the source code
X *	- added % in column 1 to force copy to output
X *	- support both && and & for .and.
X *	- support both || and | for .or.
X *
X */
X
#include <stdio.h>
X
#if defined __stdc__ || defined __STDC__
#include <stdlib.h>
#endif
X
#include <string.h>
X
#include "ratdef.h"
#include "ratcom.h"
X
/* keywords: */
X
char sdo[3] = {
X	LETD,LETO,EOS};
char vdo[2] = {
X	LEXDO,EOS};
X
char sif[3] = {
X	LETI,LETF,EOS};
char vif[2] = {
X	LEXIF,EOS};
X
char selse[5] = {
X	LETE,LETL,LETS,LETE,EOS};
char velse[2] = {
X	LEXELSE,EOS};
X
#ifdef F77
char sthen[5] = {
X	LETT,LETH,LETE,LETN,EOS};
X
char sendif[6] = {
X	LETE,LETN,LETD,LETI,LETF,EOS};
X
#endif /* F77 */
char swhile[6] = {
X	LETW, LETH, LETI, LETL, LETE, EOS};
char vwhile[2] = {
X	LEXWHILE, EOS};
X
char ssbreak[6] = {
X	LETB, LETR, LETE, LETA, LETK, EOS};
char vbreak[2] = {
X	LEXBREAK, EOS};
X
char snext[5] = {
X	LETN,LETE, LETX, LETT, EOS};
char vnext[2] = {
X	LEXNEXT, EOS};
X
char sfor[4] = {
X	LETF,LETO, LETR, EOS};
char vfor[2] = {
X	LEXFOR, EOS};
X
char srept[7] = {
X	LETR, LETE, LETP, LETE, LETA, LETT, EOS};
char vrept[2] = {
X	LEXREPEAT, EOS};
X
char suntil[6] = {
X	LETU, LETN, LETT, LETI, LETL, EOS};
char vuntil[2] = {
X	LEXUNTIL, EOS};
X
char sswitch[7] = {
X	LETS, LETW, LETI, LETT, LETC, LETH, EOS};
char vswitch[2] = {
X	LEXSWITCH, EOS};
X
char scase[5] = {
X	LETC, LETA, LETS, LETE, EOS};
char vcase[2] = {
X	LEXCASE, EOS};
X
char sdefault[8] = {
X	LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS};
char vdefault[2] = {
X	LEXDEFAULT, EOS};
X
char sret[7] = {
X	LETR, LETE, LETT, LETU, LETR, LETN, EOS};
char vret[2] = {
X	LEXRETURN, EOS};
X
char sstr[7] = {
X	LETS, LETT, LETR, LETI, LETN, LETG, EOS};
char vstr[2] = {
X	LEXSTRING, EOS};
X
char deftyp[2] = {
X	DEFTYPE, EOS};
X
/* constant strings */
X
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/";
X
extern S_CHAR ngetch();
char *progname;
int startlab = 23000;		/* default start label */
int leaveC = NO;		/* Flag for handling comments */
X
/*
X * M A I N   L I N E  &  I N I T
X */
X
main(argc,argv)
int argc;
char *argv[];
{
X	int c, errflg = 0;
X	extern int optind77;
X	extern char *optarg;
X
X	progname = argv[0];
X
X	while ((c=our_getopt(argc, argv, "Chn:o:6:")) != EOF)
X	switch (c) {
X		case 'C':
X			leaveC = YES; /* keep comments in src */
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",progname);
X		exit(1);
X	}
X
X	/*
X	 * present version can only process one file, sadly.
X	 */
X	if (optind77 >= argc)
X		infile[0] = stdin;
X	else if ((infile[0] = fopen(argv[optind77], "r")) == NULL)
X		error("cannot read %s\n", argv[optind77]);
X
X	initvars();
X
X	parse();		/* call parser.. */
X
X	exit(0);
}
X
/*
X * initialise
X */
initvars()
{
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	printf("C Output from Public domain Ratfor, version 1.0\n");
}
X
/*
X * P A R S E R
X */
X
parse()
{
X	S_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 * L E X I C A L  A N A L Y S E R
X */
X
/*
X *  alldig - return YES if str is all digits
X *
X */
int
alldig(str)
S_CHAR str[];
{
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 * balpar - copy balanced paren string
X *
X */
balpar()
{
X	S_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 * deftok - get token; process macro calls and invocations
X *
X */
int
deftok(token, toksiz, fd)
S_CHAR token[];
int toksiz;
FILE *fd;
{
X	S_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 * eatup - process rest of statement; interpret continuations
X *
X */
eatup()
{
X
X	S_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 * getdef (for no arguments) - get name and definition
X *
X */
getdef(token, toksiz, defn, defsiz, fd)
S_CHAR token[];
int toksiz;
S_CHAR defn[];
int defsiz;
FILE *fd;
{
X	int i, nlpar, t;
X	S_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 = (S_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 != (S_CHAR)EOF && c != PERCENT);
X		if (c == SHARP || c == PERCENT)
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) == (S_CHAR)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 * gettok - get token. handles file inclusion and line numbers
X *
X */
int
gettok(token, toksiz)
S_CHAR token[];
int toksiz;
{
X	int t, i;
X	int tok;
X	S_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((char *) (&name[0]))) {
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;
/*WSB 6-25-91
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				name[i-1]=EOS;
X				infile[level+1] = fopen((char*)&name[2], "r");
/*WSB 6-25-91
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 * gnbtok - get nonblank token
X *
X */
int
gnbtok(token, toksiz)
S_CHAR token[];
int toksiz;
{
X	int tok;
X
X	skpblk(infile[level]);
X	tok = gettok(token, toksiz);
X	return(tok);
}
X
/*
X * gtok - get token for Ratfor
X *
X */
int
gtok(lexstr, toksiz, fd)
S_CHAR lexstr[];
int toksiz;
FILE *fd;
{ int i, b, n, tok;
X	S_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 == PERCENT) 
X		{
X			  outasis(fd);		/* copy direct to output if % */
X			  c = NEWLINE;
X		}
X		if (c == SHARP) {
X			if(leaveC == YES)
X			{
X			  outcmnt(fd);		/* copy comments to output */
X			  c = NEWLINE;
X			}
X			else
X			  while (ngetch(&c, fd) != NEWLINE) /* strip comments */
X				;
X		}
/*
X		if (c == UNDERLINE)	
X			if(ngetch(&c, fd) == NEWLINE)
X				while(ngetch(&c, fd) == NEWLINE)
X					;
X			else
X			{
X				putbak(c);
X				c = UNDERLINE;
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	}
#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	}
#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 == PERCENT) {
X		outasis(fd);		/* direct copy of protected */
X		tok = NEWLINE;
X	}
X	else if (c == SHARP) { 
X		if(leaveC == YES)
X		  outcmnt(fd);		/* copy comments to output */
X		else
X		  while (ngetch(&lexstr[0], fd) != NEWLINE) /* strip comments */
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
#if defined(CRAY) || defined(GNU)
/* cray cannot compare char and ints, since EOF is an int we check with feof */
X	if (feof(fd)) tok = EOF;
#endif
X
X	return(tok);
}
X
/*
X * lex - return lexical type of token
X *
X */
int
lex(lexstr)
S_CHAR lexstr[];
{
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, ssbreak) == 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 * ngetch - get a (possibly pushed back) character
X *
X */
S_CHAR
ngetch(c, fd)
S_CHAR *c;
FILE *fd;
{
X
X	if (bp >= 0) {
X		*c = buf[bp];
X		bp--;
X	}
X	else
X		*c = (S_CHAR) getc(fd);
X
/*
X *					check for a continuation '_\n'
X *					also removes UNDERLINES from 
X *					variable names
X */
X	while ( *c == UNDERLINE)
X	{
X		if (bp >= 0) {
X			*c = buf[bp];
X			bp--;
X		}
X		else
X			*c = (S_CHAR) getc(fd);
X
X		if (*c != NEWLINE)
X		{
X			putbak(*c);
X			*c=UNDERLINE;
X			break;
X		}
X		else
X		{
X			while(*c == NEWLINE)
X			{
X				if (bp >= 0) {
X					*c = buf[bp];
X					bp--;
X				}
X				else
X					*c = (S_CHAR) getc(fd);
X			}
X		}
X	}
X
X	return(*c);
}
/*
X * pbstr - push string back onto input
X *
X */
pbstr(in)
S_CHAR in[];
{
X	int i;
X
X	for (i = strlen((char *) (&in[0])) - 1; i >= 0; i--)
X		putbak(in[i]);
}
X
/*
X * putbak - push char back onto input
X *
X */
putbak(c)
S_CHAR c;
{
X
X	bp++;
X	if (bp > BUFSIZE)
X		baderr("too many characters pushed back.");
X	buf[bp] = c;
}
X
X
/*
X * relate - convert relational shorthands into long form
X *
X */
int
relate(token, fd)
S_CHAR token[];
FILE *fd;
{
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) {		/* look for && or & */
X	  if (ngetch(&token[1], fd) != AND) 
X		                    putbak(token[1]);
X		token[1] = LETA;
X		token[2] = LETN;
X		token[3] = LETD;
X		token[4] = PERIOD;
X	}
X	else if (token[0] == OR) {
X	  if (ngetch(&token[1], fd) != OR)	/* look for || or | */ 
X		                    putbak(token[1]);
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((char *) (&token[0]))-1);
}
X
/*
X * skpblk - skip blanks and tabs in file  fd
X *
X */
skpblk(fd)
FILE *fd;
{
X	S_CHAR c;
X
X	for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
X		;
X	putbak(c);
}
X
X
/*
X * type - return LETTER, DIGIT or char; works with ascii alphabet
X *
X */
int
type(c)
S_CHAR c;
{
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 * C O D E  G E N E R A T I O N
X */
X
/*
X * brknxt - generate code for break n and next n; n = 1 is default
X */
brknxt(sp, lextyp, labval, token)
int sp;
int lextyp[];
int labval[];
int token;
{
X	int i, n;
X	S_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]);
/* original value
X			xfer = YES;
*/
X			xfer = NO;
X			return;
X		}
X	if (token == LEXBREAK)
X		synerr("illegal break.");
X	else
X		synerr("illegal next.");
X	return;
}
X
/*
X * docode - generate code for beginning of do
X *
X */
docode(lab)
int *lab;
{
X	xfer = NO;
X	outtab();
X	outstr(sdo);
X	*lab = labgen(2);
X	outnum(*lab);
X	eatup();
X	outdon();
}
X
/*
X * dostat - generate code for end of do statement
X *
X */
dostat(lab)
int lab;
{
X	outcon(lab);
X	outcon(lab+1);
}
X
/*
X * elseif - generate code for end of if before else
X *
X */
elseif(lab)
int lab;
{
X
#ifdef F77
X	outtab();
X	outstr(selse);
X	outdon();
#else
X	outgo(lab+1);
X	outcon(lab);
#endif /* F77 */
}
X
/*
X * forcod - beginning of for statement
X *
X */
forcod(lab)
int *lab;
{
X	S_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 == (S_CHAR)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((char *) (&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 == (S_CHAR)EOF) {
X			pbstr(token);
X			break;
X		}
X		if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
X			if ((j + ((int) strlen((char *) (&token[0])))) >=
X				((int) MAXFORSTK))
X				baderr("for clause too long.");
X			scopy(token, 0, forstk, j);
X			j = j + strlen((char *) (&token[0]));
X		}
X	}
X	tlab++;   /* label for next's */
X	*lab = tlab;
}
X
/*
X * fors - process end of for statement
X *
X */
fors(lab)
int lab;
{
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((char *) (&forstk[j])) + 1;
X	if (((int) strlen((char *) (&forstk[j]))) > ((int) 0)) {
X		outtab();
X		outstr(&forstk[j]);
X		outdon();
X	}
X	outgo(lab-1);
X	outcon(lab+1);
X	fordep--;
}
X
/*
X * ifcode - generate initial code for if
X *
X */
ifcode(lab)
int *lab;
{
X
X	xfer = NO;
X	*lab = labgen(2);
#ifdef F77
X	ifthen();
#else
X	ifgo(*lab);
#endif /* F77 */
}
X
#ifdef F77
/*
X * ifend - generate code for end of if
X *
X */
ifend()
{
X	outtab();
X	outstr(sendif);
X	outdon();
}
#endif /* F77 */
X
/*
X * ifgo - generate "if(.not.(...))goto lab"
X *
X */
ifgo(lab)
int lab;
{
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
#ifdef F77
/*
X * ifthen - generate "if((...))then"
X *
X */
ifthen()
{
X	outtab();
X	outstr(sif);
X	balpar();
X	outstr(sthen);
X	outdon();
}
#endif /* F77 */
X
/*
X * labelc - output statement number
X *
X */
labelc(lexstr)
S_CHAR lexstr[];
{
X
X	xfer = NO;   /* can't suppress goto's now */
X	if (strlen((char *) (&lexstr[0])) == 5)   /* warn about 23xxx labels */
X		if (atoi((char*)lexstr) >= startlab)
X			synerr("warning: possible label conflict.");
X	outstr(lexstr);
X	outtab();
}
X
/*
X * labgen - generate  n  consecutive labels, return first one
X *
X */
int
labgen(n)
int n;
{
X	int i;
X
X	i = label;
X	label = label + n;
X	return(i);
}
X
/*
X * otherc - output ordinary Fortran statement
X *
X */
otherc(lexstr)
S_CHAR lexstr[];
{
X	xfer = NO;
X	outtab();
X	outstr(lexstr);
X	eatup();
X	outdon();
}
X
/*
X * outch - put one char into output buffer
X *
X */
outch(c)
S_CHAR c;
{
X	int i;
X
X	if (outp >= 72) {   /* continuation card */
X		outdon();
X		for (i = 0; i < 6; i++)
X			outbuf[i] = BLANK;
X		outbuf[5]='*';
X		outp = 6;
X	}
X	outbuf[outp] = c;
X	outp++;
}
X
/*
X * outcon - output "n   continue"
X *
X */
outcon(n)
int n;
{
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 * outdon - finish off an output line
X *
X */
outdon()
{
X
X	outbuf[outp] = NEWLINE;
X	outbuf[outp+1] = EOS;
X	printf("%s", outbuf);
X	outp = 0;
}
X
/*
X * outcmnt - copy comment to output
X *
X */
outcmnt(fd)
FILE * fd;
{
X        S_CHAR c;
X        S_CHAR comout[81];
X        int i, comoutp=0;
X
X        comoutp=1;
X        comout[0]='C';
X        while((c=ngetch(&c,fd)) != NEWLINE) {
X           if (comoutp > 79) {
X              comout[80]=NEWLINE;
X              comout[81]=EOS;
X              printf("%s",comout);
X              comoutp=0;
X              comout[comoutp]='C';
X              comoutp++;
X           }
X           comout[comoutp]=c;
X           comoutp++;
X        }
X        comout[comoutp]=NEWLINE;
X        comout[comoutp+1]=EOS;
X        printf("%s",comout);
}
X
/*
X * outasis - copy directly out
X *
X */
outasis(fd)
FILE * fd;
{
X	S_CHAR c;
X	while((c=ngetch(&c,fd)) != NEWLINE)
X					outch(c);
X	outdon();
}
X
/*
X * outgo - output "goto  n"
X *
X */
outgo(n)
int n;
{
X	if (xfer == YES)
X		return;
X	outtab();
X	outstr(rgoto);
X	outnum(n);
X	outdon();
}
X
/*
X * outnum - output decimal number
X *
X */
outnum(n)
int n;
{
X
X	S_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 * outstr - output string
X *
X */
outstr(str)
S_CHAR str[];
{
X	int i;
X
X	for (i=0; str[i] != EOS; i++)
X		outch(str[i]);
}
X
/*
X * outtab - get past column 6
X *
X */
outtab()
{
X	while (outp < 6)
X		outch(BLANK);
}
X
X
/*
X * repcod - generate code for beginning of repeat
X *
X */
repcod(lab)
int *lab;
{
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 * retcod - generate code for return
X *
X */
retcod()
{
X	S_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
/* strdcl - generate code for string declaration */
strdcl()
{
X	S_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((char *) (&init[0])) + 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((char *)(&init[0])) + 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 * unstak - unstack at end of statement
X *
X */
unstak(sp, lextyp, labval, token)
int *sp;
int lextyp[];
int labval[];
S_CHAR token;
{
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)
#ifdef F77
X			ifend();
#else
X			outcon(labval[tp]);
#endif /* F77 */
X		else if (lextyp[tp] == LEXELSE) {
X			if (*sp > 1)
X				tp--;
#ifdef F77
X			ifend();
#else
X			outcon(labval[tp]+1);
#endif /* F77 */
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 * untils - generate code for until or end of repeat
X *
X */
untils(lab, token)
int lab;
int token;
{
X	S_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 * whilec - generate code for beginning of while
X *
X */
whilec(lab)
int *lab;
{
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);
#ifdef F77
X	ifthen();
#else
X	ifgo(tlab+1);
#endif /* F77 */
X	*lab = tlab;
}
X
/*
X * whiles - generate code for end of while
X *
X */
whiles(lab)
int lab;
{
X
X	outgo(lab);
#ifdef F77
X	ifend();
#endif /* F77 */
X	outcon(lab+1);
}
X
/*
X * E R R O R  M E S S A G E S
X */
X
/*
X *  baderr - print error message, then die
X */
baderr(msg)
S_CHAR msg[];
{
X	synerr(msg);
X	exit(1);
}
X
/*
X * error - print error message with one parameter, then die
X */
error(msg, s)
char *msg;
S_CHAR *s;
{
X	fprintf(stderr, msg,s);
X	exit(1);
}
X
/*
X * synerr - report Ratfor syntax error
X */
synerr(msg)
S_CHAR *msg;
{
X	S_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,(char*)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,(char*)&fnames[i]);
X			break;
X		}
X	fprintf(stderr,": \n      %s\n",msg);
}
X
X
/*
X * U T I L I T Y  R O U T I N E S
X */
X
/*
X * ctoi - convert string at in[i] to int, increment i
X */
int
ctoi(in, i)
S_CHAR in[];
int *i;
{
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 * fold - convert alphabetic token to single case
X *
X */
fold(token)
S_CHAR token[];
{
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 * equal - compare str1 to str2; return YES if equal, NO if not
X *
X */
int
equal(str1, str2)
S_CHAR str1[];
S_CHAR str2[];
{
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 * scopy - copy string at from[i] to to[j]
X *
X */
scopy(from, i, to, j)
S_CHAR from[];
int i;
S_CHAR to[];
int j;
{
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
#include "lookup.h"
/*
X * look - look-up a definition
X *
X */
int
look(name,defn)
S_CHAR name[];
S_CHAR defn[];
{
X	extern struct hashlist *lookup();
X	struct hashlist *p;
X
X	if ((p = lookup(name)) == NULL)
X		return(NO);
X	(void) strcpy((char *) (&defn[0]),(char *) (&((p->def)[0])));
X	return(YES);
}
X
/*
X * itoc - special version of itoa
X */
int
itoc(n,str,size)
int n;
S_CHAR str[];
int size;
{
X	int i,j,k,sign;
X	S_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((char *) (&str[0])) - 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 * cascod - generate code for case or default label
X *
X */
cascod (lab, token)
int lab;
int token;
{
X	int t, l, lb, ub, i, j, junk;
X	S_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 * caslab - get one case label
X *
X */
int
caslab (n, t)
int *n;
int *t;
{
X	S_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 * swcode - generate code for switch stmt.
X *
X */
swcode (lab)
int *lab;
{
X	S_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 * swend  - finish off switch statement; generate dispatch code
X *
X */
swend(lab)
int lab;
{
X	int lb, ub, n, i, j;
X
static	char *sif   	= "if (";
static	char *slt   	= ".lt.1.or.";
static	char *sgt   	= ".gt.";
static	char *sgoto 	= "goto (";
static	char *seq   	= ".eq.";
static	char *sge   	= ".ge.";
static	char *sle   	= ".le.";
static	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	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 * swvar  - output switch variable Innn, where nnn = lab
X */
swvar  (lab)
int lab;
{
X
X	outch ('I');
X	outnum (lab);
}
SHAR_EOF
  $shar_touch -am 0320165896 'rat4.c' &&
  chmod 0444 'rat4.c' ||
  echo 'restore of rat4.c failed'
  shar_count="`wc -c < 'rat4.c'`"
  test 37223 -eq "$shar_count" ||
    echo "rat4.c: original size 37223, current size $shar_count"
fi
# ============= ratcom.h ==============
if test -f 'ratcom.h' && test X"$1" != X"-c"; then
  echo 'x - skipping ratcom.h (file already exists)'
else
  echo 'x - extracting ratcom.h (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'ratcom.h' &&
int bp;			/*   next available char; init = 0 */
S_CHAR buf[BUFSIZE];	/*   pushed-back chars */
S_CHAR fcname[MAXNAME];	/*   text of current function name */
int fordep;		/*   current depth of for statements */
S_CHAR forstk[MAXFORSTK];	/*   stack of reinit strings */
int swtop;		/*   current switch entry; init=0              */
int swlast;		/*   next available position; init=1           */
int swstak[MAXSWITCH];	/*   switch information stack                  */
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 */
S_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 */
S_CHAR outbuf[82];	/*   output lines collected here */
S_CHAR fname[MAXNAME][NFILES];	/*   file names */
int nfiles;		/*   number of files */
SHAR_EOF
  $shar_touch -am 0320165896 'ratcom.h' &&
  chmod 0444 'ratcom.h' ||
  echo 'restore of ratcom.h failed'
  shar_count="`wc -c < 'ratcom.h'`"
  test 1218 -eq "$shar_count" ||
    echo "ratcom.h: original size 1218, current size $shar_count"
fi
# ============= ratdef.h ==============
if test -f 'ratdef.h' && test X"$1" != X"-c"; then
  echo 'x - skipping ratdef.h (file already exists)'
else
  echo 'x - extracting ratdef.h (text)'
  sed 's/^X//' << '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
X
#define LIMIT   134217728
#define LIM1    28
#define LIM2    -28
X
/*
X * lexical analyser symbols
X *
X */
X
#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 LEXSWITCH	19
#define LEXCASE		20
#define LEXDEFAULT	21
#define DEFTYPE   	22
X
#define MAXCHARS   	10   	/* characters for outnum */
#define MAXDEF   	200   	/* max chars in a defn */
#define MAXSWITCH       300     /* max stack for switch statement */
#define CUTOFF          3       /* min number of cases necessary to generate
*/
X                                /* a dispatch table */
#define DENSITY         2
#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 */
X
#define RADIX   	PERCENT /* % indicates alternate radix */
#define BUFSIZE   	300   	/* pushback buffer for ngetch and putbak */
X
SHAR_EOF
  $shar_touch -am 0320165896 'ratdef.h' &&
  chmod 0444 'ratdef.h' ||
  echo 'restore of ratdef.h failed'
  shar_count="`wc -c < 'ratdef.h'`"
  test 3573 -eq "$shar_count" ||
    echo "ratdef.h: original size 3573, current size $shar_count"
fi
# ============= ratfor.man ==============
if test -f 'ratfor.man' && test X"$1" != X"-c"; then
  echo 'x - skipping ratfor.man (file already exists)'
else
  echo 'x - extracting ratfor.man (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'ratfor.man' &&
NAME
X  ratfor77 - ratfor preprocessor for fortran77
X
SYNOPSIS
X ratfor [-l n] [-C] [-o output] input
X
PARAMETERS
X -l n        user sets strating label n
X -o output   specify output file, otherwise it is stdout 
X -C          keep comments in (useful for compiler directives)
X
X
DESCRIPTION
Ratfor has the following syntax:
X
prog:   stat
X        prog stat
X
stat:   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
where stat is any Fortran or Ratfor statement, and intexpr is an
expression that resolves into an integer value.  A statement is
terminated by an end-of-line or a semicolon.  The following translations
are also performed.
X
X        <       .lt.    <=      .le.
X        ==      .eq.
X        !=      .ne.    ^=      .ne.    ~=      .ne.
X        >=      .ge.    >       .gt.
X        |       .or.    &       .and.
X        !       .not.   ^       .not.   ~       .not.
X
Integer constants in bases other that decimal may be specified as
n%dddd...  where n is a decimal number indicating the base and dddd...
are digits in that base.  For bases > 10, letters are used for digits
above 9.  Examples:  8%77, 16%2ff, 2%0010011.  The number is converted
the equivalent decimal value using multiplication; this may cause sign
problems if the number has too many digits.
X
String literals ("..." or '...') can be continued across line boundaries
by ending the line to be continued with an underline.  The underline is
not included as part of the literal.  Leading blanks and tabs on the
next line are ignored; this facilitates consistent indentation.
X
X        include file
X
will include the named file in the input.
X
X        define (name,value)     or
X        define name value
X
defines name as a symbolic parameter with the indicated value.  Names of
symbolic parameters may contain letters, digits, periods, and underline
character but must begin with a letter (e.g.  B.FLAG).  Upper case is
not equivalent to lower case in parameter names.
X
X        string name "character string"          or
X        string name(size) "character string"
X
defines name to be an integer array long enough to accomodate the ascii
codes for the given character string, one per word.  The last word of
name is initialized to the symbolic parameter EOS, and indicates the end
of string.
X
KEYWORDS
ratfor fortran preprocessor fortran77 ratfor77 spp
X
SHAR_EOF
  $shar_touch -am 0320165896 'ratfor.man' &&
  chmod 0444 'ratfor.man' ||
  echo 'restore of ratfor.man failed'
  shar_count="`wc -c < 'ratfor.man'`"
  test 2669 -eq "$shar_count" ||
    echo "ratfor.man: original size 2669, current size $shar_count"
fi
# ============= test.r ==============
if test -f 'test.r' && test X"$1" != X"-c"; then
  echo 'x - skipping test.r (file already exists)'
else
  echo 'x - extracting test.r (text)'
  sed 's/^X//' << 'SHAR_EOF' > 'test.r' &&
integer x,y
x=1; y=2
if(x == y)
X	write(6,600)
else if(x > y)
X	write(6,601)
else
X	write(6,602)
x=1
while(x < 10){
X	if(y != 2) break
X	if(y != 2) next
X	write(6,603)x
X	x=x+1
X	}
repeat
X	x=x-1
until(x == 0)
for(x=0; x < 10; x=x+1)
X	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
  $shar_touch -am 0320165896 'test.r' &&
  chmod 0444 'test.r' ||
  echo 'restore of test.r failed'
  shar_count="`wc -c < 'test.r'`"
  test 366 -eq "$shar_count" ||
    echo "test.r: original size 366, current size $shar_count"
fi
# ============= testw.r ==============
if test -f 'testw.r' && test X"$1" != X"-c"; then
  echo 'x - skipping testw.r (file already exists)'
else
  echo 'x - extracting testw.r (binary)'
  sed 's/^X//' << 'SHAR_EOF' | uudecode &&
begin 600 testw.r
M:6YT96=E<B!X+'DL<7=E="QF9V0L9&IR+&MF>2QG+&IG+&=K+&HL<V1H9BQA
M<V<L86=S9"QA9W,L:"QY+'1S<F@L<W1H+')U:RQI;"QY+&ID+'-H="QW:'0L
M=W1H+'1H92QJ=7EK+'ET+'1L:74L<FHL:'1W+&=R<RQW+'1H+'=H="QH=W1E
M+&5R:BQK=70L=6MY+&EL="QY+&5R+&AT+'=T:"QE:'0L97DL96IY+&5J+&4L
M=6ME+&QY+&QI=2QO>2QG+'0L87-G+'-D9BQB8RQG:&8L<G1H+'-B8RQS9&@L
M<V@L<V)C+'-D9BQS9FAD+'=R:`IX/3$[('D],@HC('-F861J;&L[;&MD9F%S
M:FML9G-J:VQF<V1J;&MF:FML9F1S:FML.V9D<VIK;&IK;'-D9FIK;#MD<V9D
M9FIK;'-J:VQS9&9J:VQF<V1J;#MK:SMS9&9J:VP[9G-D:FML.V1F<VIK;&1S
M9FIK;#MD9G-J:VP[9F1S:FML9F1S:FML.VIH9'-T:&IK.W-H=&UK+GAB9VUK
M8G9M:VQD.V9S9&IK;'-G:FML9VIK;#MG<VIK;#MG:FP[:VIK;#MG:FML.V9G
M;#MJ:VIK;`HE(V1E9FEN92!!0D,@9&5F"FEF*"AX/3UY*2`F)B!X(#X],"EP
M<FEN="`J+"=I="!W;W)K<RXN+B<*:68H*'@]/7DI("8F(%\*>"`\/3`I(%\*
M"7!R:6YT("HL)VET('=O<FMS+BXN)PII9BAX(#T]('DI"@EW<FET92@V+#8P
M,"D*96QS92!I9BAX(#X@>2D*"7=R:71E*#8L-C`Q*0IE;'-E"@EW<FET92@V
M+#8P,BD*(R!C:&5C:R!U;F1E<G-C;W)E<R!I;B!N86UE<PIC86QL(&%B8U]D
M968H>"QY*0H*>#TQ"G=H:6QE*'@@/"`Q,"E["@EI9BAY("$](#(I(&)R96%K
M"@EI9BAY("$](#(I(&YE>'0*"7=R:71E*#8L-C`S*7@*"7@]>"LQ"@E]"G)E
M<&5A="!["@EX/7@M,0H):68H>"`\(#`I>PH)"6)R96%K"@D)?0H)?0IU;G1I
M;"AX(#T](#`I"F9O<BAX/3`[('@@/"`Q,#L@>#UX*S$I"@EW<FET92@V+#8P
M-"EX"C8P,"!F;W)M870H)U=R;VYG+"!X("$]('DG*0HV,#$@9F]R;6%T*"=!
M;'-O('=R;VYG+"!X(#P@>2<I"C8P,B!F;W)M870H)T]K(2<I"C8P,R!F;W)M
H870H)W@@/2`G+&DR*0HV,#0@9F]R;6%T*"=X(#T@)RQI,BD*96YD"B!F
`
end
SHAR_EOF
  $shar_touch -am 0320165896 'testw.r' &&
  chmod 0444 'testw.r' ||
  echo 'restore of testw.r failed'
  shar_count="`wc -c < 'testw.r'`"
  test 985 -eq "$shar_count" ||
    echo "testw.r: original size 985, current size $shar_count"
fi
exit 0