Ratfor in C
Ozan Yigit
oz at yetti.UUCP
Thu Jun 20 05:13:53 AEST 1985
The following is a C version of Ratfor. It is almost a direct
translation from a Ratfor in ratfor, distributed by the University
of Arizona. The code is full of peculiarities, indicative of such
a translation. The preprocessor seem to work well, but it probably
contains many bugs, some of which were discovered and fixed by
the software tools group for their own brand of ratfor. I have
used this particular pre-processor to create many other pre-processors,
including one for VMS DCL. So, if you need such a pre-processor,
and do not have fortran, or UN*X version of it, here it is !!!
Ps: I would appreciate receiving any bug fixes you may have.
Oz (whizzard of something or another, no doubt..)
Usenet: [dacvax|allegra|ihnp4|linus]!utzoo!yetti!oz
Bitnet: oz@[yuleo|yuyetti]
---------- CUT -------------------- CUT ------------------
#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# ratfor.c
# ratcom.h
# ratdef.h
# makefile
# lookup.c
# lookup.h
# This archive created: Wed Jun 19 15:01:06 1985
export PATH; PATH=/bin:$PATH
if test -f 'ratfor.c'
then
echo shar: over-writing existing file "'ratfor.c'"
fi
cat << \SHAR_EOF > 'ratfor.c'
/*
* ratfor
*
* A ratfor pre-processor in C. It is almost a direct
* translation of a pre-processor distributed by the
* University of Arizona. It closely corresponds to the
* pre-processor described in the "SOFTWARE TOOLS" book.
* It lacks the "case" construct available in the UNIX
* version of ratfor.
*
* By: Oz
* March 1984
*
*/
#include <stdio.h>
#include "ratdef.h"
#include "ratcom.h"
/* keywords: */
char sdo[3] = {
LETD,LETO,EOS};
char vdo[2] = {
LEXDO,EOS};
char sif[3] = {
LETI,LETF,EOS};
char vif[2] = {
LEXIF,EOS};
char selse[5] = {
LETE,LETL,LETS,LETE,EOS};
char velse[2] = {
LEXELSE,EOS};
char swhile[6] = {
LETW, LETH, LETI, LETL, LETE, EOS};
char vwhile[2] = {
LEXWHILE, EOS};
char sbreak[6] = {
LETB, LETR, LETE, LETA, LETK, EOS};
char vbreak[2] = {
LEXBREAK, EOS};
char snext[5] = {
LETN,LETE, LETX, LETT, EOS};
char vnext[2] = {
LEXNEXT, EOS};
char sfor[4] = {
LETF,LETO, LETR, EOS};
char vfor[2] = {
LEXFOR, EOS};
char srept[7] = {
LETR, LETE, LETP, LETE, LETA, LETT, EOS};
char vrept[2] = {
LEXREPEAT, EOS};
char suntil[6] = {
LETU, LETN, LETT, LETI, LETL, EOS};
char vuntil[2] = {
LEXUNTIL, EOS};
char sret[7] = {
LETR, LETE, LETT, LETU, LETR, LETN, EOS};
char vret[2] = {
LEXRETURN, EOS};
char sstr[7] = {
LETS, LETT, LETR, LETI, LETN, LETG, EOS};
char vstr[2] = {
LEXSTRING, EOS};
char deftyp[2] = {
DEFTYPE, EOS};
/* constant strings */
char *errmsg = "error at line ";
char *in = " in ";
char *ifnot = "if(.not.";
char *incl = "include";
char *fncn = "function";
char *def = "define";
char *bdef = "DEFINE";
char *contin = "continue";
char *rgoto = "goto ";
char *dat = "data ";
char *eoss = "EOS/";
extern char ngetch();
/* ------------------------------ */
/* M A I N L I N E & I N I T */
/* ------------------------------ */
main(argc,argv)
int argc;
char *argv[];
{
int i;
char *p;
if (argc == 1)
usage();
if ((infile[0] = fopen(argv[1], "r")) == NULL) {
fprintf(stderr,"%s: cannot open.\n",argv[1]);
exit(1);
}
if (p = argv[2])
if ((freopen(p, "w", stdout)) == NULL) {
fprintf(stderr,"%s: cannot create.\n",p);
exit(1);
}
/*
* initialise our stuff..
*
*/
outp = 0; /* output character pointer */
level = 0; /* file control */
linect[0] = 1; /* line count of first file */
fnamp = 0;
fnames[0] = EOS;
bp = -1; /* pushback buffer pointer */
fordep = 0; /* for stack */
for( i = 0; i <= 126; i++)
tabptr[i] = 0;
install(def, deftyp); /* default definitions */
install(bdef, deftyp);
fcname[0] = EOS; /* current function name */
label = 23000; /* next generated label */
parse(); /* call parser.. */
exit(1);
}
/* ------------------------------ */
/* P A R S E R */
/* ------------------------------ */
parse()
{
char lexstr[MAXTOK];
int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, token;
sp = 0;
lextyp[0] = EOF;
for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
if (token == LEXIF)
ifcode(&lab);
else if (token == LEXDO)
docode(&lab);
else if (token == LEXWHILE)
whilec(&lab);
else if (token == LEXFOR)
forcod(&lab);
else if (token == LEXREPEAT)
repcod(&lab);
else if (token == LEXDIGITS)
labelc(lexstr);
else if (token == LEXELSE) {
if (lextyp[sp] == LEXIF)
elseif(labval[sp]);
else
synerr("illegal else.");
}
if (token == LEXIF || token == LEXELSE || token == LEXWHILE
|| token == LEXFOR || token == LEXREPEAT
|| token == LEXDO || token == LEXDIGITS
|| token == LBRACE) {
sp++; /* beginning of statement */
if (sp > MAXSTACK)
baderr("stack overflow in parser.");
lextyp[sp] = token; /* stack type and value */
labval[sp] = lab;
}
else { /* end of statement - prepare to unstack */
if (token == RBRACE) {
if (lextyp[sp] == LBRACE)
sp--;
else
synerr("illegal right brace.");
}
else if (token == LEXOTHER)
otherc(lexstr);
else if (token == LEXBREAK || token == LEXNEXT)
brknxt(sp, lextyp, labval, token);
else if (token == LEXRETURN)
retcod();
else if (token == LEXSTRING)
strdcl();
token = lex(lexstr); /* peek at next token */
pbstr(lexstr);
unstak(&sp, lextyp, labval, token);
}
}
if (sp != 0)
synerr("unexpected EOF.");
}
/* ------------------------------ */
/* L E X I C A L A N A L Y S E R */
/* ------------------------------ */
/*
* alldig - return YES if str is all digits
*
*/
int
alldig(str)
char str[];
{
int i,j;
j = NO;
if (str[0] == EOS)
return(j);
for (i = 0; str[i] != EOS; i++)
if (type(str[i]) != DIGIT)
return(j);
j = YES;
return(j);
}
/*
* balpar - copy balanced paren string
*
*/
balpar()
{
char token[MAXTOK];
int t,nlpar;
if (gnbtok(token, MAXTOK) != LPAREN) {
synerr("missing left paren.");
return;
}
outstr(token);
nlpar = 1;
do {
t = gettok(token, MAXTOK);
if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
pbstr(token);
break;
}
if (t == NEWLINE) /* delete newlines */
token[0] = EOS;
else if (t == LPAREN)
nlpar++;
else if (t == RPAREN)
nlpar--;
/* else nothing special */
outstr(token);
}
while (nlpar > 0);
if (nlpar != 0)
synerr("missing parenthesis in condition.");
}
/*
* deftok - get token; process macro calls and invocations
*
*/
int
deftok(token, toksiz, fd)
char token[];
int toksiz;
FILE *fd;
{
char defn[MAXDEF];
int t;
for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
if (t != ALPHA) /* non-alpha */
break;
if (look(token, defn) == NO) /* undefined */
break;
if (defn[0] == DEFTYPE) { /* get definition */
getdef(token, toksiz, defn, MAXDEF, fd);
install(token, defn);
}
else
pbstr(defn); /* push replacement onto input */
}
if (t == ALPHA) /* convert to single case */
fold(token);
return(t);
}
/*
* eatup - process rest of statement; interpret continuations
*
*/
eatup()
{
char ptoken[MAXTOK], token[MAXTOK];
int nlpar, t;
nlpar = 0;
do {
t = gettok(token, MAXTOK);
if (t == SEMICOL || t == NEWLINE)
break;
if (t == RBRACE || t == LBRACE) {
pbstr(token);
break;
}
if (t == EOF) {
synerr("unexpected EOF.");
pbstr(token);
break;
}
if (t == COMMA || t == PLUS
|| t == MINUS || t == STAR || t == LPAREN
|| t == AND || t == BAR || t == BANG
|| t == EQUALS || t == UNDERLINE ) {
while (gettok(ptoken, MAXTOK) == NEWLINE)
;
pbstr(ptoken);
if (t == UNDERLINE)
token[0] = EOS;
}
if (t == LPAREN)
nlpar++;
else if (t == RPAREN)
nlpar--;
outstr(token);
} while (nlpar >= 0);
if (nlpar != 0)
synerr("unbalanced parentheses.");
}
/*
* getdef (for no arguments) - get name and definition
*
*/
getdef(token, toksiz, defn, defsiz, fd)
char token[];
int toksiz;
char defn[];
int defsiz;
FILE *fd;
{
int i, nlpar, t;
char c, ptoken[MAXTOK];
skpblk(fd);
/*
* define(name,defn) or
* define name defn
*
*/
if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
t = BLANK; /* define name defn */
pbstr(ptoken);
}
skpblk(fd);
if (gtok(token, toksiz, fd) != ALPHA)
baderr("non-alphanumeric name.");
skpblk(fd);
c = (char) gtok(ptoken, MAXTOK, fd);
if (t == BLANK) { /* define name defn */
pbstr(ptoken);
i = 0;
do {
c = ngetch(&c, fd);
if (i > defsiz)
baderr("definition too long.");
defn[i++] = c;
}
while (c != SHARP && c != NEWLINE && c != EOF);
if (c == SHARP)
putbak(c);
}
else if (t == LPAREN) { /* define (name, defn) */
if (c != COMMA)
baderr("missing comma in define.");
/* else got (name, */
nlpar = 0;
for (i = 0; nlpar >= 0; i++)
if (i > defsiz)
baderr("definition too long.");
else if (ngetch(&defn[i], fd) == EOF)
baderr("missing right paren.");
else if (defn[i] == LPAREN)
nlpar++;
else if (defn[i] == RPAREN)
nlpar--;
/* else normal character in defn[i] */
}
else
baderr("getdef is confused.");
defn[i-1] = EOS;
}
/*
* gettok - get token. handles file inclusion and line numbers
*
*/
int
gettok(token, toksiz)
char token[];
int toksiz;
{
int t, i;
int tok;
char name[MAXNAME];
for ( ; level >= 0; level--) {
for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
tok = deftok(token, toksiz, infile[level])) {
if (equal(token, fncn) == YES) {
skpblk(infile[level]);
t = deftok(fcname, MAXNAME, infile[level]);
pbstr(fcname);
if (t != ALPHA)
synerr("missing function name.");
putbak(BLANK);
return(tok);
}
else if (equal(token, incl) == NO)
return(tok);
for (i = 0 ;; i = strlen(name)) {
t = deftok(&name[i], MAXNAME, infile[level]);
if (t == NEWLINE || t == SEMICOL) {
pbstr(&name[i]);
break;
}
}
name[i] = EOS;
if (name[1] == SQUOTE) {
outtab();
outstr(token);
outstr(name);
outdon();
eatup();
return(tok);
}
if (level >= NFILES)
synerr("includes nested too deeply.");
else {
infile[level+1] = fopen(name, "r");
linect[level+1] = 1;
if (infile[level+1] == NULL)
synerr("can't open include.");
else {
level++;
if (fnamp + i <= MAXFNAMES) {
scopy(name, 0, fnames, fnamp);
fnamp = fnamp + i; /* push file name stack */
}
}
}
}
if (level > 0) { /* close include and pop file name stack */
fclose(infile[level]);
for (fnamp--; fnamp > 0; fnamp--)
if (fnames[fnamp-1] == EOS)
break;
}
}
token[0] = EOF; /* in case called more than once */
token[1] = EOS;
tok = EOF;
return(tok);
}
/*
* gnbtok - get nonblank token
*
*/
int
gnbtok(token, toksiz)
char token[];
int toksiz;
{
int tok;
skpblk(infile[level]);
tok = gettok(token, toksiz);
return(tok);
}
/*
* gtok - get token for Ratfor
*
*/
int
gtok(lexstr, toksiz, fd)
char lexstr[];
int toksiz;
FILE *fd;
{
int i, b, n, tok;
char c;
c = ngetch(&lexstr[0], fd);
if (c == BLANK || c == TAB) {
lexstr[0] = BLANK;
while (c == BLANK || c == TAB) /* compress many blanks to one */
c = ngetch(&c, fd);
if (c == SHARP)
while (ngetch(&c, fd) != NEWLINE) /* strip comments */
;
if (c != NEWLINE)
putbak(c);
else
lexstr[0] = NEWLINE;
lexstr[1] = EOS;
return((int)lexstr[0]);
}
i = 0;
tok = type(c);
if (tok == LETTER) { /* alpha */
for (i = 0; i < toksiz - 3; i++) {
tok = type(ngetch(&lexstr[i+1], fd));
/* Test for DOLLAR added by BM, 7-15-80 */
if (tok != LETTER && tok != DIGIT
&& tok != UNDERLINE && tok!=DOLLAR
&& tok != PERIOD)
break;
}
putbak(lexstr[i+1]);
tok = ALPHA;
}
else if (tok == DIGIT) { /* digits */
b = c - DIG0; /* in case alternate base number */
for (i = 0; i < toksiz - 3; i++) {
if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
break;
b = 10*b + lexstr[i+1] - DIG0;
}
if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {
/* n%ddd... */
for (n = 0;; n = b*n + c - DIG0) {
c = ngetch(&lexstr[0], fd);
if (c >= LETA && c <= LETZ)
c = c - LETA + DIG9 + 1;
else if (c >= BIGA && c <= BIGZ)
c = c - BIGA + DIG9 + 1;
if (c < DIG0 || c >= DIG0 + b)
break;
}
putbak(lexstr[0]);
i = itoc(n, lexstr, toksiz);
}
else
putbak(lexstr[i+1]);
tok = DIGIT;
}
#ifdef SQUAREB
else if (c == LBRACK) { /* allow [ for { */
lexstr[0] = LBRACE;
tok = LBRACE;
}
else if (c == RBRACK) { /* allow ] for } */
lexstr[0] = RBRACE;
tok = RBRACE;
}
#endif
else if (c == SQUOTE || c == DQUOTE) {
for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
if (lexstr[i] == UNDERLINE)
if (ngetch(&c, fd) == NEWLINE) {
while (c == NEWLINE || c == BLANK || c == TAB)
c = ngetch(&c, fd);
lexstr[i] = c;
}
else
putbak(c);
if (lexstr[i] == NEWLINE || i >= toksiz-1) {
synerr("missing quote.");
lexstr[i] = lexstr[0];
putbak(NEWLINE);
break;
}
}
}
else if (c == SHARP) { /* strip comments */
while (ngetch(&lexstr[0], fd) != NEWLINE)
;
tok = NEWLINE;
}
else if (c == GREATER || c == LESS || c == NOT
|| c == BANG || c == CARET || c == EQUALS
|| c == AND || c == OR)
i = relate(lexstr, fd);
if (i >= toksiz-1)
synerr("token too long.");
lexstr[i+1] = EOS;
if (lexstr[0] == NEWLINE)
linect[level] = linect[level] + 1;
return(tok);
}
/*
* lex - return lexical type of token
*
*/
int
lex(lexstr)
char lexstr[];
{
int tok;
for (tok = gnbtok(lexstr, MAXTOK);
tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
;
if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
return(tok);
if (tok == DIGIT)
tok = LEXDIGITS;
else if (equal(lexstr, sif) == YES)
tok = vif[0];
else if (equal(lexstr, selse) == YES)
tok = velse[0];
else if (equal(lexstr, swhile) == YES)
tok = vwhile[0];
else if (equal(lexstr, sdo) == YES)
tok = vdo[0];
else if (equal(lexstr, sbreak) == YES)
tok = vbreak[0];
else if (equal(lexstr, snext) == YES)
tok = vnext[0];
else if (equal(lexstr, sfor) == YES)
tok = vfor[0];
else if (equal(lexstr, srept) == YES)
tok = vrept[0];
else if (equal(lexstr, suntil) == YES)
tok = vuntil[0];
else if (equal(lexstr, sret) == YES)
tok = vret[0];
else if (equal(lexstr, sstr) == YES)
tok = vstr[0];
else
tok = LEXOTHER;
return(tok);
}
/*
* ngetch - get a (possibly pushed back) character
*
*/
char
ngetch(c, fd)
char *c;
FILE *fd;
{
if (bp >= 0) {
*c = buf[bp];
bp--;
}
else
*c = (char) getc(fd);
return(*c);
}
/*
* pbstr - push string back onto input
*
*/
pbstr(in)
char in[];
{
int i;
for (i = strlen(in) - 1; i >= 0; i--)
putbak(in[i]);
}
/*
* putbak - push char back onto input
*
*/
putbak(c)
char c;
{
bp++;
if (bp > BUFSIZE)
baderr("too many characters pushed back.");
buf[bp] = c;
}
/*
* relate - convert relational shorthands into long form
*
*/
int
relate(token, fd)
char token[];
FILE *fd;
{
if (ngetch(&token[1], fd) != EQUALS) {
putbak(token[1]);
token[2] = LETT;
}
else
token[2] = LETE;
token[3] = PERIOD;
token[4] = EOS;
token[5] = EOS; /* for .not. and .and. */
if (token[0] == GREATER)
token[1] = LETG;
else if (token[0] == LESS)
token[1] = LETL;
else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
if (token[1] != EQUALS) {
token[2] = LETO;
token[3] = LETT;
token[4] = PERIOD;
}
token[1] = LETN;
}
else if (token[0] == EQUALS) {
if (token[1] != EQUALS) {
token[2] = EOS;
return(0);
}
token[1] = LETE;
token[2] = LETQ;
}
else if (token[0] == AND) {
token[1] = LETA;
token[2] = LETN;
token[3] = LETD;
token[4] = PERIOD;
}
else if (token[0] == OR) {
token[1] = LETO;
token[2] = LETR;
}
else /* can't happen */
token[1] = EOS;
token[0] = PERIOD;
return(strlen(token)-1);
}
/*
* skpblk - skip blanks and tabs in file fd
*
*/
skpblk(fd)
FILE *fd;
{
char c;
for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
;
putbak(c);
}
/*
* type - return LETTER, DIGIT or char; works with ascii alphabet
*
*/
int
type(c)
char c;
{
int t;
if (c >= DIG0 && c <= DIG9)
t = DIGIT;
else if (c >= LETA && c <= LETZ)
t = LETTER;
else if (c >= BIGA && c <= BIGZ)
t = LETTER;
else
t = c;
return(t);
}
/* ------------------------------ */
/* C O D E G E N E R A T I O N */
/* ------------------------------ */
/*
* brknxt - generate code for break n and next n; n = 1 is default
*
*/
brknxt(sp, lextyp, labval, token)
int sp;
int lextyp[];
int labval[];
int token;
{
int i, n;
char t, ptoken[MAXTOK];
n = 0;
t = gnbtok(ptoken, MAXTOK);
if (alldig(ptoken) == YES) { /* have break n or next n */
i = 0;
n = ctoi(ptoken, &i) - 1;
}
else if (t != SEMICOL) /* default case */
pbstr(ptoken);
for (i = sp; i >= 0; i--)
if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
|| lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
if (n > 0) {
n--;
continue; /* seek proper level */
}
else if (token == LEXBREAK)
outgo(labval[i]+1);
else
outgo(labval[i]);
xfer = YES;
return;
}
if (token == LEXBREAK)
synerr("illegal break.");
else
synerr("illegal next.");
return;
}
/*
* docode - generate code for beginning of do
*
*/
docode(lab)
int *lab;
{
xfer = NO;
outtab();
outstr(sdo);
*lab = labgen(2);
outnum(*lab);
eatup();
outdon();
}
/*
* dostat - generate code for end of do statement
*
*/
dostat(lab)
int lab;
{
outcon(lab);
outcon(lab+1);
}
/*
* elseif - generate code for end of if before else
*
*/
elseif(lab)
int lab;
{
outgo(lab+1);
outcon(lab);
}
/*
* forcod - beginning of for statement
*
*/
forcod(lab)
int *lab;
{
char t, token[MAXTOK];
int i, j, nlpar,tlab;
tlab = *lab;
tlab = labgen(3);
outcon(0);
if (gnbtok(token, MAXTOK) != LPAREN) {
synerr("missing left paren.");
return;
}
if (gnbtok(token, MAXTOK) != SEMICOL) { /* real init clause */
pbstr(token);
outtab();
eatup();
outdon();
}
if (gnbtok(token, MAXTOK) == SEMICOL) /* empty condition */
outcon(tlab);
else { /* non-empty condition */
pbstr(token);
outnum(tlab);
outtab();
outstr(ifnot);
outch(LPAREN);
nlpar = 0;
while (nlpar >= 0) {
t = gettok(token, MAXTOK);
if (t == SEMICOL)
break;
if (t == LPAREN)
nlpar++;
else if (t == RPAREN)
nlpar--;
if (t == EOF) {
pbstr(token);
return;
}
if (t != NEWLINE && t != UNDERLINE)
outstr(token);
}
outch(RPAREN);
outch(RPAREN);
outgo((tlab)+2);
if (nlpar < 0)
synerr("invalid for clause.");
}
fordep++; /* stack reinit clause */
j = 0;
for (i = 1; i < fordep; i++) /* find end *** should i = 1 ??? *** */
j = j + strlen(&forstk[j]) + 1;
forstk[j] = EOS; /* null, in case no reinit */
nlpar = 0;
t = gnbtok(token, MAXTOK);
pbstr(token);
while (nlpar >= 0) {
t = gettok(token, MAXTOK);
if (t == LPAREN)
nlpar++;
else if (t == RPAREN)
nlpar--;
if (t == EOF) {
pbstr(token);
break;
}
if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
if (j + strlen(token) >= MAXFORSTK)
baderr("for clause too long.");
scopy(token, 0, forstk, j);
j = j + strlen(token);
}
}
tlab++; /* label for next's */
*lab = tlab;
}
/*
* fors - process end of for statement
*
*/
fors(lab)
int lab;
{
int i, j;
xfer = NO;
outnum(lab);
j = 0;
for (i = 1; i < fordep; i++)
j = j + strlen(&forstk[j]) + 1;
if (strlen(&forstk[j]) > 0) {
outtab();
outstr(&forstk[j]);
outdon();
}
outgo(lab-1);
outcon(lab+1);
fordep--;
}
/*
* ifcode - generate initial code for if
*
*/
ifcode(lab)
int *lab;
{
xfer = NO;
*lab = labgen(2);
ifgo(*lab);
}
/*
* ifgo - generate "if(.not.(...))goto lab"
*
*/
ifgo(lab)
int lab;
{
outtab(); /* get to column 7 */
outstr(ifnot); /* " if(.not. " */
balpar(); /* collect and output condition */
outch(RPAREN); /* " ) " */
outgo(lab); /* " goto lab " */
}
/*
* labelc - output statement number
*
*/
labelc(lexstr)
char lexstr[];
{
xfer = NO; /* can't suppress goto's now */
if (strlen(lexstr) == 5) /* warn about 23xxx labels */
if (lexstr[0] == DIG2 && lexstr[1] == DIG3)
synerr("warning: possible label conflict.");
outstr(lexstr);
outtab();
}
/*
* labgen - generate n consecutive labels, return first one
*
*/
int
labgen(n)
int n;
{
int i;
i = label;
label = label + n;
return(i);
}
/*
* otherc - output ordinary Fortran statement
*
*/
otherc(lexstr)
char lexstr[];
{
xfer = NO;
outtab();
outstr(lexstr);
eatup();
outdon();
}
/*
* outch - put one char into output buffer
*
*/
outch(c)
char c;
{
int i;
if (outp >= 72) { /* continuation card */
outdon();
/*** should output "-" for dcl continuation.. ***/
for (i = 0; i < 6; i++)
outbuf[i] = BLANK;
outp = 6;
}
outbuf[outp] = c;
outp++;
}
/*
* outcon - output "n continue"
*
*/
outcon(n)
int n;
{
xfer = NO;
if (n <= 0 && outp == 0)
return; /* don't need unlabeled continues */
if (n > 0)
outnum(n);
outtab();
outstr(contin);
outdon();
}
/*
* outdon - finish off an output line
*
*/
outdon()
{
outbuf[outp] = NEWLINE;
outbuf[outp+1] = EOS;
printf(outbuf);
outp = 0;
}
/*
* outgo - output "goto n"
*
*/
outgo(n)
int n;
{
if (xfer == YES)
return;
outtab();
outstr(rgoto);
outnum(n);
outdon();
}
/*
* outnum - output positive decimal number
*
*/
outnum(n)
int n;
{
char chars[MAXCHARS];
int i, m;
m = n;
i = -1;
do {
i++;
chars[i] = (m % 10) + DIG0;
m = m / 10;
}
while (m > 0 && i < MAXCHARS);
for ( ; i >= 0; i--)
outch(chars[i]);
}
/*
* outstr - output string
*
*/
outstr(str)
char str[];
{
int i;
for (i=0; str[i] != EOS; i++)
outch(str[i]);
}
/*
* outtab - get past column 6
*
*/
outtab()
{
while (outp < 6)
outch(BLANK);
}
/*
* repcod - generate code for beginning of repeat
*
*/
repcod(lab)
int *lab;
{
int tlab;
tlab = *lab;
outcon(0); /* in case there was a label */
tlab = labgen(3);
outcon(tlab);
*lab = ++tlab; /* label to go on next's */
}
/*
* retcod - generate code for return
*
*/
retcod()
{
char token[MAXTOK], t;
t = gnbtok(token, MAXTOK);
if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
pbstr(token);
outtab();
outstr(fcname);
outch(EQUALS);
eatup();
outdon();
}
else if (t == RBRACE)
pbstr(token);
outtab();
outstr(sret);
outdon();
xfer = YES;
}
/* strdcl - generate code for string declaration */
strdcl()
{
char t, name[MAXNAME], init[MAXTOK];
int i, len;
t = gnbtok(name, MAXNAME);
if (t != ALPHA)
synerr("missing string name.");
if (gnbtok(init, MAXTOK) != LPAREN) { /* make size same as initial value */
len = strlen(init) + 1;
if (init[1] == SQUOTE || init[1] == DQUOTE)
len = len - 2;
}
else { /* form is string name(size) init */
t = gnbtok(init, MAXTOK);
i = 0;
len = ctoi(init, &i);
if (init[i] != EOS)
synerr("invalid string size.");
if (gnbtok(init, MAXTOK) != RPAREN)
synerr("missing right paren.");
else
t = gnbtok(init, MAXTOK);
}
outtab();
/*
* outstr(int);
*/
outstr(name);
outch(LPAREN);
outnum(len);
outch(RPAREN);
outdon();
outtab();
outstr(dat);
len = strlen(init) + 1;
if (init[0] == SQUOTE || init[0] == DQUOTE) {
init[len-1] = EOS;
scopy(init, 1, init, 0);
len = len - 2;
}
for (i = 1; i <= len; i++) { /* put out variable names */
outstr(name);
outch(LPAREN);
outnum(i);
outch(RPAREN);
if (i < len)
outch(COMMA);
else
outch(SLASH);
;
}
for (i = 0; init[i] != EOS; i++) { /* put out init */
outnum(init[i]);
outch(COMMA);
}
pbstr(eoss); /* push back EOS for subsequent substitution */
}
/*
* unstak - unstack at end of statement
*
*/
unstak(sp, lextyp, labval, token)
int *sp;
int lextyp[];
int labval[];
char token;
{
int tp;
tp = *sp;
for ( ; tp > 0; tp--) {
if (lextyp[tp] == LBRACE)
break;
if (lextyp[tp] == LEXIF && token == LEXELSE)
break;
if (lextyp[tp] == LEXIF)
outcon(labval[tp]);
else if (lextyp[tp] == LEXELSE) {
if (*sp > 1)
tp--;
outcon(labval[tp]+1);
}
else if (lextyp[tp] == LEXDO)
dostat(labval[tp]);
else if (lextyp[tp] == LEXWHILE)
whiles(labval[tp]);
else if (lextyp[tp] == LEXFOR)
fors(labval[tp]);
else if (lextyp[tp] == LEXREPEAT)
untils(labval[tp], token);
}
*sp = tp;
}
/*
* untils - generate code for until or end of repeat
*
*/
untils(lab, token)
int lab;
int token;
{
char ptoken[MAXTOK];
xfer = NO;
outnum(lab);
if (token == LEXUNTIL) {
lex(ptoken);
ifgo(lab-1);
}
else
outgo(lab-1);
outcon(lab+1);
}
/*
* whilec - generate code for beginning of while
*
*/
whilec(lab)
int *lab;
{
int tlab;
tlab = *lab;
outcon(0); /* unlabeled continue, in case there was a label */
tlab = labgen(2);
outnum(tlab);
ifgo(tlab+1);
*lab = tlab;
}
/*
* whiles - generate code for end of while
*
*/
whiles(lab)
int lab;
{
outgo(lab);
outcon(lab+1);
}
/* ------------------------------ */
/* E R R O R M E S S A G E S */
/* ------------------------------ */
/*
* baderr - print error message, then die
*
*/
baderr(msg)
char msg[];
{
synerr(msg);
exit(1);
}
/*
* synerr - report Ratfor syntax error
*
*/
synerr(msg)
char msg[];
{
char lc[MAXCHARS];
int i;
fprintf(stderr,errmsg);
if (level >= 0)
i = level;
else
i = 0; /* for EOF errors */
itoc(linect[i], lc, MAXCHARS);
fprintf(stderr,lc);
for (i = fnamp - 1; i > 1; i = i - 1)
if (fnames[i-1] == EOS) { /* print file name */
fprintf(stderr,in);
fprintf(stderr,fnames[i]);
break;
}
fprintf(stderr,": \n %s\n",msg);
}
/*
* usage
*
*/
usage()
{
fprintf(stderr,"usage: ratfor <input file> [output file]\n");
exit(1);
}
/* ------------------------------ */
/* U T I L I T Y R O U T I N E S */
/* ------------------------------ */
/*
* ctoi - convert string at in[i] to int, increment i
*
*/
int
ctoi(in, i)
char in[];
int *i;
{
int k, j;
j = *i;
while (in[j] == BLANK || in[j] == TAB)
j++;
for (k = 0; in[j] != EOS; j++) {
if (in[j] < DIG0 || in[j] > DIG9)
break;
k = 10 * k + in[j] - DIG0;
}
*i = j;
return(k);
}
/*
* fold - convert alphabetic token to single case
*
*/
fold(token)
char token[];
{
int i;
/* WARNING - this routine depends heavily on the */
/* fact that letters have been mapped into internal */
/* right-adjusted ascii. god help you if you */
/* have subverted this mechanism. */
for (i = 0; token[i] != EOS; i++)
if (token[i] >= BIGA && token[i] <= BIGZ)
token[i] = token[i] - BIGA + LETA;
}
/*
* equal - compare str1 to str2; return YES if equal, NO if not
*
*/
int
equal(str1, str2)
char str1[];
char str2[];
{
int i;
for (i = 0; str1[i] == str2[i]; i++)
if (str1[i] == EOS) {
return(YES);
}
return(NO);
}
/*
* scopy - copy string at from[i] to to[j]
*
*/
scopy(from, i, to, j)
char from[];
int i;
char to[];
int j;
{
int k1, k2;
k2 = j;
for (k1 = i; from[k1] != EOS; k1++) {
to[k2] = from[k1];
k2++;
}
to[k2] = EOS;
}
#include "lookup.h"
/*
* look - look-up a definition
*
*/
int
look(name,defn)
char name[];
char defn[];
{
extern struct hashlist *lookup();
struct hashlist *p;
if ((p = lookup(name)) == NULL)
return(NO);
strcpy(defn,p->def);
return(YES);
}
/*
* itoc - special version of itoa
*
*/
int
itoc(n,str,size)
int n;
char str[];
int size;
{
int i,j,k,sign;
char c;
if ((sign = n) < 0)
n = -n;
i = 0;
do {
str[i++] = n % 10 + '0';
}
while ((n /= 10) > 0 && i < size-2);
if (sign < 0 && i < size-1)
str[i++] = '-';
str[i] = EOS;
/*
* reverse the string and plug it back in
*
*/
for (j = 0, k = strlen(str) - 1; j < k; j++, k--) {
c = str[j];
str[j] = str[k];
str[k] = c;
}
return(i-1);
}
SHAR_EOF
if test -f 'ratcom.h'
then
echo shar: over-writing existing file "'ratcom.h'"
fi
cat << \SHAR_EOF > 'ratcom.h'
int bp; /* next available char; init = 0 */
char buf[BUFSIZE]; /* pushed-back chars */
char fcname[MAXNAME]; /* text of current function name */
int fordep; /* current depth of for statements */
char forstk[MAXFORSTK]; /* stack of reinit strings */
int xfer; /* YES if just made transfer, NO otherwise */
int label; /* next label returned by labgen */
int level ; /* level of file inclusion; init = 1 */
int linect[NFILES]; /* line count on input file[level]; init = 1 */
FILE *infile[NFILES]; /* file number[level]; init infile[1] = STDIN */
int fnamp; /* next free slot in fnames; init = 2 */
char fnames[MAXFNAMES]; /* stack of include names; init fnames[1] = EOS */
int avail; /* first first location in table; init = 1 */
int tabptr[127]; /* name pointers; init = 0 */
int outp; /* last position filled in outbuf; init = 0 */
char outbuf[74]; /* output lines collected here */
char fname[MAXNAME][NFILES]; /* file names */
int nfiles; /* number of files */
SHAR_EOF
if test -f 'ratdef.h'
then
echo shar: over-writing existing file "'ratdef.h'"
fi
cat << \SHAR_EOF > 'ratdef.h'
#define ACCENT 96
#define AND 38
#define APPEND
#define ATSIGN 64
#define BACKSLASH 92
#define BACKSPACE 8
#define BANG 33
#define BAR 124
#define BIGA 65
#define BIGB 66
#define BIGC 67
#define BIGD 68
#define BIGE 69
#define BIGF 70
#define BIGG 71
#define BIGH 72
#define BIGI 73
#define BIGJ 74
#define BIGK 75
#define BIGL 76
#define BIGM 77
#define BIGN 78
#define BIGO 79
#define BIGP 80
#define BIGQ 81
#define BIGR 82
#define BIGS 83
#define BIGT 84
#define BIGU 85
#define BIGV 86
#define BIGW 87
#define BIGX 88
#define BIGY 89
#define BIGZ 90
#define BLANK 32
#define CARET 94
#define COLON 58
#define COMMA 44
#define CRLF 13
#define DIG0 48
#define DIG1 49
#define DIG2 50
#define DIG3 51
#define DIG4 52
#define DIG5 53
#define DIG6 54
#define DIG7 55
#define DIG8 56
#define DIG9 57
#define DOLLAR 36
#define DQUOTE 34
#define EOS 0
#define EQUALS 61
#define ESCAPE ATSIGN
#define GREATER 62
#define HUGE 30000
#define LBRACE 123
#define LBRACK 91
#define LESS 60
#define LETA 97
#define LETB 98
#define LETC 99
#define LETD 100
#define LETE 101
#define LETF 102
#define LETG 103
#define LETH 104
#define LETI 105
#define LETJ 106
#define LETK 107
#define LETL 108
#define LETM 109
#define LETN 110
#define LETO 111
#define LETP 112
#define LETQ 113
#define LETR 114
#define LETS 115
#define LETT 116
#define LETU 117
#define LETV 118
#define LETW 119
#define LETX 120
#define LETY 121
#define LETZ 122
#define LPAREN 40
#define MINUS 45
#define NEWLINE 10
#define NO 0
#define NOT 126
#define OR BAR /* same as | */
#define PERCENT 37
#define PERIOD 46
#define PLUS 43
#define QMARK 63
#define RBRACE 125
#define RBRACK 93
#define RPAREN 41
#define SEMICOL 59
#define SHARP 35
#define SLASH 47
#define SQUOTE 39
#define STAR 42
#define TAB 9
#define TILDE 126
#define UNDERLINE 95
#define YES 1
#define LIMIT 134217728
#define LIM1 28
#define LIM2 -28
/*
* lexical analyser symbols
*
*/
#define LETTER 1
#define DIGIT 2
#define ALPHA 3
#define LEXBREAK 4
#define LEXDIGITS 5
#define LEXDO 6
#define LEXELSE 7
#define LEXFOR 8
#define LEXIF 9
#define LEXNEXT 10
#define LEXOTHER 11
#define LEXREPEAT 12
#define LEXUNTIL 13
#define LEXWHILE 14
#define LEXRETURN 15
#define LEXEND 16
#define LEXSTOP 17
#define LEXSTRING 18
#define DEFTYPE 19
#define MAXCHARS 10 /* characters for outnum */
#define MAXDEF 200 /* max chars in a defn */
#define MAXFORSTK 200 /* max space for for reinit clauses */
#define MAXFNAMES 350 /* max chars in filename stack NFILES*MAXNAME */
#define MAXNAME 64 /* file name size in gettok */
#define MAXSTACK 100 /* max stack depth for parser */
#define MAXTBL 15000 /* max chars in all definitions */
#define MAXTOK 132 /* max chars in a token */
#define NFILES 7 /* max depth of file inclusion */
#define RADIX PERCENT /* % indicates alternate radix */
#define BUFSIZE 300 /* pushback buffer for ngetch and putbak */
SHAR_EOF
if test -f 'makefile'
then
echo shar: over-writing existing file "'makefile'"
fi
cat << \SHAR_EOF > 'makefile'
CFLAGS = -O
ratfor: ratfor.o lookup.o
cc -o ratfor ratfor.o lookup.o
ratfor.o: ratdef.h ratcom.h
lookup.o: lookup.h
clean:
rm -f *.o core ratfor
SHAR_EOF
if test -f 'lookup.c'
then
echo shar: over-writing existing file "'lookup.c'"
fi
cat << \SHAR_EOF > 'lookup.c'
#include <stdio.h>
#include "lookup.h"
static
struct hashlist *hashtab[HASHMAX];
/*
* from K&R "The C Programming language"
* Table lookup routines
*
* hash - for a hash value for string s
*
*/
hash(s)
char *s;
{
int hashval;
for (hashval = 0; *s != '\0';)
hashval += *s++;
return (hashval % HASHMAX);
}
/*
* lookup - lookup for a string s in the hash table
*
*/
struct hashlist
*lookup(s)
char *s;
{
struct hashlist *np;
for (np = hashtab[hash(s)]; np != NULL; np = np->next)
if (strcmp(s, np->name) == 0)
return(np); /* found */
return(NULL); /* not found */
}
/*
* install - install a string name in hashtable and its value def
*
*/
struct hashlist
*install(name,def)
char *name;
char *def;
{
int hashval;
struct hashlist *np, *lookup();
char *strsave(), *malloc();
if ((np = lookup(name)) == NULL) { /* not found.. */
np = (struct hashlist *) malloc(sizeof(*np));
if (np == NULL)
return(NULL);
if ((np->name = strsave(name)) == NULL)
return(NULL);
hashval = hash(np->name);
np->next = hashtab[hashval];
hashtab[hashval] = np;
} else /* found.. */
free(np->def); /* free prev. */
if ((np->def = strsave(def)) == NULL)
return(NULL);
return(np);
}
/*
* strsave - save string s somewhere
*
*/
char
*strsave(s)
char *s;
{
char *p, *malloc();
if ((p = malloc(strlen(s)+1)) != NULL)
strcpy(p, s);
return(p);
}
SHAR_EOF
if test -f 'lookup.h'
then
echo shar: over-writing existing file "'lookup.h'"
fi
cat << \SHAR_EOF > 'lookup.h'
/*
* from K&R "The C Programming language"
* Table lookup routines
* structure and definitions
*
*/
/* basic table entry */
struct hashlist {
char *name;
char *def;
struct hashlist *next; /* next in chain */
};
#define HASHMAX 100 /* size of hashtable */
/* hash table itself */
SHAR_EOF
# End of shell archive
exit 0
More information about the Comp.sources.unix
mailing list