v13i037: Public domain RATFOR in C
Rich Salz
rsalz at bbn.com
Sat Feb 13 08:11:14 AEST 1988
Submitted-by: Ozan Yigit <yetti!oz>
Posting-number: Volume 13, Issue 37
Archive-name: ratfor
[ This is a pre-processor that turns RATFOR programs in to real Fortran
programs. RATFOR is Fortran with real control structures, like
switch and if/then/else. This happens to generate F77 Fortran, too.
--r$ ]
#! /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:
# rat4.c
# lookup.c
# getopt.c
# ratdef.h
# ratcom.h
# lookup.h
# README
# ratfor.doc
# test.r
# makefile
export PATH; PATH=/bin:$PATH
echo shar: extracting "'rat4.c'" '(33966 characters)'
if test -f 'rat4.c'
then
echo shar: will not over-write existing file "'rat4.c'"
else
sed 's/^ X//' << \SHAR_EOF > 'rat4.c'
X/*
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 */
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
X#ifdef F77
Xchar sthen[5] = {
X LETT,LETH,LETE,LETN,EOS};
X
Xchar sendif[6] = {
X LETE,LETN,LETD,LETI,LETF,EOS};
X
X#endif F77
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#ifdef F77
X outtab();
X outstr(selse);
X outdon();
X#else
X outgo(lab+1);
X outcon(lab);
X#endif F77
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#ifdef F77
X ifthen();
X#else
X ifgo(*lab);
X#endif F77
X}
X
X#ifdef F77
X/*
X * ifend - generate code for end of if
X *
X */
Xifend()
X{
X outtab();
X outstr(sendif);
X outdon();
X}
X#endif F77
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#ifdef F77
X/*
X * ifthen - generate "if((...))then"
X *
X */
Xifthen()
X{
X outtab();
X outstr(sif);
X balpar();
X outstr(sthen);
X outdon();
X}
X#endif F77
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 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("%s", 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#ifdef F77
X ifend();
X#else
X outcon(labval[tp]);
X#endif F77
X else if (lextyp[tp] == LEXELSE) {
X if (*sp > 1)
X tp--;
X#ifdef F77
X ifend();
X#else
X outcon(labval[tp]+1);
X#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
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#ifdef F77
X ifthen();
X#else
X ifgo(tlab+1);
X#endif F77
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#ifdef F77
X ifend();
X#endif F77
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 33966 -ne "`wc -c < 'rat4.c'`"
then
echo shar: error transmitting "'rat4.c'" '(should have been 33966 characters)'
fi
chmod +x 'rat4.c'
fi # end of overwriting check
echo shar: extracting "'lookup.c'" '(1397 characters)'
if test -f 'lookup.c'
then
echo shar: will not over-write existing file "'lookup.c'"
else
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'
fi # end of overwriting check
echo shar: extracting "'getopt.c'" '(969 characters)'
if test -f 'getopt.c'
then
echo shar: will not over-write existing file "'getopt.c'"
else
sed 's/^ X//' << \SHAR_EOF > 'getopt.c'
X/*
X * getopt - get option letter from argv
X */
X
X#include <stdio.h>
X
Xchar *optarg; /* Global argument pointer. */
Xint optind = 0; /* Global argv index. */
X
Xstatic char *scan = NULL; /* Private scan pointer. */
X
Xextern char *index();
X
Xint
Xgetopt(argc, argv, optstring)
Xint argc;
Xchar *argv[];
Xchar *optstring;
X{
X register char c;
X register char *place;
X
X optarg = NULL;
X
X if (scan == NULL || *scan == '\0') {
X if (optind == 0)
X optind++;
X
X if (optind >= argc || argv[optind][0] != '-' || argv[optind][1] == '\0')
X return(EOF);
X if (strcmp(argv[optind], "--")==0) {
X optind++;
X return(EOF);
X }
X
X scan = argv[optind]+1;
X optind++;
X }
X
X c = *scan++;
X place = index(optstring, 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[optind];
X optind++;
X }
X }
X
X return(c);
X}
X
SHAR_EOF
if test 969 -ne "`wc -c < 'getopt.c'`"
then
echo shar: error transmitting "'getopt.c'" '(should have been 969 characters)'
fi
chmod +x 'getopt.c'
fi # end of overwriting check
echo shar: extracting "'ratdef.h'" '(3579 characters)'
if test -f 'ratdef.h'
then
echo shar: will not over-write existing file "'ratdef.h'"
else
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'
fi # end of overwriting check
echo shar: extracting "'ratcom.h'" '(1206 characters)'
if test -f 'ratcom.h'
then
echo shar: will not over-write existing file "'ratcom.h'"
else
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'
fi # end of overwriting check
echo shar: extracting "'lookup.h'" '(309 characters)'
if test -f 'lookup.h'
then
echo shar: will not over-write existing file "'lookup.h'"
else
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'
fi # end of overwriting check
echo shar: extracting "'README'" '(739 characters)'
if test -f 'README'
then
echo shar: will not over-write existing file "'README'"
else
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
if test 739 -ne "`wc -c < 'README'`"
then
echo shar: error transmitting "'README'" '(should have been 739 characters)'
fi
chmod +x 'README'
fi # end of overwriting check
echo shar: extracting "'ratfor.doc'" '(2471 characters)'
if test -f 'ratfor.doc'
then
echo shar: will not over-write existing file "'ratfor.doc'"
else
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'
fi # end of overwriting check
echo shar: extracting "'test.r'" '(366 characters)'
if test -f 'test.r'
then
echo shar: will not over-write existing file "'test.r'"
else
sed 's/^ X//' << \SHAR_EOF > 'test.r'
Xinteger x,y
Xx=1; y=2
Xif(x == y)
X write(6,600)
Xelse if(x > y)
X write(6,601)
Xelse
X write(6,602)
Xx=1
Xwhile(x < 10){
X if(y != 2) break
X if(y != 2) next
X write(6,603)x
X x=x+1
X }
Xrepeat
X x=x-1
Xuntil(x == 0)
Xfor(x=0; x < 10; x=x+1)
X write(6,604)x
X600 format('Wrong, x != y')
X601 format('Also wrong, x < y')
X602 format('Ok!')
X603 format('x = ',i2)
X604 format('x = ',i2)
Xend
SHAR_EOF
if test 366 -ne "`wc -c < 'test.r'`"
then
echo shar: error transmitting "'test.r'" '(should have been 366 characters)'
fi
chmod +x 'test.r'
fi # end of overwriting check
echo shar: extracting "'makefile'" '(488 characters)'
if test -f 'makefile'
then
echo shar: will not over-write existing file "'makefile'"
else
sed 's/^ X//' << \SHAR_EOF > 'makefile'
X# pd ratfor (oz)
X#
X# if F77 is defined, the output
X# of ratfor is Fortran 77.
X#
XCFLAGS = -DF77 -O
XDEST = /usr/local/bin
XOBJS = rat4.o lookup.o getopt.o
XCSRC = rat4.c lookup.c getopt.c
XHSRC = ratdef.h ratcom.h lookup.h
XDOCS = README ratfor.doc
XRSRC = test.r makefile
X
Xrat4: ${OBJS}
X cc -o ratfor ${OBJS}
X
Xrat4.o: ratdef.h ratcom.h
Xlookup.o: lookup.h
X
Xinstall: rat4
X install ./ratfor ${DEST}/ratfor
Xclean:
X rm -f *.o core ratfor
Xpack:
X shar -a ${CSRC} ${HSRC} ${DOCS} ${RSRC} >RATFOR.SHAR
SHAR_EOF
if test 488 -ne "`wc -c < 'makefile'`"
then
echo shar: error transmitting "'makefile'" '(should have been 488 characters)'
fi
chmod +x 'makefile'
fi # end of overwriting check
# End of shell archive
exit 0
--
You see things, and you say "WHY?" Usenet: [decvax|ihnp4]!utzoo!yetti!oz
But I dream things that never were; ......!seismo!mnetor!yetti!oz
and say "WHY NOT?" Bitnet: oz@[yusol|yulibra|yuyetti]
[Back To Methuselah] Bernard Shaw Phonet: [416] 736-5257 x 3976
--
For comp.sources.unix stuff, mail to sources at uunet.uu.net.
More information about the Comp.sources.unix
mailing list