UNIX 7th Ed. - /usr/src/cmd/f77/driver.c

   1: char *xxxvers[] = "\n FORTRAN 77 DRIVER, VERSION 1.13,   20 APRIL 1979\n";
   2: #include <stdio.h>
   3: #include <ctype.h>
   4: #include "defines"
   5: #include "locdefs"
   6: #include "drivedefs"
   7: #include "ftypes"
   8: #include <signal.h>
   9: 
  10: static FILEP diagfile   = {stderr} ;
  11: static int pid;
  12: static int sigivalue    = 0;
  13: static int sigqvalue    = 0;
  14: static int sighvalue    = 0;
  15: static int sigtvalue    = 0;
  16: 
  17: static char *pass1name  = PASS1NAME ;
  18: static char *pass2name  = PASS2NAME ;
  19: static char *asmname    = ASMNAME ;
  20: static char *ldname = LDNAME ;
  21: static char *footname   = FOOTNAME;
  22: static char *proffoot   = PROFFOOT;
  23: static char *macroname  = "m4";
  24: static char *shellname  = "/bin/sh";
  25: static char *aoutname   = "a.out" ;
  26: 
  27: static char *infname;
  28: static char textfname[15];
  29: static char asmfname[15];
  30: static char asmpass2[15];
  31: static char initfname[15];
  32: static char sortfname[15];
  33: static char prepfname[15];
  34: static char objfdefault[15];
  35: static char optzfname[15];
  36: static char setfname[15];
  37: 
  38: static char fflags[30]  = "-";
  39: static char cflags[20]  = "-c";
  40: static char eflags[30]  = "";
  41: static char rflags[30]  = "";
  42: static char lflag[3]    = "-x";
  43: static char *fflagp = fflags+1;
  44: static char *cflagp = cflags+2;
  45: static char *eflagp = eflags;
  46: static char *rflagp = rflags;
  47: static char **loadargs;
  48: static char **loadp;
  49: 
  50: static flag erred   = NO;
  51: static flag loadflag    = YES;
  52: static flag saveasmflag = NO;
  53: static flag profileflag = NO;
  54: static flag optimflag   = NO;
  55: static flag debugflag   = NO;
  56: static flag verbose = NO;
  57: static flag nofloating  = NO;
  58: static flag fortonly    = NO;
  59: static flag macroflag   = NO;
  60: 
  61: 
  62: main(argc, argv)
  63: int argc;
  64: char **argv;
  65: {
  66: int i, c, status;
  67: char *setdoto(), *lastchar(), *lastfield();
  68: ptr ckalloc();
  69: register char *s;
  70: char fortfile[20], *t;
  71: char buff[100];
  72: int intrupt();
  73: 
  74: sigivalue = (int) signal(SIGINT, 1) & 01;
  75: sigqvalue = (int) signal(SIGQUIT,1) & 01;
  76: sighvalue = (int) signal(SIGHUP, 1) & 01;
  77: sigtvalue = (int) signal(SIGTERM,1) & 01;
  78: enbint(intrupt);
  79: 
  80: pid = getpid();
  81: crfnames();
  82: 
  83: loadargs = (char **) ckalloc( (argc+20) * sizeof(*loadargs) );
  84: loadargs[1] = "-X";
  85: loadargs[2] = "-u";
  86: #if HERE==PDP11 || HERE==VAX
  87:     loadargs[3] = "_MAIN__";
  88: #endif
  89: #if HERE == INTERDATA
  90:     loadargs[3] = "main";
  91: #endif
  92: loadp = loadargs + 4;
  93: 
  94: --argc;
  95: ++argv;
  96: 
  97: while(argc>0 && argv[0][0]=='-' && argv[0][1]!='\0')
  98:     {
  99:     for(s = argv[0]+1 ; *s ; ++s) switch(*s)
 100:         {
 101:         case 'T':  /* use special passes */
 102:             switch(*++s)
 103:                 {
 104:                 case '1':
 105:                     pass1name = s+1; goto endfor;
 106:                 case '2':
 107:                     pass2name = s+1; goto endfor;
 108:                 case 'a':
 109:                     asmname = s+1; goto endfor;
 110:                 case 'l':
 111:                     ldname = s+1; goto endfor;
 112:                 case 'F':
 113:                     footname = s+1; goto endfor;
 114:                 case 'm':
 115:                     macroname = s+1; goto endfor;
 116:                 default:
 117:                     fatal1("bad option -T%c", *s);
 118:                 }
 119:             break;
 120: 
 121:         case 'w':
 122:             if(s[1]=='6' && s[2]=='6')
 123:                 {
 124:                 *fflagp++ = *s++;
 125:                 *fflagp++ = *s++;
 126:                 }
 127: 
 128:         copyfflag:
 129:         case 'u':
 130:         case 'U':
 131:         case 'M':
 132:         case '1':
 133:         case 'C':
 134:             *fflagp++ = *s;
 135:             break;
 136: 
 137:         case 'O':
 138:             optimflag = YES;
 139: #if TARGET == INTERDATA
 140:                 *loadp++ = "-r";
 141:                 *loadp++ = "-d";
 142: #endif
 143:             *fflagp++ = 'O';
 144:             if( isdigit(s[1]) )
 145:                 *fflagp++ = *++s;
 146:             break;
 147: 
 148:         case 'm':
 149:             if(s[1] == '4')
 150:                 ++s;
 151:             macroflag = YES;
 152:             break;
 153: 
 154:         case 'S':
 155:             saveasmflag = YES;
 156: 
 157:         case 'c':
 158:             loadflag = NO;
 159:             break;
 160: 
 161:         case 'v':
 162:             verbose = YES;
 163:             break;
 164: 
 165:         case 'd':
 166:             debugflag = YES;
 167:             goto copyfflag;
 168: 
 169:         case 'p':
 170:             profileflag = YES;
 171:             *cflagp++ = 'p';
 172:             goto copyfflag;
 173: 
 174:         case 'o':
 175:             if( ! strcmp(s, "onetrip") )
 176:                 {
 177:                 *fflagp++ = '1';
 178:                 goto endfor;
 179:                 }
 180:             aoutname = *++argv;
 181:             --argc;
 182:             break;
 183: 
 184: #if TARGET == PDP11
 185:         case 'f':
 186:             nofloating = YES;
 187:             pass2name = NOFLPASS2;
 188:         break;
 189: #endif
 190: 
 191:         case 'F':
 192:             fortonly = YES;
 193:             loadflag = NO;
 194:             break;
 195: 
 196:         case 'I':
 197:             if(s[1]=='2' || s[1]=='4' || s[1]=='s')
 198:                 {
 199:                 *fflagp++ = *s++;
 200:                 goto copyfflag;
 201:                 }
 202:             fprintf(diagfile, "invalid flag -I%c\n", s[1]);
 203:             done(1);
 204: 
 205:         case 'l':   /* letter ell--library */
 206:             s[-1] = '-';
 207:             *loadp++ = s-1;
 208:             goto endfor;
 209: 
 210:         case 'E':   /* EFL flag argument */
 211:             while( *eflagp++ = *++s)
 212:                 ;
 213:             *eflagp++ = ' ';
 214:             goto endfor;
 215:         case 'R':
 216:             while( *rflagp++ = *++s )
 217:                 ;
 218:             *rflagp++ = ' ';
 219:             goto endfor;
 220:         default:
 221:             lflag[1] = *s;
 222:             *loadp++ = copys(lflag);
 223:             break;
 224:         }
 225: endfor:
 226:     --argc;
 227:     ++argv;
 228:     }
 229: 
 230: loadargs[0] = ldname;
 231: #if TARGET == PDP11
 232:     if(nofloating)
 233:         *loadp++ = (profileflag ? NOFLPROF : NOFLFOOT);
 234:     else
 235: #endif
 236: *loadp++ = (profileflag ? proffoot : footname);
 237: 
 238: for(i = 0 ; i<argc ; ++i)
 239:     switch(c =  dotchar(infname = argv[i]) )
 240:         {
 241:         case 'r':   /* Ratfor file */
 242:         case 'e':   /* EFL file */
 243:             if( unreadable(argv[i]) )
 244:                 {
 245:                 erred = YES;
 246:                 break;
 247:                 }
 248:             s = fortfile;
 249:             t = lastfield(argv[i]);
 250:             while( *s++ = *t++)
 251:                 ;
 252:             s[-2] = 'f';
 253: 
 254:             if(macroflag)
 255:                 {
 256:                 if(sys(sprintf(buff, "%s %s >%s", macroname, infname, prepfname) ))
 257:                     {
 258:                     rmf(prepfname);
 259:                     erred = YES;
 260:                     break;
 261:                     }
 262:                 infname = prepfname;
 263:                 }
 264: 
 265:             if(c == 'e')
 266:                 sprintf(buff, "efl %s %s >%s", eflags, infname, fortfile);
 267:             else
 268:                 sprintf(buff, "ratfor %s %s >%s", rflags, infname, fortfile);
 269:             status = sys(buff);
 270:             if(macroflag)
 271:                 rmf(infname);
 272:             if(status)
 273:                 {
 274:                 erred = YES;
 275:                 rmf(fortfile);
 276:                 break;
 277:                 }
 278: 
 279:             if( ! fortonly )
 280:                 {
 281:                 infname = argv[i] = lastfield(argv[i]);
 282:                 *lastchar(infname) = 'f';
 283: 
 284:                 if( dofort(argv[i]) )
 285:                     erred = YES;
 286:                 else    {
 287:                     if( nodup(t = setdoto(argv[i])) )
 288:                         *loadp++ = t;
 289:                     rmf(fortfile);
 290:                     }
 291:                 }
 292:             break;
 293: 
 294:         case 'f':   /* Fortran file */
 295:         case 'F':
 296:             if( unreadable(argv[i]) )
 297:                 erred = YES;
 298:             else if( dofort(argv[i]) )
 299:                 erred = YES;
 300:             else if( nodup(t=setdoto(argv[i])) )
 301:                 *loadp++ = t;
 302:             break;
 303: 
 304:         case 'c':   /* C file */
 305:         case 's':   /* Assembler file */
 306:             if( unreadable(argv[i]) )
 307:                 {
 308:                 erred = YES;
 309:                 break;
 310:                 }
 311: #if HERE==PDP11 || HERE==VAX
 312:             fprintf(diagfile, "%s:\n", argv[i]);
 313: #endif
 314:             sprintf(buff, "cc -c %s", argv[i] );
 315:             if( sys(buff) )
 316:                 erred = YES;
 317:             else
 318:                 if( nodup(t = setdoto(argv[i])) )
 319:                     *loadp++ = t;
 320:             break;
 321: 
 322:         case 'o':
 323:             if( nodup(argv[i]) )
 324:                 *loadp++ = argv[i];
 325:             break;
 326: 
 327:         default:
 328:             if( ! strcmp(argv[i], "-o") )
 329:                 aoutname = argv[++i];
 330:             else
 331:                 *loadp++ = argv[i];
 332:             break;
 333:         }
 334: 
 335: if(loadflag && !erred)
 336:     doload(loadargs, loadp);
 337: done(erred);
 338: }
 339: 
 340: dofort(s)
 341: char *s;
 342: {
 343: int retcode;
 344: char buff[200];
 345: 
 346: infname = s;
 347: sprintf(buff, "%s %s %s %s %s %s",
 348:     pass1name, fflags, s, asmfname, initfname, textfname);
 349: switch( sys(buff) )
 350:     {
 351:     case 1:
 352:         goto error;
 353:     case 0:
 354:         break;
 355:     default:
 356:         goto comperror;
 357:     }
 358: 
 359: if(content(initfname) > 0)
 360:     if( dodata() )
 361:         goto error;
 362: if( dopass2() )
 363:     goto comperror;
 364: doasm(s);
 365: retcode = 0;
 366: 
 367: ret:
 368:     rmf(asmfname);
 369:     rmf(initfname);
 370:     rmf(textfname);
 371:     return(retcode);
 372: 
 373: error:
 374:     fprintf(diagfile, "\nError.  No assembly.\n");
 375:     retcode = 1;
 376:     goto ret;
 377: 
 378: comperror:
 379:     fprintf(diagfile, "\ncompiler error.\n");
 380:     retcode = 2;
 381:     goto ret;
 382: }
 383: 
 384: 
 385: 
 386: 
 387: dopass2()
 388: {
 389: char buff[100];
 390: 
 391: if(verbose)
 392:     fprintf(diagfile, "PASS2.");
 393: 
 394: #if FAMILY==DMR
 395:     sprintf(buff, "%s %s - %s", pass2name, textfname, asmpass2);
 396:     return( sys(buff) );
 397: #endif
 398: 
 399: #if FAMILY == SCJ
 400: #	if TARGET==INTERDATA
 401:     sprintf(buff, "%s -A%s <%s >%s", pass2name, setfname, textfname, asmpass2);
 402: #	else
 403:     sprintf(buff, "%s <%s >%s", pass2name, textfname, asmpass2);
 404: #	endif
 405:     return( sys(buff) );
 406: #endif
 407: }
 408: 
 409: 
 410: 
 411: 
 412: doasm(s)
 413: char *s;
 414: {
 415: register char *lastc;
 416: char *obj;
 417: char buff[200];
 418: 
 419: if(*s == '\0')
 420:     s = objfdefault;
 421: lastc = lastchar(s);
 422: obj = setdoto(s);
 423: 
 424: #if TARGET==PDP11 || TARGET==VAX
 425: #ifdef PASS2OPT
 426: if(optimflag)
 427:     {
 428:     if( sys(sprintf(buff, "%s %s %s", PASS2OPT, asmpass2, optzfname)) )
 429:         rmf(optzfname);
 430:     else
 431:         sys(sprintf(buff,"mv %s %s", optzfname, asmpass2));
 432:     }
 433: #endif
 434: #endif
 435: 
 436: if(saveasmflag)
 437:     {
 438:     *lastc = 's';
 439: #if TARGET == INTERDATA
 440:     sys( sprintf(buff, "cat %s %s %s >%s",
 441:         asmfname, setfname, asmpass2, obj) );
 442: #else
 443:     sys( sprintf(buff, "cat %s %s >%s",
 444:             asmfname, asmpass2, obj) );
 445: #endif
 446:     *lastc = 'o';
 447:     }
 448: else
 449:     {
 450:     if(verbose)
 451:         fprintf(diagfile, "  ASM.");
 452: #if TARGET == INTERDATA
 453:     sprintf(buff, "%s -o %s %s %s %s", asmname, obj, asmfname, setfname, asmpass2);
 454: #endif
 455: 
 456: #if TARGET == VAX
 457:     /* vax assembler currently accepts only one input file */
 458:     sys(sprintf(buff, "cat %s >>%s", asmpass2, asmfname));
 459:     sprintf(buff, "%s -o %s %s", asmname, obj, asmfname);
 460: #endif
 461: 
 462: #if TARGET == PDP11
 463:     sprintf(buff, "%s -u -o %s %s %s", asmname, obj, asmfname, asmpass2);
 464: #endif
 465: 
 466: #if TARGET!=INTERDATA && TARGET!=PDP11 && TARGET!=VAX
 467:     sprintf(buff, "%s -o %s %s %s", asmname, obj, asmfname, asmpass2);
 468: #endif
 469: 
 470:     if( sys(buff) )
 471:         fatal("assembler error");
 472:     if(verbose)
 473:         fprintf(diagfile, "\n");
 474: #if HERE==PDP11 && TARGET!=PDP11
 475:     rmf(obj);
 476: #endif
 477:     }
 478: 
 479: rmf(asmpass2);
 480: }
 481: 
 482: 
 483: 
 484: doload(v0, v)
 485: register char *v0[], *v[];
 486: {
 487: char **p;
 488: int waitpid;
 489: 
 490: for(p = liblist ; *p ; *v++ = *p++)
 491:     ;
 492: 
 493: *v++ = "-o";
 494: *v++ = aoutname;
 495: *v = NULL;
 496: 
 497: if(verbose)
 498:     fprintf(diagfile, "LOAD.");
 499: if(debugflag)
 500:     {
 501:     for(p = v0 ; p<v ; ++p)
 502:         fprintf(diagfile, "%s ", *p);
 503:     fprintf(diagfile, "\n");
 504:     }
 505: 
 506: #if HERE==PDP11 || HERE==INTERDATA || HERE==VAX
 507:     if( (waitpid = fork()) == 0)
 508:         {
 509:         enbint(SIG_DFL);
 510:         execv(ldname, v0);
 511:         fatal1("couldn't load %s", ldname);
 512:         }
 513:     await(waitpid);
 514: #endif
 515: 
 516: #if HERE==INTERDATA
 517:     if(optimflag)
 518:         {
 519:         char buff[100];
 520:         if( sys(sprintf(buff, "nopt %s -o junk.%d", aoutname, pid))
 521:          || sys(sprintf(buff, "mv junk.%d %s", pid, aoutname)) )
 522:             err("bad optimization");
 523:         }
 524: #endif
 525: 
 526: if(verbose)
 527:     fprintf(diagfile, "\n");
 528: }
 529: 
 530: /* Process control and Shell-simulating routines */
 531: 
 532: sys(str)
 533: char *str;
 534: {
 535: register char *s, *t;
 536: char *argv[100], path[100];
 537: char *inname, *outname;
 538: int append;
 539: int waitpid;
 540: int argc;
 541: 
 542: 
 543: if(debugflag)
 544:     fprintf(diagfile, "%s\n", str);
 545: inname  = NULL;
 546: outname = NULL;
 547: argv[0] = shellname;
 548: argc = 1;
 549: 
 550: t = str;
 551: while( isspace(*t) )
 552:     ++t;
 553: while(*t)
 554:     {
 555:     if(*t == '<')
 556:         inname = t+1;
 557:     else if(*t == '>')
 558:         {
 559:         if(t[1] == '>')
 560:             {
 561:             append = YES;
 562:             outname = t+2;
 563:             }
 564:         else    {
 565:             append = NO;
 566:             outname = t+1;
 567:             }
 568:         }
 569:     else
 570:         argv[argc++] = t;
 571:     while( !isspace(*t) && *t!='\0' )
 572:         ++t;
 573:     if(*t)
 574:         {
 575:         *t++ = '\0';
 576:         while( isspace(*t) )
 577:             ++t;
 578:         }
 579:     }
 580: 
 581: if(argc == 1)   /* no command */
 582:     return(-1);
 583: argv[argc] = 0;
 584: 
 585: s = path;
 586: t = "/usr/bin/";
 587: while(*t)
 588:     *s++ = *t++;
 589: for(t = argv[1] ; *s++ = *t++ ; )
 590:     ;
 591: if((waitpid = fork()) == 0)
 592:     {
 593:     if(inname)
 594:         freopen(inname, "r", stdin);
 595:     if(outname)
 596:         freopen(outname, (append ? "a" : "w"), stdout);
 597:     enbint(SIG_DFL);
 598: 
 599:     texec(path+9, argv);  /* command */
 600:     texec(path+4, argv);  /*  /bin/command */
 601:     texec(path  , argv);  /* /usr/bin/command */
 602: 
 603:     fatal1("Cannot load %s",path+9);
 604:     }
 605: 
 606: return( await(waitpid) );
 607: }
 608: 
 609: 
 610: 
 611: 
 612: 
 613: #include "errno.h"
 614: 
 615: /* modified version from the Shell */
 616: texec(f, av)
 617: char *f;
 618: char **av;
 619: {
 620: extern int errno;
 621: 
 622: execv(f, av+1);
 623: 
 624: if (errno==ENOEXEC)
 625:     {
 626:     av[1] = f;
 627:     execv(shellname, av);
 628:     fatal("No shell!");
 629:     }
 630: if (errno==ENOMEM)
 631:     fatal1("%s: too large", f);
 632: }
 633: 
 634: 
 635: 
 636: 
 637: 
 638: 
 639: done(k)
 640: int k;
 641: {
 642: static int recurs   = NO;
 643: 
 644: if(recurs == NO)
 645:     {
 646:     recurs = YES;
 647:     rmfiles();
 648:     }
 649: exit(k);
 650: }
 651: 
 652: 
 653: 
 654: 
 655: 
 656: 
 657: enbint(k)
 658: int (*k)();
 659: {
 660: if(sigivalue == 0)
 661:     signal(SIGINT,k);
 662: if(sigqvalue == 0)
 663:     signal(SIGQUIT,k);
 664: if(sighvalue == 0)
 665:     signal(SIGHUP,k);
 666: if(sigtvalue == 0)
 667:     signal(SIGTERM,k);
 668: }
 669: 
 670: 
 671: 
 672: 
 673: intrupt()
 674: {
 675: done(2);
 676: }
 677: 
 678: 
 679: 
 680: await(waitpid)
 681: int waitpid;
 682: {
 683: int w, status;
 684: 
 685: enbint(SIG_IGN);
 686: while ( (w = wait(&status)) != waitpid)
 687:     if(w == -1)
 688:         fatal("bad wait code");
 689: enbint(intrupt);
 690: if(status & 0377)
 691:     {
 692:     if(status != SIGINT)
 693:         fprintf(diagfile, "Termination code %d", status);
 694:     done(3);
 695:     }
 696: return(status>>8);
 697: }
 698: 
 699: /* File Name and File Manipulation Routines */
 700: 
 701: unreadable(s)
 702: register char *s;
 703: {
 704: register FILE *fp;
 705: 
 706: if(fp = fopen(s, "r"))
 707:     {
 708:     fclose(fp);
 709:     return(NO);
 710:     }
 711: 
 712: else
 713:     {
 714:     fprintf(diagfile, "Error: Cannot read file %s\n", s);
 715:     return(YES);
 716:     }
 717: }
 718: 
 719: 
 720: 
 721: clf(p)
 722: FILEP *p;
 723: {
 724: if(p!=NULL && *p!=NULL && *p!=stdout)
 725:     {
 726:     if(ferror(*p))
 727:         fatal("writing error");
 728:     fclose(*p);
 729:     }
 730: *p = NULL;
 731: }
 732: 
 733: rmfiles()
 734: {
 735: rmf(textfname);
 736: rmf(asmfname);
 737: rmf(initfname);
 738: rmf(asmpass2);
 739: #if TARGET == INTERDATA
 740:     rmf(setfname);
 741: #endif
 742: }
 743: 
 744: 
 745: 
 746: 
 747: 
 748: 
 749: 
 750: 
 751: /* return -1 if file does not exist, 0 if it is of zero length
 752:    and 1 if of positive length
 753: */
 754: content(filename)
 755: char *filename;
 756: {
 757: #ifdef VERSION6
 758:     struct stat
 759:         {
 760:         char cjunk[9];
 761:         char size0;
 762:         int size1;
 763:         int ijunk[12];
 764:         } buf;
 765: #else
 766: #	include <sys/types.h>
 767: #	include <sys/stat.h>
 768:     struct stat buf;
 769: #endif
 770: 
 771: if(stat(filename,&buf) < 0)
 772:     return(-1);
 773: #ifdef VERSION6
 774:     return(buf.size0 || buf.size1);
 775: #else
 776:     return( buf.st_size > 0 );
 777: #endif
 778: }
 779: 
 780: 
 781: 
 782: 
 783: crfnames()
 784: {
 785: fname(textfname, "x");
 786: fname(asmfname, "s");
 787: fname(asmpass2, "a");
 788: fname(initfname, "d");
 789: fname(sortfname, "S");
 790: fname(objfdefault, "o");
 791: fname(prepfname, "p");
 792: fname(optzfname, "z");
 793: fname(setfname, "A");
 794: }
 795: 
 796: 
 797: 
 798: 
 799: rmf(fn)
 800: register char *fn;
 801: {
 802: if(!debugflag && fn!=NULL && *fn!='\0')
 803:     unlink(fn);
 804: }
 805: 
 806: 
 807: 
 808: 
 809: 
 810: LOCAL fname(name, suff)
 811: char *name, *suff;
 812: {
 813: sprintf(name, "fort%d.%s", pid, suff);
 814: }
 815: 
 816: 
 817: 
 818: 
 819: dotchar(s)
 820: register char *s;
 821: {
 822: for( ; *s ; ++s)
 823:     if(s[0]=='.' && s[1]!='\0' && s[2]=='\0')
 824:         return( s[1] );
 825: return(NO);
 826: }
 827: 
 828: 
 829: 
 830: char *lastfield(s)
 831: register char *s;
 832: {
 833: register char *t;
 834: for(t = s; *s ; ++s)
 835:     if(*s == '/')
 836:         t = s+1;
 837: return(t);
 838: }
 839: 
 840: 
 841: 
 842: char *lastchar(s)
 843: register char *s;
 844: {
 845: while(*s)
 846:     ++s;
 847: return(s-1);
 848: }
 849: 
 850: char *setdoto(s)
 851: register char *s;
 852: {
 853: *lastchar(s) = 'o';
 854: return( lastfield(s) );
 855: }
 856: 
 857: 
 858: 
 859: badfile(s)
 860: char *s;
 861: {
 862: fatal1("cannot open intermediate file %s", s);
 863: }
 864: 
 865: 
 866: 
 867: ptr ckalloc(n)
 868: int n;
 869: {
 870: ptr p, calloc();
 871: 
 872: if( p = calloc(1, (unsigned) n) )
 873:     return(p);
 874: 
 875: fatal("out of memory");
 876: /* NOTREACHED */
 877: }
 878: 
 879: 
 880: 
 881: 
 882: 
 883: copyn(n, s)
 884: register int n;
 885: register char *s;
 886: {
 887: register char *p, *q;
 888: 
 889: p = q = (char *) ckalloc(n);
 890: while(n-- > 0)
 891:     *q++ = *s++;
 892: return(p);
 893: }
 894: 
 895: 
 896: 
 897: copys(s)
 898: char *s;
 899: {
 900: return( copyn( strlen(s)+1 , s) );
 901: }
 902: 
 903: 
 904: 
 905: 
 906: 
 907: nodup(s)
 908: char *s;
 909: {
 910: register char **p;
 911: 
 912: for(p = loadargs ; p < loadp ; ++p)
 913:     if( !strcmp(*p, s) )
 914:         return(NO);
 915: 
 916: return(YES);
 917: }
 918: 
 919: 
 920: 
 921: static fatal(t)
 922: char *t;
 923: {
 924: fprintf(diagfile, "Compiler error in file %s: %s\n", infname, t);
 925: if(debugflag)
 926:     abort();
 927: done(1);
 928: exit(1);
 929: }
 930: 
 931: 
 932: 
 933: 
 934: static fatal1(t,d)
 935: char *t, *d;
 936: {
 937: char buff[100];
 938: fatal( sprintf(buff, t, d) );
 939: }
 940: 
 941: 
 942: 
 943: 
 944: err(s)
 945: char *s;
 946: {
 947: fprintf(diagfile, "Error in file %s: %s\n", infname, s);
 948: }
 949: 
 950: LOCAL int nch   = 0;
 951: LOCAL FILEP asmfile;
 952: LOCAL FILEP sortfile;
 953: 
 954: #include "ftypes"
 955: 
 956: static ftnint typesize[NTYPES]
 957:     = { 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
 958:         2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 1};
 959: static int typealign[NTYPES]
 960:     = { 1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
 961:         ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1};
 962: 
 963: dodata()
 964: {
 965: char buff[50];
 966: char varname[XL+1], ovarname[XL+1];
 967: int status;
 968: flag erred;
 969: ftnint offset, vlen, type;
 970: register ftnint ooffset, ovlen;
 971: ftnint vchar;
 972: int size, align;
 973: int vargroup;
 974: ftnint totlen, doeven();
 975: 
 976: erred = NO;
 977: ovarname[0] = '\0';
 978: ooffset = 0;
 979: ovlen = 0;
 980: totlen = 0;
 981: nch = 0;
 982: 
 983: if(status = sys( sprintf(buff, "sort %s >%s", initfname, sortfname) ) )
 984:     fatal1("call sort status = %d", status);
 985: if( (sortfile = fopen(sortfname, "r")) == NULL)
 986:     badfile(sortfname);
 987: if( (asmfile = fopen(asmfname, "a")) == NULL)
 988:     badfile(asmfname);
 989: pruse(asmfile, USEINIT);
 990: 
 991: while( rdname(&vargroup, varname) && rdlong(&offset) && rdlong(&vlen) && rdlong(&type) )
 992:     {
 993:     size = typesize[type];
 994:     if( strcmp(varname, ovarname) )
 995:         {
 996:         prspace(ovlen-ooffset);
 997:         strcpy(ovarname, varname);
 998:         ooffset = 0;
 999:         totlen += ovlen;
1000:         ovlen = vlen;
1001:         if(vargroup == 0)
1002:             align = (type==TYCHAR ? SZLONG : typealign[type]);
1003:         else    align = ALIDOUBLE;
1004:         totlen = doeven(totlen, align);
1005:         if(vargroup == 2)
1006:             prcomblock(asmfile, varname);
1007:         else
1008:             fprintf(asmfile, LABELFMT, varname);
1009:         }
1010:     if(offset < ooffset)
1011:         {
1012:         erred = YES;
1013:         err("overlapping initializations");
1014:         }
1015:     if(offset > ooffset)
1016:         {
1017:         prspace(offset-ooffset);
1018:         ooffset = offset;
1019:         }
1020:     if(type == TYCHAR)
1021:         {
1022:         if( ! rdlong(&vchar) )
1023:             fatal("bad intermediate file format");
1024:         prch( (int) vchar );
1025:         }
1026:     else
1027:         {
1028:         putc('\t', asmfile);
1029:         while   ( putc( getc(sortfile), asmfile)  != '\n')
1030:             ;
1031:         }
1032:     if( (ooffset += size) > ovlen)
1033:         {
1034:         erred = YES;
1035:         err("initialization out of bounds");
1036:         }
1037:     }
1038: 
1039: prspace(ovlen-ooffset);
1040: totlen = doeven(totlen+ovlen, (ALIDOUBLE>SZLONG ? ALIDOUBLE : SZLONG) );
1041: clf(&sortfile);
1042: clf(&asmfile);
1043: clf(&sortfile);
1044: rmf(sortfname);
1045: return(erred);
1046: }
1047: 
1048: 
1049: 
1050: 
1051: prspace(n)
1052: register ftnint n;
1053: {
1054: register ftnint m;
1055: 
1056: while(nch>0 && n>0)
1057:     {
1058:     --n;
1059:     prch(0);
1060:     }
1061: m = SZSHORT * (n/SZSHORT);
1062: if(m > 0)
1063:     prskip(asmfile, m);
1064: for(n -= m ; n>0 ; --n)
1065:     prch(0);
1066: }
1067: 
1068: 
1069: 
1070: 
1071: ftnint doeven(tot, align)
1072: register ftnint tot;
1073: int align;
1074: {
1075: ftnint new;
1076: new = roundup(tot, align);
1077: prspace(new - tot);
1078: return(new);
1079: }
1080: 
1081: 
1082: 
1083: rdname(vargroupp, name)
1084: int *vargroupp;
1085: register char *name;
1086: {
1087: register int i, c;
1088: 
1089: if( (c = getc(sortfile)) == EOF)
1090:     return(NO);
1091: *vargroupp = c - '0';
1092: 
1093: for(i = 0 ; i<XL ; ++i)
1094:     {
1095:     if( (c = getc(sortfile)) == EOF)
1096:         return(NO);
1097:     if(c != ' ')
1098:         *name++ = c;
1099:     }
1100: *name = '\0';
1101: return(YES);
1102: }
1103: 
1104: 
1105: 
1106: rdlong(n)
1107: register ftnint *n;
1108: {
1109: register int c;
1110: 
1111: for(c = getc(sortfile) ; c!=EOF && isspace(c) ; c = getc(sortfile) );
1112:     ;
1113: if(c == EOF)
1114:     return(NO);
1115: 
1116: for(*n = 0 ; isdigit(c) ; c = getc(sortfile) )
1117:     *n = 10* (*n) + c - '0';
1118: return(YES);
1119: }
1120: 
1121: 
1122: 
1123: 
1124: prch(c)
1125: register int c;
1126: {
1127: static int buff[SZSHORT];
1128: 
1129: buff[nch++] = c;
1130: if(nch == SZSHORT)
1131:     {
1132:     prchars(asmfile, buff);
1133:     nch = 0;
1134:     }
1135: }

Defined functions

Defined variables

Defined struct's