/* @(#)main.c 1.3 */ /* 3.0 SID # 1.2 */ static char xxxvers[ ] = "\n@(#)EFL VERSION 1.14, 19 AUGUST 1980"; /* Compiler for the EFL Programming Language. */ /* 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