Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Posting-Version: version B 2.10.2 9/5/84; site yetti.UUCP Path: utzoo!utcs!mnetor!yetti!oz From: oz@yetti.UUCP (Ozan Yigit) Newsgroups: net.sources Subject: Ratfor in C Message-ID: <199@yetti.UUCP> Date: Wed, 19-Jun-85 15:13:53 EDT Article-I.D.: yetti.199 Posted: Wed Jun 19 15:13:53 1985 Date-Received: Wed, 19-Jun-85 18:42:33 EDT Reply-To: oz@yetti.UUCP (Ozan Yigit) Organization: York University Computer Science Lines: 1898 Keywords: ratfor 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 #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 [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 #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