ratfor-1.0.orig/ 42775 0 0 0 6460707141 11601 5ustar rootrootratfor-1.0.orig/BUGS100644 0 0 734 6251464103 12335 0ustar rootrootThis is not a bug but a design error in both AT&T ratfor and this public domain ratfor: The problem is with the switch statment. It switches on an integer valued expression. It should switch on an integer variable. The reason is that "implicit undefined" "implicit null" is unusable because the switch is done on a new variable that is not declared or declarable by the programmer who cannot guess its name. Please let me know if you fix this. jon@sep.stanford.edu.us ratfor-1.0.orig/GNUmakefile100644 0 0 2171 6251464103 13741 0ustar rootroot# #DEBUG := yes # pd ratfor77 (oz) # # if F77 is defined, the output # of ratfor is Fortran 77. # # On sun4, use S_CHAR="char" # On RS6000, use S_CHAR="signed char" # On DEC3100, maybe use S_CHAR="signed char" # On CRAY, use S_CHAR="char" # On GNU, use S_CHAR="char" # # Default definition of the makefile include files # If you have kept the whole distribution together you won't need to set # this yourself. If you have just taken a few directories you should set # the envionment variable "MAKEINC" to point at the config directory. # ifndef MAKEINC MAKEINC := ./../../config endif # include $(MAKEINC)/Makefile.SEP.defs # we don't want the standard SEP flags so override them ifeq ($(GNU),yes) CFLAGS := -c -DF77 -DS_CHAR=$(SIGNED_CHAR) -DGNU else CFLAGS := -c -DF77 -DS_CHAR=$(SIGNED_CHAR) endif all: $(SEPBINDIR)/ratfor77 @echo "making all in ratfor77 : done" # deinstall: $(RM) $(SEPBINDIR)/ratfor77 @echo "deinstall in ratfor77 : done" # $(SEPBINDIR)/ratfor77: $(addprefix $(MACHINETYPE)/, rat4.o lookup.o getopt.o ) $(link.c) $(INSTALL) $(INSTALLBIN) $(MACHINETYPE)/a.out $@ include $(MAKEINC)/Makefile.rules ratfor-1.0.orig/README100644 0 0 1340 6251464103 12544 0ustar rootroot This is a C version of ratfor, derived from a UofA ratfor in ratfor. It was originally released to the net sometime ago, and It is re-released for the benefit of those sites who only get mod->comp.sources. It now includes minor changes to produce F77 code as well. This code *is* PD. You (public) have all the rights to the code. [But this also means you (singular) do not have any *extra* rights to the code, hence it is impossible for you to restrict the use and distribution of this code in any way.] I would, as usual, appreciate hearing about bug fixes and improvements. oz Usenet: [decvax|ihnp4]!utzoo!yetti!oz || ...seismo!mnetor!yetti!oz Bitnet: oz@[yusol|yuyetti].BITNET Phonet: [416] 736-5257 x 3976 ratfor-1.0.orig/getopt.c100644 0 0 1744 6251464103 13342 0ustar rootroot/* * getopt - get option letter from argv */ #include #include char *optarg; /* Global argument pointer. */ int optind77 = 0; /* Global argv index. */ static char *scan = NULL; /* Private scan pointer. */ int our_getopt(argc, argv, optstring) int argc; char *argv[]; char *optstring; { register char c; register char *place; optarg = NULL; if (scan == NULL || *scan == '\0') { if (optind77 == 0) optind77++; if (optind77 >= argc || argv[optind77][0] != '-' || argv[optind77][1] == '\0') return(EOF); if (strcmp(argv[optind77], "--")==0) { optind77++; return(EOF); } scan = argv[optind77]+1; optind77++; } c = *scan++; place = strchr(optstring, (int) c); if (place == NULL || c == ':') { fprintf(stderr, "%s: unknown option -%c\n", argv[0], c); return('?'); } place++; if (*place == ':') { if (*scan != '\0') { optarg = scan; scan = NULL; } else { optarg = argv[optind77]; optind77++; } } return(c); } ratfor-1.0.orig/lookup.c100644 0 0 2604 6251464103 13345 0ustar rootroot#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) 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) 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) S_CHAR *name; S_CHAR *def; { int hashval; struct hashlist *np, *lookup(); S_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 * */ S_CHAR *strsave(s) S_CHAR *s; { S_CHAR *p, *malloc(); if ((p = malloc(strlen(s)+1)) != NULL) strcpy(p, s); return(p); } ratfor-1.0.orig/lookup.h100644 0 0 470 6251464103 13331 0ustar rootroot /* * from K&R "The C Programming language" * Table lookup routines * structure and definitions * */ /* basic table entry */ struct hashlist { S_CHAR *name; S_CHAR *def; struct hashlist *next; /* next in chain */ }; #define HASHMAX 100 /* size of hashtable */ /* hash table itself */ ratfor-1.0.orig/rat4.c100644 0 0 110547 6251464103 12754 0ustar rootroot/* * ratfor - A ratfor pre-processor in C. * Derived from a pre-processor distributed by the * University of Arizona. Closely corresponds to the * pre-processor described in the "SOFTWARE TOOLS" book. * * By: oz * * Not deived from AT&T code. * * This code is in the public domain. In other words, all rights * are granted to all recipients, "public" at large. * * Modification history: * * June 1985 * - Ken Yap's mods for F77 output. Currently * available thru #define F77. * - Two minor bug-fixes for sane output. * June 1985 * - Improve front-end with getopt(). * User may specify -l n for starting label. * - Retrofit switch statement handling. This code * is borrowed from the SWTOOLS Ratfor. * * 05-28-91 W. Bauske IBM * - ported to RS/6000 * - fixed line continuations * - added -C option to leave comments in the source code * - added % in column 1 to force copy to output * - support both && and & for .and. * - support both || and | for .or. * */ #include #if defined __stdc__ || defined __STDC__ #include #endif #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}; #ifdef F77 char sthen[5] = { LETT,LETH,LETE,LETN,EOS}; char sendif[6] = { LETE,LETN,LETD,LETI,LETF,EOS}; #endif /* F77 */ char swhile[6] = { LETW, LETH, LETI, LETL, LETE, EOS}; char vwhile[2] = { LEXWHILE, EOS}; char ssbreak[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 sswitch[7] = { LETS, LETW, LETI, LETT, LETC, LETH, EOS}; char vswitch[2] = { LEXSWITCH, EOS}; char scase[5] = { LETC, LETA, LETS, LETE, EOS}; char vcase[2] = { LEXCASE, EOS}; char sdefault[8] = { LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS}; char vdefault[2] = { LEXDEFAULT, 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 S_CHAR ngetch(); char *progname; int startlab = 23000; /* default start label */ int leaveC = NO; /* Flag for handling comments */ /* * M A I N L I N E & I N I T */ main(argc,argv) int argc; char *argv[]; { int c, errflg = 0; extern int optind77; extern char *optarg; progname = argv[0]; while ((c=our_getopt(argc, argv, "Chn:o:6:")) != EOF) switch (c) { case 'C': leaveC = YES; /* keep comments in src */ break; case 'h': /* not written yet */ break; case 'l': /* user sets label */ startlab = atoi(optarg); break; case 'o': if ((freopen(optarg, "w", stdout)) == NULL) error("can't write %s\n", optarg); break; case '6': /* not written yet */ break; default: ++errflg; } if (errflg) { fprintf(stderr, "usage: %s [-C][-hx][-l n][-o file][-6x] [file...]\n",progname); exit(1); } /* * present version can only process one file, sadly. */ if (optind77 >= argc) infile[0] = stdin; else if ((infile[0] = fopen(argv[optind77], "r")) == NULL) error("cannot read %s\n", argv[optind77]); initvars(); parse(); /* call parser.. */ exit(0); } /* * initialise */ initvars() { int i; 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 */ swtop = 0; /* switch stack index */ swlast = 1; /* switch stack index */ for( i = 0; i <= 126; i++) tabptr[i] = 0; install(def, deftyp); /* default definitions */ install(bdef, deftyp); fcname[0] = EOS; /* current function name */ label = startlab; /* next generated label */ printf("C Output from Public domain Ratfor, version 1.0\n"); } /* * P A R S E R */ parse() { S_CHAR lexstr[MAXTOK]; int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, i, 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 == LEXSWITCH) swcode(&lab); else if (token == LEXCASE || token == LEXDEFAULT) { for (i = sp; i >= 0; i--) if (lextyp[i] == LEXSWITCH) break; if (i < 0) synerr("illegal case of default."); else cascod(labval[i], token); } 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 == LEXSWITCH || 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 if (token != LEXCASE && token != LEXDEFAULT) { /* * end of statement - prepare to unstack */ if (token == RBRACE) { if (lextyp[sp] == LBRACE) sp--; else if (lextyp[sp] == LEXSWITCH) { swend(labval[sp]); 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) S_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() { S_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) S_CHAR token[]; int toksiz; FILE *fd; { S_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() { S_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) S_CHAR token[]; int toksiz; S_CHAR defn[]; int defsiz; FILE *fd; { int i, nlpar, t; S_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 = (S_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 != (S_CHAR)EOF && c != PERCENT); if (c == SHARP || c == PERCENT) 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) == (S_CHAR)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) S_CHAR token[]; int toksiz; { int t, i; int tok; S_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((char *) (&name[0]))) { t = deftok(&name[i], MAXNAME, infile[level]); if (t == NEWLINE || t == SEMICOL) { pbstr(&name[i]); break; } } name[i] = EOS; /*WSB 6-25-91 if (name[1] == SQUOTE) { outtab(); outstr(token); outstr(name); outdon(); eatup(); return(tok); } */ if (level >= NFILES) synerr("includes nested too deeply."); else { /**/ name[i-1]=EOS; infile[level+1] = fopen((char*)&name[2], "r"); /*WSB 6-25-91 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) S_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) S_CHAR lexstr[]; int toksiz; FILE *fd; { int i, b, n, tok; S_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 == PERCENT) { outasis(fd); /* copy direct to output if % */ c = NEWLINE; } if (c == SHARP) { if(leaveC == YES) { outcmnt(fd); /* copy comments to output */ c = NEWLINE; } else while (ngetch(&c, fd) != NEWLINE) /* strip comments */ ; } /* if (c == UNDERLINE) if(ngetch(&c, fd) == NEWLINE) while(ngetch(&c, fd) == NEWLINE) ; else { putbak(c); c = UNDERLINE; } */ 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 == PERCENT) { outasis(fd); /* direct copy of protected */ tok = NEWLINE; } else if (c == SHARP) { if(leaveC == YES) outcmnt(fd); /* copy comments to output */ else while (ngetch(&lexstr[0], fd) != NEWLINE) /* strip comments */ ; 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; #if defined(CRAY) || defined(GNU) /* cray cannot compare char and ints, since EOF is an int we check with feof */ if (feof(fd)) tok = EOF; #endif return(tok); } /* * lex - return lexical type of token * */ int lex(lexstr) S_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, ssbreak) == 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, sswitch) == YES) tok = vswitch[0]; else if (equal(lexstr, scase) == YES) tok = vcase[0]; else if (equal(lexstr, sdefault) == YES) tok = vdefault[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 * */ S_CHAR ngetch(c, fd) S_CHAR *c; FILE *fd; { if (bp >= 0) { *c = buf[bp]; bp--; } else *c = (S_CHAR) getc(fd); /* * check for a continuation '_\n' * also removes UNDERLINES from * variable names */ while ( *c == UNDERLINE) { if (bp >= 0) { *c = buf[bp]; bp--; } else *c = (S_CHAR) getc(fd); if (*c != NEWLINE) { putbak(*c); *c=UNDERLINE; break; } else { while(*c == NEWLINE) { if (bp >= 0) { *c = buf[bp]; bp--; } else *c = (S_CHAR) getc(fd); } } } return(*c); } /* * pbstr - push string back onto input * */ pbstr(in) S_CHAR in[]; { int i; for (i = strlen((char *) (&in[0])) - 1; i >= 0; i--) putbak(in[i]); } /* * putbak - push char back onto input * */ putbak(c) S_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) S_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) { /* look for && or & */ if (ngetch(&token[1], fd) != AND) putbak(token[1]); token[1] = LETA; token[2] = LETN; token[3] = LETD; token[4] = PERIOD; } else if (token[0] == OR) { if (ngetch(&token[1], fd) != OR) /* look for || or | */ putbak(token[1]); token[1] = LETO; token[2] = LETR; } else /* can't happen */ token[1] = EOS; token[0] = PERIOD; return(strlen((char *) (&token[0]))-1); } /* * skpblk - skip blanks and tabs in file fd * */ skpblk(fd) FILE *fd; { S_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) S_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; S_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]); /* original value xfer = YES; */ xfer = NO; 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; { #ifdef F77 outtab(); outstr(selse); outdon(); #else outgo(lab+1); outcon(lab); #endif /* F77 */ } /* * forcod - beginning of for statement * */ forcod(lab) int *lab; { S_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 == (S_CHAR)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((char *) (&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 == (S_CHAR)EOF) { pbstr(token); break; } if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) { if ((j + ((int) strlen((char *) (&token[0])))) >= ((int) MAXFORSTK)) baderr("for clause too long."); scopy(token, 0, forstk, j); j = j + strlen((char *) (&token[0])); } } 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((char *) (&forstk[j])) + 1; if (((int) strlen((char *) (&forstk[j]))) > ((int) 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); #ifdef F77 ifthen(); #else ifgo(*lab); #endif /* F77 */ } #ifdef F77 /* * ifend - generate code for end of if * */ ifend() { outtab(); outstr(sendif); outdon(); } #endif /* F77 */ /* * 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 " */ } #ifdef F77 /* * ifthen - generate "if((...))then" * */ ifthen() { outtab(); outstr(sif); balpar(); outstr(sthen); outdon(); } #endif /* F77 */ /* * labelc - output statement number * */ labelc(lexstr) S_CHAR lexstr[]; { xfer = NO; /* can't suppress goto's now */ if (strlen((char *) (&lexstr[0])) == 5) /* warn about 23xxx labels */ if (atoi((char*)lexstr) >= startlab) 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) S_CHAR lexstr[]; { xfer = NO; outtab(); outstr(lexstr); eatup(); outdon(); } /* * outch - put one char into output buffer * */ outch(c) S_CHAR c; { int i; if (outp >= 72) { /* continuation card */ outdon(); for (i = 0; i < 6; i++) outbuf[i] = BLANK; outbuf[5]='*'; 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("%s", outbuf); outp = 0; } /* * outcmnt - copy comment to output * */ outcmnt(fd) FILE * fd; { S_CHAR c; S_CHAR comout[81]; int i, comoutp=0; comoutp=1; comout[0]='C'; while((c=ngetch(&c,fd)) != NEWLINE) { if (comoutp > 79) { comout[80]=NEWLINE; comout[81]=EOS; printf("%s",comout); comoutp=0; comout[comoutp]='C'; comoutp++; } comout[comoutp]=c; comoutp++; } comout[comoutp]=NEWLINE; comout[comoutp+1]=EOS; printf("%s",comout); } /* * outasis - copy directly out * */ outasis(fd) FILE * fd; { S_CHAR c; while((c=ngetch(&c,fd)) != NEWLINE) outch(c); outdon(); } /* * outgo - output "goto n" * */ outgo(n) int n; { if (xfer == YES) return; outtab(); outstr(rgoto); outnum(n); outdon(); } /* * outnum - output decimal number * */ outnum(n) int n; { S_CHAR chars[MAXCHARS]; int i, m; m = abs(n); i = -1; do { i++; chars[i] = (m % 10) + DIG0; m = m / 10; } while (m > 0 && i < MAXCHARS); if (n < 0) outch(MINUS); for ( ; i >= 0; i--) outch(chars[i]); } /* * outstr - output string * */ outstr(str) S_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() { S_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() { S_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((char *) (&init[0])) + 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((char *)(&init[0])) + 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[]; S_CHAR token; { int tp; tp = *sp; for ( ; tp > 0; tp--) { if (lextyp[tp] == LBRACE) break; if (lextyp[tp] == LEXSWITCH) break; if (lextyp[tp] == LEXIF && token == LEXELSE) break; if (lextyp[tp] == LEXIF) #ifdef F77 ifend(); #else outcon(labval[tp]); #endif /* F77 */ else if (lextyp[tp] == LEXELSE) { if (*sp > 1) tp--; #ifdef F77 ifend(); #else outcon(labval[tp]+1); #endif /* F77 */ } 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; { S_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); #ifdef F77 ifthen(); #else ifgo(tlab+1); #endif /* F77 */ *lab = tlab; } /* * whiles - generate code for end of while * */ whiles(lab) int lab; { outgo(lab); #ifdef F77 ifend(); #endif /* F77 */ outcon(lab+1); } /* * E R R O R M E S S A G E S */ /* * baderr - print error message, then die */ baderr(msg) S_CHAR msg[]; { synerr(msg); exit(1); } /* * error - print error message with one parameter, then die */ error(msg, s) char *msg; S_CHAR *s; { fprintf(stderr, msg,s); exit(1); } /* * synerr - report Ratfor syntax error */ synerr(msg) S_CHAR *msg; { S_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,(char*)lc); for (i = fnamp - 1; i > 1; i = i - 1) if (fnames[i-1] == EOS) { /* print file name */ fprintf(stderr,in); fprintf(stderr,(char*)&fnames[i]); break; } fprintf(stderr,": \n %s\n",msg); } /* * 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) S_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) S_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) S_CHAR str1[]; S_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) S_CHAR from[]; int i; S_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) S_CHAR name[]; S_CHAR defn[]; { extern struct hashlist *lookup(); struct hashlist *p; if ((p = lookup(name)) == NULL) return(NO); (void) strcpy((char *) (&defn[0]),(char *) (&((p->def)[0]))); return(YES); } /* * itoc - special version of itoa */ int itoc(n,str,size) int n; S_CHAR str[]; int size; { int i,j,k,sign; S_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((char *) (&str[0])) - 1; j < k; j++, k--) { c = str[j]; str[j] = str[k]; str[k] = c; } return(i-1); } /* * cascod - generate code for case or default label * */ cascod (lab, token) int lab; int token; { int t, l, lb, ub, i, j, junk; S_CHAR scrtok[MAXTOK]; if (swtop <= 0) { synerr ("illegal case or default."); return; } outgo(lab + 1); /* # terminate previous case */ xfer = YES; l = labgen(1); if (token == LEXCASE) { /* # case n[,n]... : ... */ while (caslab (&lb, &t) != EOF) { ub = lb; if (t == MINUS) junk = caslab (&ub, &t); if (lb > ub) { synerr ("illegal range in case label."); ub = lb; } if (swlast + 3 > MAXSWITCH) baderr ("switch table overflow."); for (i = swtop + 3; i < swlast; i = i + 3) if (lb <= swstak[i]) break; else if (lb <= swstak[i+1]) synerr ("duplicate case label."); if (i < swlast && ub >= swstak[i]) synerr ("duplicate case label."); for (j = swlast; j > i; j--) /* # insert new entry */ swstak[j+2] = swstak[j-1]; swstak[i] = lb; swstak[i + 1] = ub; swstak[i + 2] = l; swstak[swtop + 1] = swstak[swtop + 1] + 1; swlast = swlast + 3; if (t == COLON) break; else if (t != COMMA) synerr ("illegal case syntax."); } } else { /* # default : ... */ t = gnbtok (scrtok, MAXTOK); if (swstak[swtop + 2] != 0) baderr ("multiple defaults in switch statement."); else swstak[swtop + 2] = l; } if (t == EOF) synerr ("unexpected EOF."); else if (t != COLON) baderr ("missing colon in case or default label."); xfer = NO; outcon (l); } /* * caslab - get one case label * */ int caslab (n, t) int *n; int *t; { S_CHAR tok[MAXTOK]; int i, s; *t = gnbtok (tok, MAXTOK); while (*t == NEWLINE) *t = gnbtok (tok, MAXTOK); if (*t == EOF) return (*t); if (*t == MINUS) s = -1; else s = 1; if (*t == MINUS || *t == PLUS) *t = gnbtok (tok, MAXTOK); if (*t != DIGIT) { synerr ("invalid case label."); *n = 0; } else { i = 0; *n = s * ctoi (tok, &i); } *t = gnbtok (tok, MAXTOK); while (*t == NEWLINE) *t = gnbtok (tok, MAXTOK); } /* * swcode - generate code for switch stmt. * */ swcode (lab) int *lab; { S_CHAR scrtok[MAXTOK]; *lab = labgen (2); if (swlast + 3 > MAXSWITCH) baderr ("switch table overflow."); swstak[swlast] = swtop; swstak[swlast + 1] = 0; swstak[swlast + 2] = 0; swtop = swlast; swlast = swlast + 3; xfer = NO; outtab(); /* # Innn=(e) */ swvar(*lab); outch(EQUALS); balpar(); outdon(); outgo(*lab); /* # goto L */ xfer = YES; while (gnbtok (scrtok, MAXTOK) == NEWLINE) ; if (scrtok[0] != LBRACE) { synerr ("missing left brace in switch statement."); pbstr (scrtok); } } /* * swend - finish off switch statement; generate dispatch code * */ swend(lab) int lab; { int lb, ub, n, i, j; static char *sif = "if ("; static char *slt = ".lt.1.or."; static char *sgt = ".gt."; static char *sgoto = "goto ("; static char *seq = ".eq."; static char *sge = ".ge."; static char *sle = ".le."; static char *sand = ".and."; lb = swstak[swtop + 3]; ub = swstak[swlast - 2]; n = swstak[swtop + 1]; outgo(lab + 1); /* # terminate last case */ if (swstak[swtop + 2] == 0) swstak[swtop + 2] = lab + 1; /* # default default label */ xfer = NO; outcon (lab); /* L continue */ /* output branch table */ /* if (n >= CUTOFF && ub - lb < DENSITY * n) { if (lb != 0) { * L Innn=Innn-lb * outtab(); swvar (lab); outch (EQUALS); swvar (lab); if (lb < 0) outch (PLUS); outnum (-lb + 1); outdon(); } outtab(); * if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default * outstr (sif); swvar (lab); outstr (slt); swvar (lab); outstr (sgt); outnum (ub - lb + 1); outch (RPAREN); outgo (swstak[swtop + 2]); outtab(); outstr (sgoto); * goto ... * j = lb; for (i = swtop + 3; i < swlast; i = i + 3) { * # fill in vacancies * for ( ; j < swstak[i]; j++) { outnum(swstak[swtop + 2]); outch(COMMA); } for (j = swstak[i + 1] - swstak[i]; j >= 0; j--) outnum(swstak[i + 2]); * # fill in range * j = swstak[i + 1] + 1; if (i < swlast - 3) outch(COMMA); } outch(RPAREN); outch(COMMA); swvar(lab); outdon(); } else if (n > 0) { * # output linear search form * */ if (n > 0) { /* # output linear search form */ for (i = swtop + 3; i < swlast; i = i + 3) { outtab(); /* # if (Innn */ outstr (sif); swvar (lab); if (swstak[i] == swstak[i+1]) { outstr (seq); /* # .eq....*/ outnum (swstak[i]); } else { outstr (sge); /* # .ge.lb.and.Innn.le.ub */ outnum (swstak[i]); outstr (sand); swvar (lab); outstr (sle); outnum (swstak[i + 1]); } outch (RPAREN); /* # ) goto ... */ outgo (swstak[i + 2]); } if (lab + 1 != swstak[swtop + 2]) outgo (swstak[swtop + 2]); } outcon (lab + 1); /* # L+1 continue */ swlast = swtop; /* # pop switch stack */ swtop = swstak[swtop]; } /* * swvar - output switch variable Innn, where nnn = lab */ swvar (lab) int lab; { outch ('I'); outnum (lab); } ratfor-1.0.orig/ratcom.h100644 0 0 2302 6251464103 13321 0ustar rootrootint bp; /* next available char; init = 0 */ S_CHAR buf[BUFSIZE]; /* pushed-back chars */ S_CHAR fcname[MAXNAME]; /* text of current function name */ int fordep; /* current depth of for statements */ S_CHAR forstk[MAXFORSTK]; /* stack of reinit strings */ int swtop; /* current switch entry; init=0 */ int swlast; /* next available position; init=1 */ int swstak[MAXSWITCH]; /* switch information stack */ int xfer; /* YES if just made transfer, NO otherwise */ int label; /* next label returned by labgen */ int level ; /* level of file inclusion; init = 1 */ int linect[NFILES]; /* line count on input file[level]; init = 1 */ FILE *infile[NFILES]; /* file number[level]; init infile[1] = STDIN */ int fnamp; /* next free slot in fnames; init = 2 */ S_CHAR fnames[MAXFNAMES]; /* stack of include names; init fnames[1] = EOS */ int avail; /* first first location in table; init = 1 */ int tabptr[127]; /* name pointers; init = 0 */ int outp; /* last position filled in outbuf; init = 0 */ S_CHAR outbuf[82]; /* output lines collected here */ S_CHAR fname[MAXNAME][NFILES]; /* file names */ int nfiles; /* number of files */ ratfor-1.0.orig/ratdef.h100644 0 0 6765 6251464103 13322 0ustar rootroot#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 LEXSWITCH 19 #define LEXCASE 20 #define LEXDEFAULT 21 #define DEFTYPE 22 #define MAXCHARS 10 /* characters for outnum */ #define MAXDEF 200 /* max chars in a defn */ #define MAXSWITCH 300 /* max stack for switch statement */ #define CUTOFF 3 /* min number of cases necessary to generate */ /* a dispatch table */ #define DENSITY 2 #define MAXFORSTK 200 /* max space for for reinit clauses */ #define MAXFNAMES 350 /* max chars in filename stack NFILES*MAXNAME */ #define MAXNAME 64 /* file name size in gettok */ #define MAXSTACK 100 /* max stack depth for parser */ #define MAXTBL 15000 /* max chars in all definitions */ #define MAXTOK 132 /* max chars in a token */ #define NFILES 7 /* max depth of file inclusion */ #define RADIX PERCENT /* % indicates alternate radix */ #define BUFSIZE 300 /* pushback buffer for ngetch and putbak */ ratfor-1.0.orig/ratfor.man100644 0 0 5155 6251464103 13666 0ustar rootrootNAME ratfor77 - ratfor preprocessor for fortran77 SYNOPSIS ratfor [-l n] [-C] [-o output] input PARAMETERS -l n user sets strating label n -o output specify output file, otherwise it is stdout -C keep comments in (useful for compiler directives) DESCRIPTION Ratfor has the following syntax: prog: stat prog stat stat: if (...) stat if (...) stat else stat while (...) stat repeat stat repeat stat until (...) for (...;...;...) stat do ... stat switch (intexpr) { case val[,val]: stmt ... default: stmt } break n next n return (...) digits stat { prog } or [ prog ] or $( prog $) anything unrecognizable where stat is any Fortran or Ratfor statement, and intexpr is an expression that resolves into an integer value. A statement is terminated by an end-of-line or a semicolon. The following translations are also performed. < .lt. <= .le. == .eq. != .ne. ^= .ne. ~= .ne. >= .ge. > .gt. | .or. & .and. ! .not. ^ .not. ~ .not. Integer constants in bases other that decimal may be specified as n%dddd... where n is a decimal number indicating the base and dddd... are digits in that base. For bases > 10, letters are used for digits above 9. Examples: 8%77, 16%2ff, 2%0010011. The number is converted the equivalent decimal value using multiplication; this may cause sign problems if the number has too many digits. String literals ("..." or '...') can be continued across line boundaries by ending the line to be continued with an underline. The underline is not included as part of the literal. Leading blanks and tabs on the next line are ignored; this facilitates consistent indentation. include file will include the named file in the input. define (name,value) or define name value defines name as a symbolic parameter with the indicated value. Names of symbolic parameters may contain letters, digits, periods, and underline character but must begin with a letter (e.g. B.FLAG). Upper case is not equivalent to lower case in parameter names. string name "character string" or string name(size) "character string" defines name to be an integer array long enough to accomodate the ascii codes for the given character string, one per word. The last word of name is initialized to the symbolic parameter EOS, and indicates the end of string. KEYWORDS ratfor fortran preprocessor fortran77 ratfor77 spp ratfor-1.0.orig/test.r100644 0 0 556 6251464103 13016 0ustar rootrootinteger 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 ratfor-1.0.orig/testw.r100644 0 0 1731 6251464103 13221 0ustar rootrootinteger x,y,qwet,fgd,djr,kfy,g,jg,gk,j,sdhf,asg,agsd,ags,h,y,tsrh,sth,ruk,il,y,jd,sht,wht,wth,the,juyk,yt,tliu,rj,htw,grs,w,th,wht,hwte,erj,kut,uky,ilt,y,er,ht,wth,eht,ey,ejy,ej,e,uke,ly,liu,oy,g,t,asg,sdf,bc,ghf,rth,sbc,sdh,sh,sbc,sdf,sfhd,wrh x=1; y=2 # sfadjlk;lkdfasjklfsjklfsdjlkfjklfdsjkl;fdsjkljklsdfjkl;dsfdfjklsjklsdfjklfsdjl;kk;sdfjkl;fsdjkl;dfsjkldsfjkl;dfsjkl;fdsjklfdsjkl;jhdsthjk;shtmk.xbgmkbvmkld;fsdjklsgjklgjkl;gsjkl;gjl;kjkl;gjkl;fgl;jkjkl %#define ABC def if((x==y) && x >=0)print *,'it works...' if((x==y) && _ x <=0) _ print *,'it works...' if(x == y) write(6,600) else if(x > y) write(6,601) else write(6,602) # check underscores in names call abc_def(x,y) x=1 while(x < 10){ if(y != 2) break if(y != 2) next write(6,603)x x=x+1 } repeat { x=x-1 if(x < 0){ break } } 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