4.4BSD/usr/src/old/efl/main.c
static char xxxvers[ ] = "\n@(#)EFL VERSION 1.14, 19 AUGUST 1980";
/* Compiler for the EFL Programming Language. Written by:
Stuart I. Feldman
Bell Laboratories
Murray Hill, New Jersey
*/
/* Flags:
-d EFL debugging output
-v verbose (print out Pass numbers and memory limits)
-w supress warning messages
-f put Fortran output on appropriate .f files
-F put Fortran code for input file x onto x.F
-e divert diagnostic output to next argument
-# do not pass comments through to output
*/
#include "defs"
int sysflag;
int nerrs = 0;
int nbad = 0;
int nwarns = 0;
int stnos[MAXSTNO];
int nxtstno = 0;
int constno = 0;
int labno = 0;
int dumpic = NO;
int memdump = NO;
int dbgflag = NO;
int nowarnflag = NO;
int nocommentflag = NO;
int verbose = NO;
int dumpcore = NO;
char msg[200];
struct fileblock fcb[4];
struct fileblock *iifilep;
struct fileblock *ibfile = &fcb[0];
struct fileblock *icfile = &fcb[1];
struct fileblock *idfile = &fcb[2];
struct fileblock *iefile = &fcb[3];
FILE *diagfile = {stderr};
FILE *codefile = {stdout};
FILE *fileptrs[MAXINCLUDEDEPTH];
char *filenames[MAXINCLUDEDEPTH];
char *basefile;
int filelines[MAXINCLUDEDEPTH];
int filedepth = 0;
char *efmacp = NULL;
char *filemacs[MAXINCLUDEDEPTH];
int pushchars[MAXINCLUDEDEPTH];
int ateof = NO;
int igeol = NO;
int pushlex = NO;
int eofneed = NO;
int forcerr = NO;
int defneed = NO;
int prevbg = NO;
int comneed = NO;
int optneed = NO;
int lettneed = NO;
int iobrlevel = 0;
ptr comments = NULL;
ptr prevcomments = NULL;
ptr genequivs = NULL;
ptr arrays = NULL;
ptr generlist = NULL;
ptr knownlist = NULL;
ptr thisexec;
ptr thisctl;
chainp tempvarlist = CHNULL;
chainp temptypelist = CHNULL;
chainp hidlist = CHNULL;
chainp commonlist = CHNULL;
chainp gonelist = CHNULL;
int blklevel = 0;
int ctllevel = 0;
int dclsect = 0;
int instruct = 0;
int inbound = 0;
int inproc = 0;
int ncases = 0;
int graal = 0;
ptr procname = NULL;
int procclass = 0;
ptr thisargs = NULL;
int nhid[MAXBLOCKDEPTH];
int ndecl[MAXBLOCKDEPTH];
char ftnames[MAXFTNAMES][7];
int neflnames = 0;
int nftnames;
int nftnm0;
int impltype[26];
int ftnefl[NFTNTYPES] = { TYINT, TYREAL, TYLOG, TYCOMPLEX, TYLREAL,
TYCHAR, TYLCOMPLEX };
int eflftn[NEFLTYPES];
int ftnmask[NFTNTYPES] = { 1, 2, 4, 8, 16, 32, 64 };
struct tailoring tailor;
struct system systab[] =
{
{ "portable", 0, 1, 10, 7, 15},
{ "unix", UNIX, 4, 10, 7, 15 },
{ "gcos", GCOS, 4, 10, 7, 15 },
{ "gcosbcd", GCOSBCD, 6, 10, 7, 15},
{ "cray", CRAY, 8, 10, 7, 15},
{ "ibm", IBM, 4, 10, 7, 15 },
{ NULL }
};
double fieldmax = FIELDMAX;
int langopt = 2;
int dotsopt = 0;
int dbgopt = 0;
int dbglevel = 0;
int nftnch;
int nftncont;
int indifs[MAXINDIFS];
int nxtindif;
int afterif = 0;
#ifdef gcos
# define BIT(n) (1 << (36 - 1 - n) )
# define FORTRAN BIT(1)
# define FDS BIT(4)
# define EXEC BIT(5)
# define FORM BIT(14)
# define LNO BIT(15)
# define BCD BIT(16)
# define OPTZ BIT(17)
int compile = FORTRAN | FDS;
#endif
main(argc,argv)
register int argc;
register char **argv;
{
FILE *fd;
register char *p;
int neflnm0;
#ifdef unix
int intrupt();
sysflag = UNIX;
/*
meter();
*/
if( (signal(2,1) & 01) == 0)
signal(2, intrupt);
#endif
#ifdef gcos
/*
meter();
*/
sysflag = (intss() ? GCOS : GCOSBCD);
#endif
crii();
--argc;
++argv;
tailinit(systab + sysflag);
while(argc>0 && ( (argv[0][0]=='-' && argv[0][1]!='\0') || eqlstrng(argv[0]) ))
{
if(argv[0][0] == '-')
for(p = argv[0]+1 ; *p ; ++p) switch(*p)
{
case ' ':
break;
case 'd':
case 'D':
switch( *++p)
{
case '1':
dbgflag = YES;
break;
case '2':
setyydeb();
break;
case '3':
dumpcore = YES;
break;
case '4':
dumpic = YES;
break;
case 'm':
case 'M':
memdump = YES;
break;
default:
dbgflag = YES;
--p;
break;
}
break;
case 'w':
case 'W':
nowarnflag = YES;
break;
case 'v':
case 'V':
verbose = YES;
break;
case '#':
nocommentflag = YES;
break;
case 'C':
case 'c':
nocommentflag = NO;
break;
#ifdef gcos
case 'O':
case 'o':
compile |= OPTZ;
break;
case 'E':
case 'e':
compile = 0;
break;
#endif
default:
fprintf(diagfile, "Illegal EFL flag %c\n", *p);
exit(1);
}
--argc;
++argv;
}
kwinit();
geninit();
knowninit();
init();
implinit();
neflnm0 = neflnames;
#ifdef gcos
if( intss() )
compile = 0;
else
gcoutf();
#endif
/* fprintf(diagfile, "EFL 1.10\n"); */
if(argc==0)
{
filenames[0] = "-";
dofile(stdin);
}
else
while(argc>0)
{
if( eqlstrng(argv[0]) )
{
--argc;
++argv;
continue;
}
if(argv[0][0]=='-' && argv[0][1]=='\0')
{
basefile = "";
fd = stdin;
}
else {
basefile = argv[0];
fd = fopen(argv[0], "r");
}
if(fd == NULL)
{
sprintf(msg, "Cannot open file %s", argv[0]);
fprintf(diagfile, "%s. Stop\n", msg);
done(2);
}
filenames[0] = argv[0];
filedepth = 0;
nftnames = 0;
nftnm0 = 0;
neflnames = neflnm0;
dofile(fd);
if(fd != stdin)
fclose(fd);
--argc;
++argv;
}
p2flush();
if(verbose)
fprintf(diagfile, "End of compilation\n");
/*
prhisto();
/* */
rmiis();
#ifdef gcos
gccomp();
#endif
done(nbad);
}
dofile(fd)
FILE *fd;
{
int k;
fprintf(diagfile, "File %s:\n", filenames[0]);
#ifdef gcos
if( fd==stdin && intss() && inquire(stdin, _TTY) )
freopen("*src", "rt", stdin);
#endif
yyin = fileptrs[0] = fd;
yylineno = filelines[0] = 1;
filedepth = 0;
ateof = 0;
do {
nerrs = 0;
nwarns = 0;
eofneed = 0;
forcerr = 0;
comneed = 0;
optneed = 0;
defneed = 0;
lettneed = 0;
iobrlevel = 0;
prevbg = 0;
constno = 0;
labno = 0;
nxtstno = 0;
afterif = 0;
thisexec = 0;
thisctl = 0;
nxtindif = 0;
inproc = 0;
blklevel = 0;
implinit();
opiis();
swii(icfile);
if(k = yyparse())
fprintf(diagfile, "Error in source file.\n");
else switch(graal)
{
case PARSERR:
/*
fprintf(diagfile, "error\n");
*/
break;
case PARSEOF:
break;
case PARSOPT:
propts();
break;
case PARSDCL:
fprintf(diagfile, "external declaration\n");
break;
case PARSPROC:
/* work already done in endproc */
break;
case PARSDEF:
break;
}
cliis();
if(nerrs) ++nbad;
} while(graal!=PARSEOF && !ateof);
}
ptr bgnproc()
{
ptr bgnexec();
if(blklevel > 0)
{
execerr("procedure %s terminated prematurely", procnm() );
endproc();
}
ctllevel = 0;
procname = 0;
procclass = 0;
thisargs = 0;
dclsect = 0;
blklevel = 1;
nftnm0 = nftnames;
dclsect = 1;
ndecl[1] = 0;
nhid[1] = 0;
thisctl = allexcblock();
thisctl->tag = TCONTROL;
thisctl->subtype = STPROC;
inproc = 1;
return( bgnexec() );
}
endproc()
{
char comline[50], *concat();
ptr p;
inproc = 0;
if(nerrs == 0)
{
pass2();
unhide();
cleanst();
if(dumpic)
system( concat("od ", icfile->filename, comline) );
if(memdump)
prmem();
}
else {
fprintf(diagfile, "**Procedure %s not generated\n", procnm());
for( ; blklevel > 0 ; --blklevel)
unhide();
cleanst();
}
if(nerrs==0 && nwarns>0)
if(nwarns == 1)
fprintf(diagfile,"*1 warning\n");
else fprintf(diagfile, "*%d warnings\n", nwarns);
blklevel = 0;
thisargs = 0;
procname = 0;
procclass = 0;
while(thisctl)
{
p = thisctl;
thisctl = thisctl->prevctl;
frexcblock(p);
}
while(thisexec)
{
p = thisexec;
thisexec = thisexec->prevexec;
frexcblock(p);
}
nftnames = nftnm0;
if(verbose)
{
fprintf(diagfile, "Highwater mark %d words. ", nmemused);
fprintf(diagfile, "%ld words left over\n", totalloc-totfreed);
}
}
implinit()
{
setimpl(TYREAL, 'a', 'z');
setimpl(TYINT, 'i', 'n');
}
init()
{
eflftn[TYINT] = FTNINT;
eflftn[TYREAL] = FTNREAL;
eflftn[TYLREAL] = FTNDOUBLE;
eflftn[TYLOG] = FTNLOG;
eflftn[TYCOMPLEX] = FTNCOMPLEX;
eflftn[TYCHAR] = FTNINT;
eflftn[TYFIELD] = FTNINT;
eflftn[TYLCOMPLEX] = FTNDOUBLE;
}
#ifdef gcos
meter()
{
FILE *mout;
char *cuserid(), *datime(), *s;
if(equals(s = cuserid(), "efl")) return;
mout = fopen("efl/eflmeter", "a");
if(mout == NULL)
fprintf(diagfile,"cannot open meter file");
else {
fprintf(mout, "%s user %s at %s\n",
( rutss()? "tss " : "batch"), s, datime() );
fclose(mout);
}
}
#endif
#ifdef unix
meter() /* temporary metering of non-SIF usage */
{
FILE *mout;
int tvec[2];
int uid;
char *ctime(), *p;
uid = getuid() & 0377;
if(uid == 91) return; /* ignore sif uses */
mout = fopen("/usr/sif/efl/Meter", "a");
if(mout == NULL)
fprintf(diagfile, "cannot open meter file");
else {
time(tvec);
p = ctime(tvec);
p[16] = '\0';
fprintf(mout,"User %d, %s\n", uid, p+4);
fclose(mout);
}
}
intrupt()
{
done(0);
}
#endif
done(k)
int k;
{
rmiis();
exit(k);
}
/* if string has an embedded equal sign, set option with it*/
eqlstrng(s)
char *s;
{
register char *t;
for(t = s; *t; ++t)
if(*t == '=')
{
*t = '\0';
while( *++t == ' ' )
;
setopt(s, t);
return(YES);
}
return(NO);
}
#ifdef gcos
/* redirect output unit */
gcoutf()
{
if (!intss())
{
fputs("\t\t Version 2.10 : read INFO/EFL (03/27/80)\n", stderr);
if (compile)
{
static char name[80] = "s*", opts[20] = "yw";
char *opt = (char *)inquire(stdout, _OPTIONS);
if (!strchr(opt, 't'))
{ /* if stdout is diverted */
sprintf(name, "%s\"s*\"",
(char *)inquire(stdout, _FILENAME));
strcpy(&opts[1], opt);
}
if (freopen(name, opts, stdout) == NULL)
cant(name);
}
}
}
/* call in fortran compiler if necessary */
gccomp()
{
if (compile)
{
if (nbad > 0) /* abort */
cretsw(EXEC);
else { /* good: call forty */
FILE *dstar; /* to intercept "gosys" action */
if ((dstar = fopen("d*", "wv")) == NULL)
cant("d*");
fputs("$\tforty\tascii", dstar);
if (fopen("*1", "o") == NULL)
cant("*1");
fclose(stdout, "rl");
cretsw(FORM | LNO | BCD);
if (! tailor.ftncontnu)
compile |= FORM;
csetsw(compile);
gosys("forty");
}
}
}
cant(s)
char *s;
{
ffiler(s);
done(1);
}
#endif