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