PWB1/sys/source/s2/ratfor.a
eÿr.g _
ƒ’ ¶ Ü%{
extern int transfer;
extern int indent;
%}
%term IF ELSE FOR WHILE BREAK NEXT
%term DIGITS DO
%term GOK DEFINE INCLUDE
%term REPEAT UNTIL
%term RETURN
%term SWITCH CASE DEFAULT
%%
statl : statl stat
|
;
stat : if stat ={ indent--; outcont($1); }
| ifelse stat ={ indent--; outcont($1+1); }
| switch fullcase '}' ={ endsw($1, $2); }
| while stat ={ whilestat($1); }
| for stat ={ forstat($1); }
| repeat stat UNTIL ={ untils($1,1); }
| repeat stat ={ untils($1,0); }
| BREAK ={ breakcode($1); }
| NEXT ={ nextcode($1); }
| do stat ={ dostat($1); }
| GOK ={ gokcode($1); }
| RETURN ={ retcode($1); }
| ';'
| '{' statl '}'
| label stat
| error ={ errcode($1); yyclearin; }
;
switch : sw '{'
;
sw : SWITCH ={ swcode(); }
;
fullcase: caselist ={ $$ = 0; }
| caselist defpart ={ $$ = 1; }
;
caselist: casepart
| caselist casepart
;
defpart : default statl
;
default : DEFAULT ={ getdefault(); }
;
casepart: case statl
;
case : CASE ={ getcase(); }
;
label : DIGITS ={ transfer = 0; outcode($1); }
;
if : IF ={ ifcode($1); }
;
ifelse : if stat ELSE ={ elsecode($1); }
;
while : WHILE ={ whilecode($1); }
;
for : FOR ={ forcode($1); }
;
repeat : REPEAT ={ repcode($1); }
;
do : DO ={ docode($1); }
;
%%
r.h _
ƒ’ ¶ ”#include <stdio.h>
#include "y.tab.h"
#
#define putbak(c) *ip++ = c
/* #define getchr() (ip>ibuf?*--ip: getc(infile[infptr])) */
#define LET 1
#define DIG 2
#define CRAP 3
#define COMMENT '#'
#define QUOTE '"'
extern int transfer;
#define INDENT 3 /* indent delta */
#ifdef gcos
#define CONTFLD 6
#endif
#ifdef unix
#define CONTFLD 1
#endif
extern int contfld; /* column for continuation char */
extern int contchar;
extern int dbg;
extern int yyval;
extern int *yypv;
extern int yylval;
extern int errorflag;
extern char comment[]; /* save input comments here */
extern int comptr; /* next free slot in comment */
extern int printcom; /* print comments, etc., if on */
extern int indent; /* level of nesting for indenting */
extern char ibuf[];
extern char *ip;
extern FILE *outfil; /* output file id */
extern FILE *infile[];
extern char *curfile[];
extern int infptr;
extern int linect[];
extern char fcname[];
extern int svargc;
extern char **svargv;
#define NULL 0
#define EOS 0
#define HSHSIZ 101
struct nlist {
char *name;
char *def;
int ydef;
struct nlist *next;
};
struct nlist *lookup();
char *install();
extern char *fcnloc;
extern char type[];
r1.c k
5Í ¶‘ v#include "r.h"
#define wasbreak brkused[brkptr]==1 || brkused[brkptr]==3
#define wasnext brkused[brkptr]==2 || brkused[brkptr]==3
int transfer 0; /* 1 if just finished retrun, break, next */
char fcname[10];
char scrat[500];
int brkptr -1;
int brkstk[10]; /* break label */
int typestk[10]; /* type of loop construct */
int brkused[10]; /* loop contains BREAK or NEXT */
int forptr 0;
int forstk[10];
repcode() {
transfer = 0;
outcont(0);
putcom("repeat");
yyval = genlab(3);
indent++;
outcont(yyval);
brkstk[++brkptr] = yyval+1;
typestk[brkptr] = REPEAT;
brkused[brkptr] = 0;
}
untils(p1,un) int p1,un; {
outnum(p1+1);
outtab();
if (un > 0) {
outcode("if(.not.");
balpar();
outcode(")");
}
transfer = 0;
outgoto(p1);
indent--;
if (wasbreak)
outcont(p1+2);
brkptr--;
}
ifcode(p1) int p1; {
transfer = 0;
outtab();
outcode("if(.not.");
balpar();
outcode(")");
outgoto(yyval=genlab(2));
indent++;
}
elsecode(p1) {
outgoto(p1+1);
indent--;
putcom("else");
indent++;
outcont(p1);
}
whilecode(p1) int p1; {
transfer = 0;
outcont(0);
putcom("while");
brkstk[++brkptr] = yyval = genlab(2);
typestk[brkptr] = WHILE;
brkused[brkptr] = 0;
outnum(yyval);
outtab();
outcode("if(.not.");
balpar();
outcode(")");
outgoto(yyval+1);
indent++;
}
whilestat(p1) int p1; {
outgoto(p1);
indent--;
putcom("endwhile");
outcont(p1+1);
brkptr--;
}
balpar() {
register c, lpar;
while ((c=gtok(scrat)) == ' ' || c == '\t')
;
if (c != '(') {
error("missing left paren");
return;
}
outcode(scrat);
lpar = 1;
do {
c = gtok(scrat);
if (c==';' || c=='{' || c=='}' || c==EOF) {
pbstr(scrat);
break;
}
if (c=='(')
lpar++;
else if (c==')')
lpar--;
else if (c == '\n') {
while ((c = gtok(scrat)) == ' ' || c=='\t' || c=='\n')
;
pbstr(scrat);
continue;
}
else if (c == '=' && scrat[1] == '\0')
error("assigment inside conditional");
outcode(scrat);
} while (lpar > 0);
}
int labval 23000;
genlab(n){
labval =+ n;
return(labval-n);
}
gokcode(p1) char *p1; {
transfer = 0;
outtab();
outcode(p1);
eatup();
outdon();
}
eatup() {
int i, t, lpar;
char temp[100];
lpar = 0;
do {
if ((t = gtok(scrat)) == ';' || t == '\n')
break;
if (t == '{' || t == '}' || t == EOF) {
pbstr(scrat);
break;
}
if (t == ',' || t == '+' || t == '-' || t == '*' || t == '('
|| t == '&' || t == '|' || t == '=') {
while (gtok(temp) == '\n')
;
pbstr(temp);
}
if (t == '(')
lpar++;
else if (t==')') {
lpar--;
if (lpar < 0) {
error("missing left paren");
return(1);
}
}
outcode(scrat);
} while (lpar >= 0);
if (lpar > 0) {
error("missing right paren");
return(1);
}
return(0);
}
forcode(){
int lpar, t;
char *calloc(), *ps, *qs;
transfer = 0;
outcont(0);
putcom("for");
yyval = genlab(3);
brkstk[++brkptr] = yyval+1;
typestk[brkptr] = FOR;
brkused[brkptr] = 0;
forstk[forptr++] = calloc(1, 1);
if ((t = gnbtok(scrat)) != '(') {
error("missing left paren in FOR");
pbstr(scrat);
return;
}
if (gnbtok(scrat) != ';') { /* real init clause */
pbstr(scrat);
outtab();
if (eatup() > 0) {
error("illegal FOR clause");
return;
}
outdon();
}
if (gnbtok(scrat) == ';') /* empty condition */
outcont(yyval);
else { /* non-empty condition */
pbstr(scrat);
outnum(yyval);
outtab();
outcode("if(.not.(");
for (lpar=0; lpar >= 0;) {
if ((t = gnbtok(scrat)) == ';')
break;
if (t == '(')
lpar++;
else if (t == ')') {
lpar--;
if (lpar < 0) {
error("missing left paren in FOR clause");
return;
}
}
if (t != '\n')
outcode(scrat);
}
outcode("))");
outgoto(yyval+2);
if (lpar < 0)
error("invalid FOR clause");
}
ps = scrat;
for (lpar=0; lpar >= 0;) {
if ((t = gtok(ps)) == '(')
lpar++;
else if (t == ')')
lpar--;
if (lpar >= 0 && t != '\n')
while(*ps)
ps++;
}
*ps = '\0';
qs = forstk[forptr-1] = calloc(ps-scrat+1,1);
ps = scrat;
while (*qs++ = *ps++)
;
indent++;
}
forstat(p1) int p1; {
char *bp, *q;
int i;
bp = forstk[--forptr];
if (wasnext)
outnum(p1+1);
if (nonblank(bp)){
outtab();
outcode(bp);
outdon();
}
outgoto(p1);
indent--;
putcom("endfor");
outcont(p1+2);
for (q=bp; *q++;);
cfree(bp, q-bp, 1);
brkptr--;
}
retcode(p1) int p1; {
register c;
if ((c = gnbtok(scrat)) != '\n' && c != ';' && c != '}') {
pbstr(scrat);
outtab();
outcode(fcname);
outcode(" = ");
eatup();
outdon();
}
else if (c == '}')
pbstr(scrat);
outtab();
outcode("return");
outdon();
transfer = 1;
}
docode(p1) char *p1; {
transfer = 0;
outtab();
outcode("do ");
yyval = genlab(2);
brkstk[++brkptr] = yyval;
typestk[brkptr] = DO;
brkused[brkptr] = 0;
outnum(yyval);
eatup();
outdon();
indent++;
}
dostat(p1) int p1; {
outcont(p1);
indent--;
if (wasbreak)
outcont(p1+1);
brkptr--;
}
#ifdef gcos
#define atoi(s) (*s-'0') /* crude!!! */
#endif
breakcode(p1) int p1; {
int level, t;
level = 0;
if ((t=gnbtok(scrat)) == DIG)
level = atoi(scrat) - 1;
else if (t != ';')
pbstr(scrat);
if (brkptr-level < 0)
error("illegal BREAK");
else {
outgoto(brkstk[brkptr-level]+1);
brkused[brkptr-level] =| 1;
}
transfer = 1;
}
nextcode(p1) int p1; {
int level, t;
level = 0;
if ((t=gnbtok(scrat)) == DIG)
level = atoi(scrat) - 1;
else if (t != ';')
pbstr(scrat);
if (brkptr-level < 0)
error("illegal NEXT");
else {
outgoto(brkstk[brkptr-level]);
brkused[brkptr-level] =| 2;
}
transfer = 1;
}
nonblank(s) char *s; {
int c;
while (c = *s++)
if (c!=' ' && c!='\t' && c!='\n')
return(1);
return(0);
}
int errorflag 0;
error(s1, s2) char *s1, *s2; {
if (errorflag == 0)
fprintf(stderr, "******\n");
fprintf(stderr, "*****W ratfor: ");
fprintf(stderr, "error at line %d, file %s: ",linect[infptr],curfile[infptr]);
fprintf(stderr, s1,s2);
fprintf(stderr, "\n");
errorflag = 1;
}
errcode(p1) char *p1; {
int c;
if (errorflag == 0)
fprintf(stderr, "******\n");
fprintf(stderr, "*****F ratfor:");
fprintf(stderr, "syntax error, line %d, file %s\n", linect[infptr], curfile[infptr]);
while ((c=getchr())!=';' && c!='}' && c!='\n' && c!=EOF && c!='\0')
;
if (c == EOF || c == '\0')
putbak(c);
errorflag = 1;
}
r2.c _
…’ ¶ C #include "r.h"
char outbuf[80];
int outp 0;
int cont 0;
int contchar '&';
char comment[320];
int comptr 0;
int indent 0;
outdon() {
outbuf[outp] = '\0';
if (outp > 0)
fprintf(outfil, "%s\n", outbuf);
outp = cont = 0;
}
putcom(s) char *s; {
if (printcom) {
ptc('c');
outtab();
pts(s);
outdon();
}
}
outcode(p) char *p; {
register c, c1, j;
char *q;
if (cont == 0 && comptr > 0) /* flush comment if not on continuation */
flushcom();
while( (c = *p++) ){
c1 = *p;
if (type[c] == LET || type[c] == DIG) {
pts(p-1);
break;
}
switch(c){
case '"': case '\'':
j = 0;
for (q=p; *q; q++) {
if (*q == '\\')
q++;
j++;
}
if (outp+j+2 > 71)
contcard();
outnum(--j);
ptc('h');
while (*p != c) {
if (*p == '\\')
p++;
ptc(*p++);
}
p++;
break;
case '$': case '\\':
if (length(p-1)+outp > 71)
contcard();
if (c1 == '"' || c1 == '\'') {
ptc(c1);
p++;
} else
for (p--; *p; p++)
ptc(*p);
break;
case '%':
outp = 0;
while (*p)
ptc(*p++);
break;
case '>':
if( c1=='=' ){
pts(".ge."); p++;
} else
pts(".gt.");
break;
case '<':
if( c1=='=' ){
pts(".le."); p++;
} else if( c1=='>' ){
pts(".ne."); p++;
} else
pts(".lt.");
break;
case '=':
if( c1=='=' ){
pts(".eq."); p++;
} else
ptc('=');
break;
case '!': case '^':
if( c1=='=' ){
pts(".ne."); p++;
} else
pts(".not.");
break;
case '&':
if( c1=='&' )
p++;
pts(".and.");
break;
case '|':
if( c1=='|' )
p++;
pts(".or.");
break;
case '\t':
outtab();
break;
case '\n':
ptc(' ');
break;
default:
ptc(c);
break;
}
}
}
ptc(c) char c; {
if( outp > 71 )
contcard();
outbuf[outp++] = c;
}
pts(s) char *s; {
if (length(s)+outp > 71)
contcard();
while(*s)
ptc(*s++);
}
contcard(){
int n;
outbuf[outp] = '\0';
fprintf(outfil, "%s\n", outbuf);
n = 6;
if (printcom) {
n =+ INDENT * indent + 1;
if (n > 35) n = 35;
}
for( outp=0; outp<n; outbuf[outp++] = ' ' );
outbuf[contfld-1] = contchar;
cont++;
if (cont > 19)
error("more than 19 continuation cards");
}
outtab(){
int n;
n = 6;
if (printcom) {
n =+ INDENT * indent;
if (n > 35) n = 35;
}
while (outp < n)
ptc(' ');
}
outnum(n) int n; {
int a;
if( a = n/10 )
outnum(a);
ptc(n%10 + '0');
}
outcont(n) int n; {
transfer = 0;
if (n == 0 && outp == 0)
return;
if( n > 0 )
outnum(n);
outcode("\tcontinue");
outdon();
}
outgoto(n) int n; {
if (transfer != 0)
return;
outcode("\tgoto ");
outnum(n);
outdon();
}
flushcom() {
int i, j;
if (printcom == 0)
comptr = 0;
else if (cont == 0 && comptr > 0) {
for (i=j=0; i < comptr; i++)
if (comment[i] == '\n') {
comment[i] = '\0';
fprintf(outfil, "%s\n", &comment[j]);
j = i + 1;
}
comptr = 0;
}
}
rio.c _
†’ ¶ ž#include "r.h"
#define BUFSIZE 512
char ibuf[BUFSIZE];
char *ip ibuf;
char type[] {
0, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP,
CRAP, '\t', '\n', CRAP, CRAP, CRAP, CRAP, CRAP,
CRAP, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP,
CRAP, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP, CRAP,
' ', '!', '"', '#', '$', '%', '&', '\'',
'(', ')', '*', '+', ',', '-', '.', '/',
DIG, DIG, DIG, DIG, DIG, DIG, DIG, DIG,
DIG, DIG, ':', ';', '<', '=', '>', '?',
'@', LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, '[', '\\', ']', '^', '_',
'`', LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, LET, LET, LET, LET, LET,
LET, LET, LET, '{', '|', '}', '~', 0,
};
gtok(s) char *s; { /* get token into s */
register c, t;
register char *p;
struct nlist *q;
for(;;) {
p = s;
*p++ = c = getchr();
switch(t = type[c]) {
case 0:
if (infptr > 0) {
fclose(infile[infptr]);
infptr--;
continue;
}
if (svargc > 1) {
svargc--;
svargv++;
if (infile[infptr] != stdin)
fclose(infile[infptr]);
if( (infile[infptr] = fopen(*svargv,"r")) == NULL )
cant(*svargv);
linect[infptr] = 0;
curfile[infptr] = *svargv;
continue;
}
return(EOF); /* real eof */
case ' ':
case '\t':
while ((c = getchr()) == ' ' || c == '\t')
; /* skip others */
if (c == COMMENT || c == '_') {
putbak(c);
continue;
}
if (c != '\n') {
putbak(c);
*p = '\0';
return(' ');
} else {
*s = '\n';
*(s+1) = '\0';
return(*s);
}
case '_':
while ((c = getchr()) == ' ' || c == '\t')
;
if (c == COMMENT) {
putbak(c);
gtok(s); /* recursive */
}
else if (c != '\n')
putbak(c);
continue;
case LET:
case DIG:
while ((t=type[*p = getchr()]) == LET || t == DIG)
p++;
putbak(*p);
*p = '\0';
if ((q = lookup(s))->name != NULL && q->ydef == 0) { /* found but not keyword */
if (q->def != fcnloc) { /* not "function" */
pbstr(q->def);
continue;
}
getfname(); /* recursive gtok */
}
for (p=s; *p; p++)
if (*p>='A' && *p<='Z')
*p =+ 'a' - 'A';
for (p=s; *p; p++)
if (*p < '0' || *p > '9')
return(LET);
return(DIG);
case '[':
*p = '\0';
return('{');
case ']':
*p = '\0';
return('}');
case '$':
case '\\':
if ((*p = getchr()) == '(' || *p == ')') {
putbak(*p=='(' ? '{' : '}');
continue;
}
if (*p == '"' || *p == '\'')
p++;
else
putbak(*p);
*p = '\0';
return('$');
case COMMENT:
comment[comptr++] = 'c';
while ((comment[comptr++] = getchr()) != '\n')
;
flushcom();
*s = '\n';
*(s+1) = '\0';
return(*s);
case '"':
case '\'':
for (; (*p = getchr()) != c; p++) {
if (*p == '\\')
*++p = getchr();
if (*p == '\n') {
error("missing quote");
putbak('\n');
break;
}
}
*p++ = c;
*p = '\0';
return(QUOTE);
case '%':
while ((*p = getchr()) != '\n')
p++;
putbak(*p);
*p = '\0';
return('%');
case '>': case '<': case '=': case '!': case '^':
return(peek(p, '='));
case '&':
return(peek(p, '&'));
case '|':
return(peek(p, '|'));
case CRAP:
continue;
default:
*p = '\0';
return(*s);
}
}
}
gnbtok(s) char *s; {
register c;
while ((c = gtok(s)) == ' ' || c == '\t')
;
return(c);
}
getfname() {
while (gtok(fcname) == ' ')
;
pbstr(fcname);
putbak(' ');
}
peek(p, c1) char *p, c1; {
register c;
c = *(p-1);
if ((*p = getchr()) == c1)
p++;
else
putbak(*p);
*p = '\0';
return(c);
}
pbstr(str)
register char *str;
{
register char *p;
p = str;
while (*p++);
--p;
if (ip >= &ibuf[BUFSIZE]) {
error("pushback overflow");
exit(1);
}
while (p > str)
putbak(*--p);
}
getchr() {
register c;
if (ip > ibuf)
return(*--ip);
c = getc(infile[infptr]);
if (c == '\n')
linect[infptr]++;
if (c == EOF)
return(0);
return(c);
}
rlex.c _
‡’ ¶ Y# include "r.h"
char *keyword []{
"do",
"if",
"else",
"for",
"repeat",
"until",
"while",
"break",
"next",
"define",
"include",
"return",
"switch",
"case",
"default",
0};
int keytran[]{
DO,
IF,
ELSE,
FOR,
REPEAT,
UNTIL,
WHILE,
BREAK,
NEXT,
DEFINE,
INCLUDE,
RETURN,
SWITCH,
CASE,
DEFAULT,
0};
char *fcnloc; /* spot for "function" */
int svargc;
char **svargv;
char *curfile[10] { "" };
int infptr 0;
FILE *outfil { stdout };
FILE *infile[10] { stdin };
int linect[10];
int contfld CONTFLD; /* place to put continuation char */
int printcom 0; /* print comments if on */
#ifdef gcos
char *ratfor "tssrat";
int bcdrat[2];
char *bwkmeter ". bwkmeter ";
int bcdbwk[5];
#endif
main(argc,argv) int argc; char **argv; {
int i;
while(argc>1 && argv[1][0]=='-') {
if(argv[1][1]=='6') {
contfld=6;
if (argv[1][2]!='\0')
contchar = argv[1][2];
} else if (argv[1][1] == 'C')
printcom++;
argc--;
argv++;
}
#ifdef gcos
if (!intss()) {
_fixup();
ratfor = "batrat";
}
ascbcd(ratfor,bcdrat,6);
ascbcd(bwkmeter,bcdbwk,24);
acdata(bcdrat[0],1);
acupdt(bcdbwk[0]);
if (!intss()) {
if ((infile[infptr]=fopen("s*", "r")) == NULL)
cant("s*");
if ((outfil=fopen("*s", "w")) == NULL)
cant("*s");
}
#endif
svargc = argc;
svargv = argv;
if (svargc > 1)
putbak('\0');
for (i=0; keyword[i]; i++)
install(keyword[i], "", keytran[i]);
fcnloc = install("function", "", 0);
yyparse();
#ifdef gcos
if (!intss())
bexit(errorflag);
#endif
exit(errorflag);
}
#ifdef gcos
bexit(status) {
/* this is the batch version of exit for gcos tss */
FILE *inf, *outf;
char c;
fclose(stderr); /* make sure diagnostics get flushed */
if (status) /* abort */
_nogud();
/* good: copy output back to s*, call forty */
fclose(outfil,"r");
fclose(infile[0],"r");
inf = fopen("*s", "r");
outf = fopen("s*", "w");
while ((c=getc(inf)) != EOF)
putc(c, outf);
fclose(inf,"r");
fclose(outf,"r");
__imok();
}
#endif
cant(s) char *s; {
error("cant open %s", s);
exit(1);
}
inclstat() {
int i,c,lpar;
char *ps;
char fname[100];
while ((c = getchr()) == ' ' || c == '\t');
if (c == '(') {
for (ps=fname; (*ps=getchr()) != ')'; ps++);
*ps = '\0';
} else {
putbak(c);
for (ps=fname; (*ps=getchr()) != ' ' &&*ps!='\t' && *ps!='\n' && *ps!=';'; ps++);
*ps = '\0';
}
if ((infile[++infptr] = fopen(fname,"r")) == NULL) {
cant(fname);
exit(1);
}
linect[infptr] = 0;
curfile[infptr] = fname;
}
char str[500];
int strp;
int nstr;
yylex() {
int c, t, i;
for (;;) {
while ((c=gtok(str))==' ' || c=='\n' || c=='\t')
;
yylval = c;
if (c==';' || c=='{' || c=='}')
return(c);
if (c==EOF)
return(0);
yylval = str;
if (c == DIG)
return(DIGITS);
t = lookup(str)->ydef;
if (t==DEFINE)
defstat();
else if (t==INCLUDE)
inclstat();
else if (t > 0)
return(t);
else
return(GOK);
}
}
int dbg 0;
yyerror() {;}
defstat() {
int c,i,val,t,nlp;
extern int nstr;
extern char str[];
while ((c=getchr())==' ' || c=='\t');
if (c == '(') {
t = '(';
while ((c=getchr())==' ' || c=='\t');
putbak(c);
}
else {
t = ' ';
putbak(c);
}
for (nstr=0; c=getchr(); nstr++) {
if (type[c] != LET && type[c] != DIG)
break;
str[nstr] = c;
}
putbak(c);
str[nstr] = '\0';
if (c != ' ' && c != '\t' && c != '\n' && c != ',') {
error("illegal define statement: %s", str);;
return;
}
val = nstr+1;
if (t == ' ') {
while ((c=getchr())==' ' || c=='\t');
putbak(c);
for (i=val; (c=getchr())!='\n' && c!='#' && c!='\0'; i++)
str[i] = c;
putbak(c);
} else {
while ((c=getchr())==' ' || c=='\t' || c==',' || c=='\n');
putbak(c);
nlp = 0;
for (i=val; nlp>=0 && (c=str[i]=getchr()); i++)
if (c == '(')
nlp++;
else if (c == ')')
nlp--;
i--;
}
for ( ; i>0; i--)
if (str[i-1] != ' ' && str[i-1] != '\t')
break;
str[i] = '\0';
install(str, &str[val], 0);
}
}rlook.c _
‡’ ¶ Â#define NULL 0
#define EOS 0
#define HSHSIZ 101
struct nlist {
char *name;
char *def;
int ydef;
struct nlist *next;
};
struct nlist *hshtab[HSHSIZ];
struct nlist *lookup();
char *install();
char *calloc();
char *copy();
int hshval;
struct nlist *lookup(str)
char *str;
{
register char *s1, *s2;
register struct nlist *np;
static struct nlist nodef;
s1 = str;
for (hshval = 0; *s1; )
hshval =+ *s1++;
hshval =% HSHSIZ;
for (np = hshtab[hshval]; np!=NULL; np = np->next) {
s1 = str;
s2 = np->name;
while (*s1++ == *s2)
if (*s2++ == EOS)
return(np);
}
return(&nodef);
}
char *install(nam, val, tran)
char *nam, *val;
int tran;
{
register struct nlist *np;
if ((np = lookup(nam))->name == NULL) {
np = calloc(sizeof(*np),1);
np->name = copy(nam);
np->def = copy(val);
np->ydef = tran;
np->next = hshtab[hshval];
hshtab[hshval] = np;
return(np->def);
}
cfree(np->def, length(np->def)+1, 1);
np->def = copy(val);
return(np->def);
}
char *copy(s)
register char *s;
{
register char *p, *s1;
p = s1 = calloc(length(s)+1,1);
while (*s1++ = *s++);
return(p);
}
length(str)
register char *str;
{
register len;
len = 0;
while (*str++ != EOS)
len++;
return(len);
}
r0.c _
‡’ ¶ …#include "r.h"
int swlevel -1;
int swexit[5];
int nextcase[5];
swcode() {
transfer = 0;
putcom("switch");
swlevel++;
if (swlevel >= 5)
error("Switches nested > 5");
swexit[swlevel] = yyval = genlab(1);
outcode("\tI");
outnum(yyval);
outcode(" = ");
balpar();
outdon();
nextcase[swlevel] = 0;
indent++;
}
getcase() {
int t, lpar;
char token[100];
if (nextcase[swlevel] != 0) {
outgoto(swexit[swlevel]);
outcont(nextcase[swlevel]);
}
indent--;
outcode("\tif(.not.(");
do {
outcode("I");
outnum(swexit[swlevel]);
outcode(".eq.(");
lpar = 0;
do {
if ((t=gtok(token)) == ':')
break;
if (t == '(')
lpar++;
else if (t == ')')
lpar--;
else if (t == ',') {
if (lpar == 0)
break;
}
outcode(token);
} while (lpar >= 0);
if (lpar < 0)
error("Missing left parenthesis in case");
if (t == ',')
outcode(").or.");
} while (t != ':');
if (lpar != 0)
error("Missing parenthesis in case");
outcode(")))");
nextcase[swlevel] = genlab(1);
outgoto(nextcase[swlevel]);
indent++;
}
getdefault() {
char token[20];
if (gnbtok(token) != ':')
error("Missing colon after default");
outgoto(swexit[swlevel]);
outcont(nextcase[swlevel]);
indent--;
putcom("default");
indent++;
}
endsw(n, def) {
if (def == 0)
outcont(nextcase[swlevel]);
swlevel--;
if (swlevel < -1)
error("Switches unwound too far");
indent--;
outcont(n);
}
!makefile a
úÜ[¶ ¦a.out: r0.o r1.o r2.o rio.o rlook.o rlex.o y.tab.o
cc r*.o y.tab.o -ly -lS
r0.o: r.h y.tab.h r0.c
r1.o: r.h y.tab.h r1.c
r2.o: r.h y.tab.h r2.c
rio.o: r.h y.tab.h rio.c
rlook.o: r.h y.tab.h rlook.c
rlex.o: r.h y.tab.h rlex.c
y.tab.c: r.g
yacc -d r.g
y.tab.h: r.g
yacc -d r.g
list:
pr r.g r.h r*.c makefile TODO bfor.g
gcos:
fsend r.h r*.c y.tab.c y.tab.h
install:
strip a.out
cp a.out /usr/bin/ratfor
get:
ar x /sys/source/s2/ratfor.a
sys:
ar u /sys/source/s2/ratfor.a
clean:
rm r.g r.h r*.c y.tab.c info frat.g
export:
mkdir export
cp /sys/source/s2/ratfor.a export
cp /sys/source/s2/rc.c export
ar r export/stdio.a /sys/source/s4/stdio/*
ls export
tp:
frat.g _
ˆ’ ¶ (%term YLBRACK YRBRACK YLPAR YRPAR YSCOL YDIGITS
%term YIF YELSE YFOR YWHILE YBREAK YNEXT
%term YOLDDO YNEWDO YDO
%term YGOK YDEFINE YINCLUDE YOPTIONS
%%
statl : statl stat
|
;
stat : if stat ={ call outcon($1); }
| ifelse stat ={ call outcon($1+1); }
| while stat ={ call whiles($1); }
| for stat ={ call fors($1); }
| YBREAK ={ call breakc; }
| YNEXT ={ call nextc; }
| newdo stat ={ call dostat($1); }
| YOLDDO ={ call docode(0); }
| YGOK ={ call gokcod; }
| YSCOL
| YLBRACK statl YRBRACK
| label stat
| error ={ call errcod; yyclearin; }
;
label : YDIGITS ={ call labelc;}
;
if : YIF ={ call ifcode; }
;
ifelse : if stat YELSE ={ call outgo($1+1); call outcon($1); }
;
while : YWHILE ={ call whilec; }
;
for : YFOR ={ call forcod; }
;
newdo : YNEWDO ={ call docode(1); }
;
%%
info _
ˆ’ ¶ >Ratfor is a Fortran preprocessor that takes a decent
language closely related to Fortran and converts it
into Fortran. The language is best described in
the book Software Tools, by B. W. Kernighan and P. J. Plauger,
Addison-Wesley, 1976.
The version here is in C, and implements a superset
of the Ratfor described in Software Tools. New additions
are
return(value)
break n, next n
switch
output formatting
The ratfor compiler lives on several files:
r.g - the grammar as yacc source
r.h - header for r*.c
r0.c - semantic actions for switch statement
r1.c - semantic actions for input categories, like "if", etc.
r2.c - output code; formatting, quote conversion, etc.
rlex.c - lexical phase - reads input, isolates tokens.
rio.c - input processing
rlook.c - table lookup code
Compile with
yacc r.g
cc r*.c y.tab.c -ly -lS
The file y.tab.c is produced by yacc.
-ly indicates the use of the yacc runtime
library and -lS is the new Standard C I/O library.
Usage:
a.out [files ...]
Writes on standard output.
Ratfor is best used via the rc command, described in section
I of the Unix Programmers Manual, 6th edition.
rc is very similar to cc, from which it is derived.
To make a new version of rc,
cc rc.c
Usage of rc:
rc [-c] files...
where -c implies no attempt to load, as in cc.
all files ending in .r are assumed to
be ratfor source; they are ratfor'ed, fortran'ed and bound
into a .o .
The complete set of .o's is bound into an a.out unless
there is a compilation error.
There are a number of other less interesting flags,
described in the manual.
bfor.g a
WÜ ¶ Ë$ gmap nxec,ndeck
lbl cterm
ttl c compiler termination routines
ttls january 1974, bell telephone laboratories
*
* program responsibility: r. a. faulkner
*
symdef ..imok
..imok null normal termination
mme geroad
eax1 0 zero the slave prefix
rpt 17,1
stz 0,1
rpt 6,1
stz 3,1
stz 31
ldq =hratfor
stq 21 use "r" for object deck ident
ldq bufptr
mme gerels get rid of **
zero 1,0
bci 1,0000**
ldaq save26
staq 26
mme gecall invoke forty
bci 1,forty
zero
zero
bufptr zero buf,-1
buf bss 355
*
symdef .nogud
.nogud null abnormal termination
mme geroad
ldq =o010000,du
mme gerets turn off execute bit
canq =o000020,du test sys. editor bit
tnz *+2 on, skip
mme gefini off, terminate
ldaq save26
staq 26
ldq =3h0*z,dl
tra 26 return to editor
*
*
symdef .fixup
.fixup null
ldaq 26
staq save26
tra 0,1
even
save26 bss 2
end