V5/usr/source/s1/fc.c
/* Fortran command */
char *tmp;
char ts[1000];
char *tsp ts;
char *av[50];
char *clist[50];
char *llist[50];
int instring;
int pflag;
int cflag;
char *complr;
int *ibuf;
int *ibuf1;
int *ibuf2;
int *obuf;
char *lp;
char *line;
int lineno;
int exfail;
struct symtab {
char name[8];
char *value;
} *symtab;
int symsiz 200;
struct symtab *defloc;
struct symtab *incloc;
char *stringbuf;
main(argc, argv)
char *argv[]; {
char *t;
int nc, nl, i, j, c, nxo;
int dexit();
complr = "/usr/fort/fc1";
i = nc = nl = nxo = 0;
while(++i < argc) {
if(*argv[i] == '-')
switch (argv[i][1]) {
default:
goto passa;
case 'p':
pflag++;
case 'c':
cflag++;
break;
case '2':
complr = "/usr/fort/fc2";
break;
}
else {
passa:
t = argv[i];
if(getsuf(t)=='f') {
clist[nc++] = t;
t = setsuf(copy(t), 'o');
}
if (nodup(llist, t)) {
llist[nl++] = t;
if (getsuf(t)=='o')
nxo++;
}
}
}
if(nc==0)
goto nocom;
if ((signal(2, 1) & 01) == 0)
signal(2, &dexit);
for (i=0; i<nc; i++) {
if (nc>1)
printf("%s:\n", clist[i]);
tmp = 0;
av[0] = complr;
av[1] = expand(clist[i]);
if (pflag || exfail)
continue;
if (av[1] == 0) {
cflag++;
continue;
}
av[2] = 0;
t = callsys(complr, av);
if(tmp)
cunlink(tmp);
if(t) {
cflag++;
continue;
}
av[0] = "as";
av[1] = "-";
av[2] = "f.tmp1";
av[3] = 0;
callsys("/bin/as", av);
t = setsuf(clist[i], 'o');
cunlink(t);
if(link("a.out", t) || cunlink("a.out")) {
printf("move failed: %s\n", t);
cflag++;
}
}
nocom:
if (cflag==0 && nl!=0) {
i = 0;
av[0] = "ld";
av[1] = "-x";
av[2] = "/lib/fr0.o";
j = 3;
while(i<nl)
av[j++] = llist[i++];
av[j++] = "-lf";
av[j++] = "/lib/filib.a";
av[j++] = "-l";
av[j++] = 0;
callsys("/bin/ld", av);
if (nc==1 && nxo==1)
cunlink(setsuf(clist[0], 'o'));
}
dexit();
}
dexit()
{
unlink("f.tmp1");
exit();
}
expand(file)
char *file;
{
int ib1[259], ib2[259], ob[259];
struct symtab stab[200];
char ln[196], sbf[1024];
int c;
exfail = 0;
ibuf = ibuf1 = ib1;
ibuf2 = ib2;
if (fopen(file, ibuf1)<0)
return(file);
if (getc(ibuf1) != '#') {
close(ibuf1[0]);
return(file);
}
ibuf1[1]++;
ibuf1[2]--;
obuf = ob;
symtab = stab;
for (c=0; c<200; c++) {
stab[c].name[0] = '\0';
stab[c].value = 0;
}
defloc = lookup("define", 1);
defloc->value = defloc->name;
incloc = lookup("include", 1);
incloc->value = incloc->name;
stringbuf = sbf;
line = ln;
lineno = 0;
tmp = setsuf(copy(file), 'i');
if (fcreat(tmp, obuf) < 0) {
printf("Can't creat %s\n", tmp);
dexit();
}
while(getline()) {
/*
if (ibuf==ibuf2)
putc(001, obuf); /*SOH: insert */
if (ln[0] != '#')
for (lp=line; *lp!='\0'; lp++)
putc(*lp, obuf);
putc('\n', obuf);
}
fflush(obuf);
close(obuf[0]);
close(ibuf1[0]);
return(tmp);
}
getline()
{
int c, sc, state;
struct symtab *np;
char *namep, *filname;
if (ibuf==ibuf1)
lineno++;
lp = line;
*lp = '\0';
state = 0;
if ((c=getch()) == '#')
state = 1;
while (c!='\n' && c!='\0') {
if ('a'<=c && c<='z' || 'A'<=c && c<='Z' || c=='_') {
namep = lp;
sch(c);
while ('a'<=(c=getch()) && c<='z'
||'A'<=c && c<='Z'
||'0'<=c && c<='9'
||c=='_')
sch(c);
sch('\0');
lp--;
np = lookup(namep, state);
if (state==1) {
if (np==defloc)
state = 2;
else if (np==incloc)
state = 3;
else {
error("Undefined control");
while (c!='\n' && c!='\0')
c = getch();
return(c);
}
} else if (state==2) {
np->value = stringbuf;
while ((c=getch())!='\n' && c!='\0')
savch(c);
savch('\0');
return(1);
}
continue;
} else if ((sc=c)=='\'' || sc=='"') {
sch(sc);
filname = lp;
instring++;
while ((c=getch())!=sc && c!='\n' && c!='\0') {
sch(c);
if (c=='\\')
sch(getch());
}
instring = 0;
if (state==3) {
*lp = '\0';
while ((c=getch())!='\n' && c!='\0');
if (ibuf==ibuf2)
error("Nested 'include'");
if (fopen(filname, ibuf2)<0)
error("Missing file %s", filname);
else
ibuf = ibuf2;
return(c);
}
}
sch(c);
c = getch();
}
sch('\0');
if (state>1)
error("Control syntax");
return(c);
}
error(s, x)
{
printf("%d: ", lineno);
printf(s, x);
putchar('\n');
exfail++;
cflag++;
}
sch(c)
{
if (lp==line+194)
error("Line overflow");
*lp++ = c;
if (lp>line+195)
lp = line+195;
}
savch(c)
{
*stringbuf++ = c;
}
getch()
{
static peekc;
int c;
if (peekc) {
c = peekc;
peekc = 0;
return(c);
}
loop:
if ((c=getc1())=='/' && !instring) {
if ((peekc=getc1())!='*')
return('/');
peekc = 0;
for(;;) {
c = getc1();
cloop:
switch (c) {
case '\0':
return('\0');
case '*':
if ((c=getc1())=='/')
goto loop;
goto cloop;
case '\n':
if (ibuf==ibuf1) {
putc('\n', obuf);
lineno++;
}
continue;
}
}
}
return(c);
}
getc1()
{
int c;
if ((c = getc(ibuf)) < 0 && ibuf==ibuf2) {
close(ibuf2[0]);
ibuf = ibuf1;
putc('\n', obuf);
c = getc1();
}
if (c<0)
return(0);
return(c);
}
lookup(namep, enterf)
char *namep;
{
char *np, *snp;
struct symtab *sp;
int i, c;
np = namep;
i = 0;
while (c = *np++)
i =+ c;
i =% symsiz;
sp = &symtab[i];
while (sp->name[0]) {
snp = sp;
np = namep;
while (*snp++ == *np)
if (*np++ == '\0' || np==namep+8) {
if (!enterf)
subst(namep, sp);
return(sp);
}
if (sp++ > &symtab[symsiz])
sp = symtab;
}
if (enterf) {
for (i=0; i<8; i++)
if (sp->name[i] = *namep)
namep++;
while (*namep)
namep++;
}
return(sp);
}
subst(np, sp)
char *np;
struct symtab *sp;
{
char *vp;
lp = np;
if ((vp = sp->value) == 0)
return;
sch(' ');
while (*vp)
sch(*vp++);
sch(' ');
}
getsuf(s)
char s[];
{
int c;
char t, *os;
c = 0;
os = s;
while(t = *s++)
if (t=='/')
c = 0;
else
c++;
s =- 3;
if (c<=14 && c>2 && *s++=='.')
return(*s);
return(0);
}
setsuf(s, ch)
char s[];
{
char *os;
os = s;
while(*s++);
s[-2] = ch;
return(os);
}
callsys(f, v)
char f[], *v[]; {
int t, status;
if ((t=fork())==0) {
execv(f, v);
printf("Can't find %s\n", f);
exit(1);
} else
if (t == -1) {
printf("Try again\n");
return(1);
}
while(t!=wait(&status));
if ((t=(status&0377)) != 0 && t!=14) {
if (t!=2) /* interrupt */
printf("Fatal error in %s\n", f);
dexit();
}
return((status>>8) & 0377);
}
copy(s)
char s[]; {
char *otsp;
otsp = tsp;
while(*tsp++ = *s++);
return(otsp);
}
nodup(l, s)
char **l, s[]; {
char *t, *os, c;
if (getsuf(s) != 'o')
return(1);
os = s;
while(t = *l++) {
s = os;
while(c = *s++)
if (c != *t++)
break;
if (*t++ == '\0')
return(0);
}
return(1);
}
cunlink(f)
char *f;
{
if (f==0)
return(0);
return(unlink(f));
}