4.3BSD - /usr/src/usr.bin/efl/main.c

   1: static char xxxvers[ ] = "\n@(#)EFL VERSION 1.14,  19 AUGUST 1980";
   2: 
   3: /* Compiler for the EFL Programming Language.  Written by:
   4: 		Stuart I. Feldman
   5: 		Bell Laboratories
   6: 		Murray Hill, New Jersey
   7: */
   8: 
   9: 
  10: /* Flags:
  11: 	-d	EFL debugging output
  12: 	-v	verbose (print out Pass numbers and memory limits)
  13: 	-w	supress warning messages
  14: 	-f	put Fortran output on appropriate .f files
  15: 	-F	put Fortran code for input file x onto x.F
  16: 	-e	divert diagnostic output to next argument
  17: 	-#	do not pass comments through to output
  18: */
  19: 
  20: 
  21: #include "defs"
  22: 
  23: int sysflag;
  24: 
  25: int nerrs   = 0;
  26: int nbad    = 0;
  27: int nwarns  = 0;
  28: int stnos[MAXSTNO];
  29: int nxtstno = 0;
  30: int constno = 0;
  31: int labno   = 0;
  32: 
  33: int dumpic  = NO;
  34: int memdump = NO;
  35: int dbgflag = NO;
  36: int nowarnflag  = NO;
  37: int nocommentflag   = NO;
  38: int verbose = NO;
  39: int dumpcore    = NO;
  40: char msg[200];
  41: 
  42: struct fileblock fcb[4];
  43: struct fileblock *iifilep;
  44: struct fileblock *ibfile    = &fcb[0];
  45: struct fileblock *icfile    = &fcb[1];
  46: struct fileblock *idfile    = &fcb[2];
  47: struct fileblock *iefile    = &fcb[3];
  48: 
  49: FILE *diagfile  = {stderr};
  50: FILE *codefile  = {stdout};
  51: FILE *fileptrs[MAXINCLUDEDEPTH];
  52: char *filenames[MAXINCLUDEDEPTH];
  53: char *basefile;
  54: int filelines[MAXINCLUDEDEPTH];
  55: int filedepth   = 0;
  56: char *efmacp    = NULL;
  57: char *filemacs[MAXINCLUDEDEPTH];
  58: int pushchars[MAXINCLUDEDEPTH];
  59: int ateof   = NO;
  60: 
  61: int igeol   = NO;
  62: int pushlex = NO;
  63: int eofneed = NO;
  64: int forcerr  = NO;
  65: int defneed  = NO;
  66: int prevbg   = NO;
  67: int comneed  = NO;
  68: int optneed  = NO;
  69: int lettneed    = NO;
  70: int iobrlevel   = 0;
  71: 
  72: ptr comments    = NULL;
  73: ptr prevcomments    = NULL;
  74: ptr genequivs   = NULL;
  75: ptr arrays  = NULL;
  76: ptr generlist   = NULL;
  77: ptr knownlist   = NULL;
  78: 
  79: ptr thisexec;
  80: ptr thisctl;
  81: chainp tempvarlist  = CHNULL;
  82: chainp temptypelist = CHNULL;
  83: chainp hidlist  = CHNULL;
  84: chainp commonlist   = CHNULL;
  85: chainp gonelist = CHNULL;
  86: int blklevel    = 0;
  87: int ctllevel    = 0;
  88: int dclsect = 0;
  89: int instruct    = 0;
  90: int inbound = 0;
  91: int inproc  = 0;
  92: int ncases  = 0;
  93: 
  94: int graal   = 0;
  95: ptr procname    = NULL;
  96: int procclass   = 0;
  97: ptr thisargs    = NULL;
  98: 
  99: int nhid[MAXBLOCKDEPTH];
 100: int ndecl[MAXBLOCKDEPTH];
 101: 
 102: char ftnames[MAXFTNAMES][7];
 103: 
 104: 
 105: int neflnames   = 0;
 106: 
 107: int nftnames;
 108: int nftnm0;
 109: int impltype[26];
 110: 
 111: int ftnefl[NFTNTYPES]   = { TYINT, TYREAL, TYLOG, TYCOMPLEX, TYLREAL,
 112:                 TYCHAR, TYLCOMPLEX };
 113: int eflftn[NEFLTYPES];
 114: int ftnmask[NFTNTYPES]  = { 1, 2, 4, 8, 16, 32, 64 };
 115: struct tailoring tailor;
 116: struct system systab[] =
 117:     {
 118:         { "portable", 0,    1, 10, 7, 15},
 119:         { "unix", UNIX, 4, 10, 7, 15 },
 120:         { "gcos", GCOS, 4, 10, 7, 15 },
 121:         { "gcosbcd", GCOSBCD,   6, 10, 7, 15},
 122:         { "cray", CRAY, 8, 10, 7, 15},
 123:         { "ibm", IBM,   4, 10, 7, 15 },
 124:         { NULL }
 125:     };
 126: 
 127: double fieldmax = FIELDMAX;
 128: 
 129: int langopt = 2;
 130: int dotsopt = 0;
 131: int dbgopt  = 0;
 132: int dbglevel    = 0;
 133: 
 134: int nftnch;
 135: int nftncont;
 136: int indifs[MAXINDIFS];
 137: int nxtindif;
 138: int afterif = 0;
 139: 
 140: #ifdef  gcos
 141: #	define BIT(n) (1 << (36 - 1 - n) )
 142: #	define FORTRAN    BIT(1)
 143: #	define FDS    BIT(4)
 144: #	define EXEC   BIT(5)
 145: #	define FORM   BIT(14)
 146: #	define LNO    BIT(15)
 147: #	define BCD    BIT(16)
 148: #	define OPTZ   BIT(17)
 149:     int compile = FORTRAN | FDS;
 150: #endif
 151: 
 152: 
 153: main(argc,argv)
 154: register int argc;
 155: register char **argv;
 156: {
 157: FILE *fd;
 158: register char *p;
 159: int neflnm0;
 160: 
 161: #ifdef unix
 162:     int intrupt();
 163:     sysflag = UNIX;
 164: 
 165: /*
 166: 	meter();
 167: */
 168:     if( (signal(2,1) & 01) == 0)
 169:         signal(2, intrupt);
 170: #endif
 171: 
 172: #ifdef gcos
 173: /*
 174: 	meter();
 175: */
 176:     sysflag = (intss() ? GCOS : GCOSBCD);
 177: #endif
 178: 
 179: 
 180: crii();
 181: --argc;
 182: ++argv;
 183: tailinit(systab + sysflag);
 184: 
 185: while(argc>0 && ( (argv[0][0]=='-' && argv[0][1]!='\0') || eqlstrng(argv[0]) ))
 186:     {
 187:     if(argv[0][0] == '-')
 188:         for(p = argv[0]+1 ; *p ; ++p) switch(*p)
 189:         {
 190:         case ' ':
 191:             break;
 192: 
 193:         case 'd':
 194:         case 'D':
 195:             switch( *++p)
 196:                 {
 197:                 case '1':
 198:                     dbgflag = YES;
 199:                     break;
 200:                 case '2':
 201:                     setyydeb();
 202:                     break;
 203:                 case '3':
 204:                     dumpcore = YES;
 205:                     break;
 206:                 case '4':
 207:                     dumpic = YES;
 208:                     break;
 209:                 case 'm':
 210:                 case 'M':
 211:                     memdump = YES;
 212:                     break;
 213: 
 214:                 default:
 215:                     dbgflag = YES;
 216:                     --p;
 217:                     break;
 218:                 }
 219:             break;
 220: 
 221:         case 'w':
 222:         case 'W':
 223:             nowarnflag = YES;
 224:             break;
 225: 
 226:         case 'v':
 227:         case 'V':
 228:             verbose = YES;
 229:             break;
 230: 
 231:         case '#':
 232:             nocommentflag = YES;
 233:             break;
 234: 
 235:         case 'C':
 236:         case 'c':
 237:             nocommentflag = NO;
 238:             break;
 239: 
 240: #ifdef gcos
 241:         case 'O':
 242:         case 'o':
 243:             compile |= OPTZ;
 244:             break;
 245: 
 246:         case 'E':
 247:         case 'e':
 248:             compile = 0;
 249:             break;
 250: #endif
 251: 
 252:         default:
 253:             fprintf(diagfile, "Illegal EFL flag %c\n", *p);
 254:             exit(1);
 255:         }
 256:     --argc;
 257:     ++argv;
 258:     }
 259: 
 260: kwinit();
 261: geninit();
 262: knowninit();
 263: init();
 264: implinit();
 265: neflnm0 = neflnames;
 266: 
 267: #ifdef gcos
 268:     if( intss() )
 269:         compile = 0;
 270:     else
 271:         gcoutf();
 272: #endif
 273: 
 274: /*	fprintf(diagfile, "EFL 1.10\n");	*/
 275: 
 276: if(argc==0)
 277:     {
 278:     filenames[0] = "-";
 279:     dofile(stdin);
 280:     }
 281: else
 282:     while(argc>0)
 283:         {
 284:         if( eqlstrng(argv[0]) )
 285:             {
 286:             --argc;
 287:             ++argv;
 288:             continue;
 289:             }
 290:         if(argv[0][0]=='-' && argv[0][1]=='\0')
 291:             {
 292:             basefile = "";
 293:             fd = stdin;
 294:             }
 295:         else    {
 296:             basefile = argv[0];
 297:             fd = fopen(argv[0], "r");
 298:             }
 299:         if(fd == NULL)
 300:             {
 301:             sprintf(msg, "Cannot open file %s", argv[0]);
 302:             fprintf(diagfile, "%s.  Stop\n", msg);
 303:             done(2);
 304:             }
 305:         filenames[0] = argv[0];
 306:         filedepth = 0;
 307: 
 308:         nftnames = 0;
 309:         nftnm0 = 0;
 310:         neflnames = neflnm0;
 311: 
 312:         dofile(fd);
 313:         if(fd != stdin)
 314:             fclose(fd);
 315:         --argc;
 316:         ++argv;
 317:         }
 318: p2flush();
 319: if(verbose)
 320:     fprintf(diagfile, "End of compilation\n");
 321: /*
 322: prhisto();
 323: /* */
 324: rmiis();
 325: 
 326: #ifdef gcos
 327:     gccomp();
 328: #endif
 329: 
 330: done(nbad);
 331: }
 332: 
 333: 
 334: dofile(fd)
 335: FILE *fd;
 336: {
 337: int k;
 338: 
 339: fprintf(diagfile, "File %s:\n", filenames[0]);
 340: 
 341: #ifdef gcos
 342:     if( fd==stdin && intss() && inquire(stdin, _TTY) )
 343:         freopen("*src", "rt", stdin);
 344: #endif
 345: 
 346: yyin = fileptrs[0] = fd;
 347: yylineno = filelines[0] = 1;
 348: filedepth = 0;
 349: ateof = 0;
 350: 
 351: do  {
 352:     nerrs = 0;
 353:     nwarns = 0;
 354:     eofneed = 0;
 355:     forcerr = 0;
 356:     comneed = 0;
 357:     optneed = 0;
 358:     defneed = 0;
 359:     lettneed = 0;
 360:     iobrlevel = 0;
 361:     prevbg = 0;
 362: 
 363:     constno = 0;
 364:     labno = 0;
 365:     nxtstno = 0;
 366:     afterif = 0;
 367:     thisexec = 0;
 368:     thisctl = 0;
 369:     nxtindif = 0;
 370:     inproc = 0;
 371:     blklevel = 0;
 372: 
 373:     implinit();
 374: 
 375:     opiis();
 376:     swii(icfile);
 377: 
 378:     if(k = yyparse())
 379:         fprintf(diagfile, "Error in source file.\n");
 380:     else  switch(graal)
 381:         {
 382:         case PARSERR:
 383:             /*
 384: 			fprintf(diagfile, "error\n");
 385: 			*/
 386:             break;
 387: 
 388:         case PARSEOF:
 389:             break;
 390: 
 391:         case PARSOPT:
 392:             propts();
 393:             break;
 394: 
 395:         case PARSDCL:
 396:             fprintf(diagfile, "external declaration\n");
 397:             break;
 398: 
 399:         case PARSPROC:
 400:             /* work already done in endproc */
 401:             break;
 402: 
 403:         case PARSDEF:
 404:             break;
 405:         }
 406: 
 407:     cliis();
 408:     if(nerrs) ++nbad;
 409: 
 410:     } while(graal!=PARSEOF && !ateof);
 411: }
 412: 
 413: ptr bgnproc()
 414: {
 415: ptr bgnexec();
 416: 
 417: if(blklevel > 0)
 418:     {
 419:     execerr("procedure %s terminated prematurely", procnm() );
 420:     endproc();
 421:     }
 422: ctllevel = 0;
 423: procname = 0;
 424: procclass = 0;
 425: thisargs = 0;
 426: dclsect = 0;
 427: blklevel = 1;
 428: nftnm0 = nftnames;
 429: dclsect = 1;
 430: ndecl[1] = 0;
 431: nhid[1] = 0;
 432: 
 433: thisctl = allexcblock();
 434: thisctl->tag = TCONTROL;
 435: thisctl->subtype = STPROC;
 436: inproc = 1;
 437: return( bgnexec() );
 438: }
 439: 
 440: 
 441: endproc()
 442: {
 443: char comline[50], *concat();
 444: ptr p;
 445: 
 446: inproc = 0;
 447: 
 448: if(nerrs == 0)
 449:     {
 450:     pass2();
 451:     unhide();
 452:     cleanst();
 453:     if(dumpic)
 454:         system( concat("od ", icfile->filename, comline) );
 455:     if(memdump)
 456:         prmem();
 457:     }
 458: else    {
 459:     fprintf(diagfile, "**Procedure %s not generated\n", procnm());
 460:     for( ; blklevel > 0 ; --blklevel)
 461:         unhide();
 462:     cleanst();
 463:     }
 464: 
 465: if(nerrs==0 && nwarns>0)
 466:     if(nwarns == 1)
 467:         fprintf(diagfile,"*1 warning\n");
 468:     else    fprintf(diagfile, "*%d warnings\n", nwarns);
 469: 
 470: blklevel = 0;
 471: thisargs = 0;
 472: procname = 0;
 473: procclass = 0;
 474: while(thisctl)
 475:     {
 476:     p = thisctl;
 477:     thisctl = thisctl->prevctl;
 478:     frexcblock(p);
 479:     }
 480: 
 481: while(thisexec)
 482:     {
 483:     p = thisexec;
 484:     thisexec = thisexec->prevexec;
 485:     frexcblock(p);
 486:     }
 487: 
 488: nftnames = nftnm0;
 489: if(verbose)
 490:     {
 491:     fprintf(diagfile, "Highwater mark %d words. ", nmemused);
 492:     fprintf(diagfile, "%ld words left over\n", totalloc-totfreed);
 493:     }
 494: }
 495: 
 496: 
 497: 
 498: 
 499: implinit()
 500: {
 501: setimpl(TYREAL, 'a', 'z');
 502: setimpl(TYINT,  'i', 'n');
 503: }
 504: 
 505: 
 506: 
 507: init()
 508: {
 509: eflftn[TYINT] = FTNINT;
 510: eflftn[TYREAL] = FTNREAL;
 511: eflftn[TYLREAL] = FTNDOUBLE;
 512: eflftn[TYLOG] = FTNLOG;
 513: eflftn[TYCOMPLEX] = FTNCOMPLEX;
 514: eflftn[TYCHAR] = FTNINT;
 515: eflftn[TYFIELD] = FTNINT;
 516: eflftn[TYLCOMPLEX] = FTNDOUBLE;
 517: }
 518: 
 519: 
 520: 
 521: 
 522: #ifdef gcos
 523: meter()
 524: {
 525: FILE *mout;
 526: char *cuserid(), *datime(), *s;
 527: if(equals(s = cuserid(), "efl")) return;
 528: mout = fopen("efl/eflmeter", "a");
 529: if(mout == NULL)
 530:     fprintf(diagfile,"cannot open meter file");
 531: 
 532: else    {
 533:     fprintf(mout, "%s user %s at %s\n",
 534:         ( rutss()? "tss  " : "batch"), s, datime() );
 535:     fclose(mout);
 536:     }
 537: }
 538: #endif
 539: 
 540: 
 541: 
 542: #ifdef unix
 543: meter() /* temporary metering of non-SIF usage */
 544: {
 545: FILE *mout;
 546: int tvec[2];
 547: int uid;
 548: char *ctime(), *p;
 549: 
 550: uid = getuid() & 0377;
 551: if(uid == 91) return;   /* ignore sif uses */
 552: mout = fopen("/usr/sif/efl/Meter", "a");
 553: if(mout == NULL)
 554:     fprintf(diagfile, "cannot open meter file");
 555: else    {
 556:     time(tvec);
 557:     p = ctime(tvec);
 558:     p[16] = '\0';
 559:     fprintf(mout,"User %d, %s\n",  uid, p+4);
 560:     fclose(mout);
 561:     }
 562: }
 563: 
 564: intrupt()
 565: {
 566: done(0);
 567: }
 568: #endif
 569: 
 570: 
 571: done(k)
 572: int k;
 573: {
 574: rmiis();
 575: exit(k);
 576: }
 577: 
 578: 
 579: 
 580: 
 581: 
 582: /* if string has an embedded equal sign, set option with it*/
 583: eqlstrng(s)
 584: char *s;
 585: {
 586: register char *t;
 587: 
 588: for(t = s; *t; ++t)
 589:     if(*t == '=')
 590:         {
 591:         *t = '\0';
 592:         while( *++t == ' ' )
 593:             ;
 594:         setopt(s, t);
 595:         return(YES);
 596:         }
 597: 
 598: return(NO);
 599: }
 600: 
 601: #ifdef gcos
 602: 
 603: /* redirect output unit */
 604: 
 605: gcoutf()
 606: {
 607: if (!intss())
 608:     {
 609:     fputs("\t\t    Version 2.10 : read INFO/EFL (03/27/80)\n", stderr);
 610:     if (compile)
 611:         {
 612:         static char name[80] = "s*", opts[20] = "yw";
 613:         char *opt = (char *)inquire(stdout, _OPTIONS);
 614:         if (!strchr(opt, 't'))
 615:             { /* if stdout is diverted */
 616:             sprintf(name, "%s\"s*\"",
 617:                 (char *)inquire(stdout, _FILENAME));
 618:             strcpy(&opts[1], opt);
 619:             }
 620:         if (freopen(name, opts, stdout) == NULL)
 621:             cant(name);
 622:         }
 623:     }
 624: }
 625: 
 626: 
 627: 
 628: /* call in fortran compiler if necessary */
 629: 
 630: gccomp()
 631: {
 632: if (compile)
 633:     {
 634:     if (nbad > 0)   /* abort */
 635:         cretsw(EXEC);
 636: 
 637:     else    { /* good: call forty */
 638:         FILE *dstar; /* to intercept "gosys" action */
 639: 
 640:         if ((dstar = fopen("d*", "wv")) == NULL)
 641:             cant("d*");
 642:         fputs("$\tforty\tascii", dstar);
 643:         if (fopen("*1", "o") == NULL)
 644:             cant("*1");
 645:         fclose(stdout, "rl");
 646:         cretsw(FORM | LNO | BCD);
 647:         if (! tailor.ftncontnu)
 648:             compile |= FORM;
 649:         csetsw(compile);
 650:         gosys("forty");
 651:         }
 652:     }
 653: }
 654: 
 655: 
 656: cant(s)
 657: char *s;
 658: {
 659: ffiler(s);
 660: done(1);
 661: }
 662: #endif

Defined functions

Defined variables

Defined macros