![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to proc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1 |
1.1 ! root 1: /* @(#)proc.c 1.4 (Berkeley) 6/1/81 */ ! 2: #include "defs.h" ! 3: #include "machdefs.h" ! 4: ! 5: #ifdef SDB ! 6: # include <a.out.h> ! 7: # ifndef N_SO ! 8: # include <stab.h> ! 9: # endif ! 10: #endif ! 11: ! 12: ! 13: typedef ! 14: struct SizeList ! 15: { ! 16: struct SizeList *next; ! 17: ftnint size; ! 18: struct VarList *vars; ! 19: } ! 20: sizelist; ! 21: ! 22: ! 23: typedef ! 24: struct VarList ! 25: { ! 26: struct VarList *next; ! 27: Namep np; ! 28: struct Equivblock *ep; ! 29: } ! 30: varlist; ! 31: ! 32: ! 33: LOCAL sizelist *varsizes; ! 34: ! 35: ! 36: /* start a new procedure */ ! 37: ! 38: newproc() ! 39: { ! 40: if(parstate != OUTSIDE) ! 41: { ! 42: execerr("missing end statement", CNULL); ! 43: endproc(); ! 44: } ! 45: ! 46: parstate = INSIDE; ! 47: procclass = CLMAIN; /* default */ ! 48: } ! 49: ! 50: ! 51: ! 52: /* end of procedure. generate variables, epilogs, and prologs */ ! 53: ! 54: endproc() ! 55: { ! 56: struct Labelblock *lp; ! 57: ! 58: if(parstate < INDATA) ! 59: enddcl(); ! 60: if(ctlstack >= ctls) ! 61: err("DO loop or BLOCK IF not closed"); ! 62: for(lp = labeltab ; lp < labtabend ; ++lp) ! 63: if(lp->stateno!=0 && lp->labdefined==NO) ! 64: errstr("missing statement number %s", convic(lp->stateno) ); ! 65: ! 66: if (optimflag) ! 67: optimize(); ! 68: ! 69: outiodata(); ! 70: epicode(); ! 71: procode(); ! 72: donmlist(); ! 73: dobss(); ! 74: ! 75: #if FAMILY == PCC ! 76: putbracket(); ! 77: #endif ! 78: fixlwm(); ! 79: procinit(); /* clean up for next procedure */ ! 80: } ! 81: ! 82: ! 83: ! 84: /* End of declaration section of procedure. Allocate storage. */ ! 85: ! 86: enddcl() ! 87: { ! 88: register struct Entrypoint *ep; ! 89: ! 90: parstate = INEXEC; ! 91: docommon(); ! 92: doequiv(); ! 93: docomleng(); ! 94: for(ep = entries ; ep ; ep = ep->entnextp) { ! 95: doentry(ep); ! 96: #ifdef SDB ! 97: if(sdbflag) ! 98: { ! 99: entrystab(ep,procclass); ! 100: } ! 101: #endif ! 102: } ! 103: } ! 104: ! 105: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ ! 106: ! 107: /* Main program or Block data */ ! 108: ! 109: startproc(progname, class) ! 110: struct Extsym * progname; ! 111: int class; ! 112: { ! 113: register struct Entrypoint *p; ! 114: ! 115: p = ALLOC(Entrypoint); ! 116: if(class == CLMAIN) ! 117: puthead("MAIN_", CLMAIN); ! 118: else ! 119: puthead(CNULL, CLBLOCK); ! 120: if(class == CLMAIN) ! 121: newentry( mkname(5, "MAIN") ); ! 122: p->entryname = progname; ! 123: p->entrylabel = newlabel(); ! 124: entries = p; ! 125: ! 126: procclass = class; ! 127: retlabel = newlabel(); ! 128: fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); ! 129: if(progname) ! 130: fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) ); ! 131: fprintf(diagfile, ":\n"); ! 132: #ifdef SDB ! 133: if(sdbflag) { ! 134: entrystab(p,class); ! 135: } ! 136: #endif ! 137: } ! 138: ! 139: /* subroutine or function statement */ ! 140: ! 141: struct Extsym *newentry(v) ! 142: register Namep v; ! 143: { ! 144: register struct Extsym *p; ! 145: ! 146: p = mkext( varunder(VL, v->varname) ); ! 147: ! 148: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) ! 149: { ! 150: if(p == 0) ! 151: dclerr("invalid entry name", v); ! 152: else dclerr("external name already used", v); ! 153: return(0); ! 154: } ! 155: v->vstg = STGAUTO; ! 156: v->vprocclass = PTHISPROC; ! 157: v->vclass = CLPROC; ! 158: p->extstg = STGEXT; ! 159: p->extinit = YES; ! 160: return(p); ! 161: } ! 162: ! 163: ! 164: entrypt(class, type, length, entry, args) ! 165: int class, type; ! 166: ftnint length; ! 167: struct Extsym *entry; ! 168: chainp args; ! 169: { ! 170: register Namep q; ! 171: register struct Entrypoint *p, *ep; ! 172: ! 173: if(class != CLENTRY) ! 174: puthead( varstr(XL, procname = entry->extname), class); ! 175: if(class == CLENTRY) ! 176: fprintf(diagfile, " entry "); ! 177: fprintf(diagfile, " %s:\n", nounder(XL, entry->extname)); ! 178: q = mkname(VL, nounder(XL,entry->extname) ); ! 179: ! 180: if( (type = lengtype(type, (int) length)) != TYCHAR) ! 181: length = 0; ! 182: if(class == CLPROC) ! 183: { ! 184: procclass = CLPROC; ! 185: proctype = type; ! 186: procleng = length; ! 187: ! 188: retlabel = newlabel(); ! 189: if(type == TYSUBR) ! 190: ret0label = newlabel(); ! 191: } ! 192: ! 193: p = ALLOC(Entrypoint); ! 194: ! 195: if(entries) /* put new block at end of entries list */ ! 196: { ! 197: for(ep = entries; ep->entnextp; ep = ep->entnextp) ! 198: ; ! 199: ep->entnextp = p; ! 200: } ! 201: else ! 202: entries = p; ! 203: ! 204: p->entryname = entry; ! 205: p->arglist = args; ! 206: p->entrylabel = newlabel(); ! 207: p->enamep = q; ! 208: ! 209: if(class == CLENTRY) ! 210: { ! 211: class = CLPROC; ! 212: if(proctype == TYSUBR) ! 213: type = TYSUBR; ! 214: } ! 215: ! 216: q->vclass = class; ! 217: q->vprocclass = PTHISPROC; ! 218: settype(q, type, (int) length); ! 219: /* hold all initial entry points till end of declarations */ ! 220: if(parstate >= INDATA) { ! 221: doentry(p); ! 222: } ! 223: #ifdef SDB ! 224: if(sdbflag) ! 225: { /* may need to preserve CLENTRY here */ ! 226: entrystab(p,class); ! 227: } ! 228: #endif ! 229: } ! 230: ! 231: /* generate epilogs */ ! 232: ! 233: LOCAL epicode() ! 234: { ! 235: register int i; ! 236: ! 237: if(procclass==CLPROC) ! 238: { ! 239: if(proctype==TYSUBR) ! 240: { ! 241: putlabel(ret0label); ! 242: if(substars) ! 243: putforce(TYINT, ICON(0) ); ! 244: putlabel(retlabel); ! 245: goret(TYSUBR); ! 246: } ! 247: else { ! 248: putlabel(retlabel); ! 249: if(multitype) ! 250: { ! 251: typeaddr = autovar(1, TYADDR, PNULL); ! 252: putbranch( cpexpr(typeaddr) ); ! 253: for(i = 0; i < NTYPES ; ++i) ! 254: if(rtvlabel[i] != 0) ! 255: { ! 256: putlabel(rtvlabel[i]); ! 257: retval(i); ! 258: } ! 259: } ! 260: else ! 261: retval(proctype); ! 262: } ! 263: } ! 264: ! 265: else if(procclass != CLBLOCK) ! 266: { ! 267: putlabel(retlabel); ! 268: goret(TYSUBR); ! 269: } ! 270: } ! 271: ! 272: ! 273: /* generate code to return value of type t */ ! 274: ! 275: LOCAL retval(t) ! 276: register int t; ! 277: { ! 278: register Addrp p; ! 279: ! 280: switch(t) ! 281: { ! 282: case TYCHAR: ! 283: case TYCOMPLEX: ! 284: case TYDCOMPLEX: ! 285: break; ! 286: ! 287: case TYLOGICAL: ! 288: t = tylogical; ! 289: case TYADDR: ! 290: case TYSHORT: ! 291: case TYLONG: ! 292: p = (Addrp) cpexpr(retslot); ! 293: p->vtype = t; ! 294: putforce(t, p); ! 295: break; ! 296: ! 297: case TYREAL: ! 298: case TYDREAL: ! 299: p = (Addrp) cpexpr(retslot); ! 300: p->vtype = t; ! 301: putforce(t, p); ! 302: break; ! 303: ! 304: default: ! 305: badtype("retval", t); ! 306: } ! 307: goret(t); ! 308: } ! 309: ! 310: ! 311: /* Allocate extra argument array if needed. Generate prologs. */ ! 312: ! 313: LOCAL procode() ! 314: { ! 315: register struct Entrypoint *p; ! 316: Addrp argvec; ! 317: ! 318: #if TARGET==GCOS ! 319: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); ! 320: #else ! 321: if(lastargslot>0 && nentry>1) ! 322: #if TARGET == VAX ! 323: argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL); ! 324: #else ! 325: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); ! 326: #endif ! 327: else ! 328: argvec = NULL; ! 329: #endif ! 330: ! 331: ! 332: #if TARGET == PDP11 ! 333: /* for the optimizer */ ! 334: if(fudgelabel) ! 335: putlabel(fudgelabel); ! 336: #endif ! 337: ! 338: for(p = entries ; p ; p = p->entnextp) ! 339: prolog(p, argvec); ! 340: ! 341: #if FAMILY == PCC ! 342: putrbrack(procno); ! 343: #endif ! 344: ! 345: prendproc(); ! 346: } ! 347: ! 348: /* ! 349: manipulate argument lists (allocate argument slot positions) ! 350: * keep track of return types and labels ! 351: */ ! 352: ! 353: LOCAL doentry(ep) ! 354: struct Entrypoint *ep; ! 355: { ! 356: register int type; ! 357: register Namep np; ! 358: chainp p; ! 359: register Namep q; ! 360: Addrp mkarg(); ! 361: ! 362: ++nentry; ! 363: if(procclass == CLMAIN) ! 364: { ! 365: if (optimflag) ! 366: optbuff (SKLABEL, 0, ep->entrylabel, 0); ! 367: else ! 368: putlabel(ep->entrylabel); ! 369: return; ! 370: } ! 371: else if(procclass == CLBLOCK) ! 372: return; ! 373: ! 374: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) ); ! 375: type = np->vtype; ! 376: if(proctype == TYUNKNOWN) ! 377: if( (proctype = type) == TYCHAR) ! 378: procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)); ! 379: ! 380: if(proctype == TYCHAR) ! 381: { ! 382: if(type != TYCHAR) ! 383: err("noncharacter entry of character function"); ! 384: else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng) ! 385: err("mismatched character entry lengths"); ! 386: } ! 387: else if(type == TYCHAR) ! 388: err("character entry of noncharacter function"); ! 389: else if(type != proctype) ! 390: multitype = YES; ! 391: if(rtvlabel[type] == 0) ! 392: rtvlabel[type] = newlabel(); ! 393: ep->typelabel = rtvlabel[type]; ! 394: ! 395: if(type == TYCHAR) ! 396: { ! 397: if(chslot < 0) ! 398: { ! 399: chslot = nextarg(TYADDR); ! 400: chlgslot = nextarg(TYLENG); ! 401: } ! 402: np->vstg = STGARG; ! 403: np->vardesc.varno = chslot; ! 404: if(procleng < 0) ! 405: np->vleng = (expptr) mkarg(TYLENG, chlgslot); ! 406: } ! 407: else if( ISCOMPLEX(type) ) ! 408: { ! 409: np->vstg = STGARG; ! 410: if(cxslot < 0) ! 411: cxslot = nextarg(TYADDR); ! 412: np->vardesc.varno = cxslot; ! 413: } ! 414: else if(type != TYSUBR) ! 415: { ! 416: if(nentry == 1) ! 417: retslot = autovar(1, TYDREAL, PNULL); ! 418: np->vstg = STGAUTO; ! 419: np->voffset = retslot->memoffset->constblock.const.ci; ! 420: } ! 421: ! 422: for(p = ep->arglist ; p ; p = p->nextp) ! 423: if(! (( q = (Namep) (p->datap) )->vdcldone) ) ! 424: q->vardesc.varno = nextarg(TYADDR); ! 425: ! 426: for(p = ep->arglist ; p ; p = p->nextp) ! 427: if(! (( q = (Namep) (p->datap) )->vdcldone) ) ! 428: { ! 429: impldcl(q); ! 430: q->vdcldone = YES; ! 431: if(q->vtype == TYCHAR) ! 432: { ! 433: if(q->vleng == NULL) /* character*(*) */ ! 434: q->vleng = (expptr) ! 435: mkarg(TYLENG, nextarg(TYLENG) ); ! 436: else if(nentry == 1) ! 437: nextarg(TYLENG); ! 438: } ! 439: else if(q->vclass==CLPROC && nentry==1) ! 440: nextarg(TYLENG) ; ! 441: #ifdef SDB ! 442: if(sdbflag) { ! 443: namestab(q); ! 444: } ! 445: #endif ! 446: } ! 447: ! 448: if (optimflag) ! 449: optbuff (SKLABEL, 0, ep->entrylabel, 0); ! 450: else ! 451: putlabel(ep->entrylabel); ! 452: } ! 453: ! 454: ! 455: ! 456: LOCAL nextarg(type) ! 457: int type; ! 458: { ! 459: int k; ! 460: k = lastargslot; ! 461: lastargslot += typesize[type]; ! 462: return(k); ! 463: } ! 464: ! 465: /* generate variable references */ ! 466: ! 467: LOCAL dobss() ! 468: { ! 469: register struct Hashentry *p; ! 470: register Namep q; ! 471: register int i; ! 472: int align; ! 473: ftnint leng, iarrl; ! 474: char *memname(); ! 475: int qstg, qclass, qtype; ! 476: ! 477: pruse(asmfile, USEBSS); ! 478: varsizes = NULL; ! 479: ! 480: for(p = hashtab ; p<lasthash ; ++p) ! 481: if(q = p->varp) ! 482: { ! 483: qstg = q->vstg; ! 484: qtype = q->vtype; ! 485: qclass = q->vclass; ! 486: ! 487: ! 488: if( (qclass==CLUNKNOWN && qstg!=STGARG) || ! 489: (qclass==CLVAR && qstg==STGUNKNOWN) ) ! 490: warn1("local variable %s never used", varstr(VL,q->varname) ); ! 491: else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG) ! 492: mkext(varunder(VL, q->varname)) ->extstg = STGEXT; ! 493: ! 494: if (qclass == CLVAR && qstg == STGBSS) ! 495: { ! 496: if (SMALLVAR(q->varsize)) ! 497: { ! 498: enlist(q->varsize, q, NULL); ! 499: q->inlcomm = NO; ! 500: } ! 501: else ! 502: { ! 503: if (q->init == NO) ! 504: { ! 505: preven(ALIDOUBLE); ! 506: prlocvar(memname(qstg, q->vardesc.varno), q->varsize); ! 507: q->inlcomm = YES; ! 508: } ! 509: else ! 510: prlocdata(memname(qstg, q->vardesc.varno), q->varsize, ! 511: q->vtype, q->initoffset, &(q->inlcomm)); ! 512: } ! 513: } ! 514: else if(qclass==CLVAR && qstg!=STGARG) ! 515: { ! 516: if(q->vdim && !ISICON(q->vdim->nelt) ) ! 517: dclerr("adjustable dimension on non-argument", q); ! 518: if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng))) ! 519: dclerr("adjustable leng on nonargument", q); ! 520: } ! 521: } ! 522: ! 523: for (i = 0 ; i < nequiv ; ++i) ! 524: if ( (leng = eqvclass[i].eqvleng) != 0 ) ! 525: { ! 526: if (SMALLVAR(leng)) ! 527: enlist(leng, NULL, eqvclass + i); ! 528: else if (eqvclass[i].init == NO) ! 529: { ! 530: preven(ALIDOUBLE); ! 531: prlocvar(memname(STGEQUIV, i), leng); ! 532: eqvclass[i].inlcomm = YES; ! 533: } ! 534: else ! 535: prlocdata(memname(STGEQUIV, i), leng, TYDREAL, ! 536: eqvclass[i].initoffset, &(eqvclass[i].inlcomm)); ! 537: } ! 538: ! 539: outlocvars(); ! 540: #ifdef SDB ! 541: if(sdbflag) { ! 542: for(p = hashtab ; p<lasthash ; ++p) if(q = p->varp) { ! 543: qstg = q->vstg; ! 544: qclass = q->vclass; ! 545: if( ONEOF(qclass, M(CLVAR))) { ! 546: if (! ONEOF(qstg,M(STGCOMMON)|M(STGARG) ) ) namestab(q); ! 547: } ! 548: } ! 549: } ! 550: #endif ! 551: ! 552: close(vdatafile); ! 553: close(vchkfile); ! 554: unlink(vdatafname); ! 555: unlink(vchkfname); ! 556: vdatahwm = 0; ! 557: } ! 558: ! 559: ! 560: ! 561: donmlist() ! 562: { ! 563: register struct Hashentry *p; ! 564: register Namep q; ! 565: ! 566: pruse(asmfile, USEINIT); ! 567: ! 568: for(p=hashtab; p<lasthash; ++p) ! 569: if( (q = p->varp) && q->vclass==CLNAMELIST) ! 570: namelist(q); ! 571: } ! 572: ! 573: ! 574: doext() ! 575: { ! 576: struct Extsym *p; ! 577: ! 578: for(p = extsymtab ; p<nextext ; ++p) ! 579: prext(p); ! 580: } ! 581: ! 582: ! 583: ! 584: ! 585: ftnint iarrlen(q) ! 586: register Namep q; ! 587: { ! 588: ftnint leng; ! 589: ! 590: leng = typesize[q->vtype]; ! 591: if(leng <= 0) ! 592: return(-1); ! 593: if(q->vdim) ! 594: if( ISICON(q->vdim->nelt) ) ! 595: leng *= q->vdim->nelt->constblock.const.ci; ! 596: else return(-1); ! 597: if(q->vleng) ! 598: if( ISICON(q->vleng) ) ! 599: leng *= q->vleng->constblock.const.ci; ! 600: else return(-1); ! 601: return(leng); ! 602: } ! 603: ! 604: /* This routine creates a static block representing the namelist. ! 605: An equivalent declaration of the structure produced is: ! 606: struct namelist ! 607: { ! 608: char namelistname[16]; ! 609: struct namelistentry ! 610: { ! 611: char varname[16]; ! 612: char *varaddr; ! 613: int type; # negative means -type= number of chars ! 614: struct dimensions *dimp; # null means scalar ! 615: } names[]; ! 616: }; ! 617: ! 618: struct dimensions ! 619: { ! 620: int numberofdimensions; ! 621: int numberofelements ! 622: int baseoffset; ! 623: int span[numberofdimensions]; ! 624: }; ! 625: where the namelistentry list terminates with a null varname ! 626: If dimp is not null, then the corner element of the array is at ! 627: varaddr. However, the element with subscripts (i1,...,in) is at ! 628: varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...) ! 629: */ ! 630: ! 631: namelist(np) ! 632: Namep np; ! 633: { ! 634: register chainp q; ! 635: register Namep v; ! 636: register struct Dimblock *dp; ! 637: char *memname(); ! 638: int type, dimno, dimoffset; ! 639: flag bad; ! 640: ! 641: ! 642: preven(ALILONG); ! 643: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno)); ! 644: putstr(asmfile, varstr(VL, np->varname), 16); ! 645: dimno = ++lastvarno; ! 646: dimoffset = 0; ! 647: bad = NO; ! 648: ! 649: for(q = np->varxptr.namelist ; q ; q = q->nextp) ! 650: { ! 651: vardcl( v = (Namep) (q->datap) ); ! 652: type = v->vtype; ! 653: if( ONEOF(v->vstg, MSKSTATIC) ) ! 654: { ! 655: preven(ALILONG); ! 656: putstr(asmfile, varstr(VL,v->varname), 16); ! 657: praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset); ! 658: prconi(asmfile, TYINT, ! 659: type==TYCHAR ? ! 660: -(v->vleng->constblock.const.ci) : (ftnint) type); ! 661: if(v->vdim) ! 662: { ! 663: praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset); ! 664: dimoffset += 3 + v->vdim->ndim; ! 665: } ! 666: else ! 667: praddr(asmfile, STGNULL,0,(ftnint) 0); ! 668: } ! 669: else ! 670: { ! 671: dclerr("may not appear in namelist", v); ! 672: bad = YES; ! 673: } ! 674: } ! 675: ! 676: if(bad) ! 677: return; ! 678: ! 679: putstr(asmfile, "", 16); ! 680: ! 681: if(dimoffset > 0) ! 682: { ! 683: fprintf(asmfile, LABELFMT, memname(STGINIT,dimno)); ! 684: for(q = np->varxptr.namelist ; q ; q = q->nextp) ! 685: if(dp = q->datap->nameblock.vdim) ! 686: { ! 687: int i; ! 688: prconi(asmfile, TYINT, (ftnint) (dp->ndim) ); ! 689: prconi(asmfile, TYINT, ! 690: (ftnint) (dp->nelt->constblock.const.ci) ); ! 691: prconi(asmfile, TYINT, ! 692: (ftnint) (dp->baseoffset->constblock.const.ci)); ! 693: for(i=0; i<dp->ndim ; ++i) ! 694: prconi(asmfile, TYINT, ! 695: dp->dims[i].dimsize->constblock.const.ci); ! 696: } ! 697: } ! 698: ! 699: } ! 700: ! 701: LOCAL docommon() ! 702: { ! 703: register struct Extsym *p; ! 704: register chainp q; ! 705: struct Dimblock *t; ! 706: expptr neltp; ! 707: register Namep v; ! 708: ftnint size; ! 709: int type; ! 710: ! 711: for(p = extsymtab ; p<nextext ; ++p) ! 712: if(p->extstg==STGCOMMON) ! 713: { ! 714: #ifdef SDB ! 715: if(sdbflag) ! 716: prstab(varstr(XL,p->extname), N_BCOMM, 0, 0); ! 717: #endif ! 718: for(q = p->extp ; q ; q = q->nextp) ! 719: { ! 720: v = (Namep) (q->datap); ! 721: if(v->vdcldone == NO) ! 722: vardcl(v); ! 723: type = v->vtype; ! 724: if(p->extleng % typealign[type] != 0) ! 725: { ! 726: dclerr("common alignment", v); ! 727: p->extleng = roundup(p->extleng, typealign[type]); ! 728: } ! 729: v->voffset = p->extleng; ! 730: v->vardesc.varno = p - extsymtab; ! 731: if(type == TYCHAR) ! 732: size = v->vleng->constblock.const.ci; ! 733: else size = typesize[type]; ! 734: if(t = v->vdim) ! 735: if( (neltp = t->nelt) && ISCONST(neltp) ) ! 736: size *= neltp->constblock.const.ci; ! 737: else ! 738: dclerr("adjustable array in common", v); ! 739: p->extleng += size; ! 740: #ifdef SDB ! 741: if(sdbflag) ! 742: { ! 743: namestab(v); ! 744: } ! 745: #endif ! 746: } ! 747: ! 748: frchain( &(p->extp) ); ! 749: #ifdef SDB ! 750: if(sdbflag) ! 751: prstab(varstr(XL,p->extname), N_ECOMM, 0, 0); ! 752: #endif ! 753: } ! 754: } ! 755: ! 756: ! 757: ! 758: ! 759: ! 760: LOCAL docomleng() ! 761: { ! 762: register struct Extsym *p; ! 763: ! 764: for(p = extsymtab ; p < nextext ; ++p) ! 765: if(p->extstg == STGCOMMON) ! 766: { ! 767: if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng ! 768: && !eqn(XL,"_BLNK__ ",p->extname) ) ! 769: warn1("incompatible lengths for common block %s", ! 770: nounder(XL, p->extname) ); ! 771: if(p->maxleng < p->extleng) ! 772: p->maxleng = p->extleng; ! 773: p->extleng = 0; ! 774: } ! 775: } ! 776: ! 777: ! 778: ! 779: ! 780: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ ! 781: ! 782: /* frees a temporary block */ ! 783: ! 784: frtemp(p) ! 785: Tempp p; ! 786: { ! 787: Addrp t; ! 788: ! 789: if (optimflag) ! 790: { ! 791: if (p->tag != TTEMP) ! 792: badtag ("frtemp",p->tag); ! 793: t = p->memalloc; ! 794: } ! 795: else ! 796: t = (Addrp) p; ! 797: ! 798: /* restore clobbered character string lengths */ ! 799: if(t->vtype==TYCHAR && t->varleng!=0) ! 800: { ! 801: frexpr(t->vleng); ! 802: t->vleng = ICON(t->varleng); ! 803: } ! 804: ! 805: /* put block on chain of temps to be reclaimed */ ! 806: holdtemps = mkchain(t, holdtemps); ! 807: } ! 808: ! 809: ! 810: ! 811: /* allocate an automatic variable slot */ ! 812: ! 813: Addrp autovar(nelt, t, lengp) ! 814: register int nelt, t; ! 815: expptr lengp; ! 816: { ! 817: ftnint leng; ! 818: register Addrp q; ! 819: ! 820: if(t == TYCHAR) ! 821: if( ISICON(lengp) ) ! 822: leng = lengp->constblock.const.ci; ! 823: else { ! 824: fatal("automatic variable of nonconstant length"); ! 825: } ! 826: else ! 827: leng = typesize[t]; ! 828: autoleng = roundup( autoleng, typealign[t]); ! 829: ! 830: q = ALLOC(Addrblock); ! 831: q->tag = TADDR; ! 832: q->vtype = t; ! 833: if(t == TYCHAR) ! 834: { ! 835: q->vleng = ICON(leng); ! 836: q->varleng = leng; ! 837: } ! 838: q->vstg = STGAUTO; ! 839: q->memno = newlabel(); ! 840: q->ntempelt = nelt; ! 841: #if TARGET==PDP11 || TARGET==VAX ! 842: /* stack grows downward */ ! 843: autoleng += nelt*leng; ! 844: q->memoffset = ICON( - autoleng ); ! 845: #else ! 846: q->memoffset = ICON( autoleng ); ! 847: autoleng += nelt*leng; ! 848: #endif ! 849: ! 850: return(q); ! 851: } ! 852: ! 853: ! 854: ! 855: /* ! 856: * create a temporary block (TTEMP) when optimizing, ! 857: * an ordinary TADDR block when not optimizing ! 858: */ ! 859: ! 860: Tempp mktmpn(nelt, type, lengp) ! 861: int nelt; ! 862: register int type; ! 863: expptr lengp; ! 864: { ! 865: ftnint leng; ! 866: chainp p, oldp; ! 867: register Tempp q; ! 868: Addrp altemp; ! 869: ! 870: if (! optimflag) ! 871: return ( (Tempp) mkaltmpn(nelt,type,lengp) ); ! 872: if(type==TYUNKNOWN || type==TYERROR) ! 873: badtype("mktmpn", type); ! 874: ! 875: if(type==TYCHAR) ! 876: if( ISICON(lengp) ) ! 877: leng = lengp->constblock.const.ci; ! 878: else { ! 879: err("adjustable length"); ! 880: return( (Tempp) errnode() ); ! 881: } ! 882: ! 883: if(type == TYCHAR) ! 884: if( ISICON(lengp) ) ! 885: leng = lengp->constblock.const.ci; ! 886: else ! 887: fatal("temporary variable of nonconstant length"); ! 888: else ! 889: leng = typesize[type]; ! 890: ! 891: q = ALLOC(Tempblock); ! 892: q->tag = TTEMP; ! 893: q->vtype = type; ! 894: if(type == TYCHAR) ! 895: { ! 896: q->vleng = ICON(leng); ! 897: q->varleng = leng; ! 898: } ! 899: ! 900: altemp = ALLOC(Addrblock); ! 901: altemp->tag = TADDR; ! 902: altemp->vstg = STGUNKNOWN; ! 903: q->memalloc = altemp; ! 904: ! 905: q->ntempelt = nelt; ! 906: q->istemp = YES; ! 907: return(q); ! 908: } ! 909: ! 910: ! 911: ! 912: Addrp mktemp(type, lengp) ! 913: int type; ! 914: expptr lengp; ! 915: { ! 916: return( (Addrp) mktmpn(1,type,lengp) ); ! 917: } ! 918: ! 919: ! 920: ! 921: /* allocate a temporary location for the given temporary block; ! 922: if already allocated, return its location */ ! 923: ! 924: Addrp altmpn(tp) ! 925: Tempp tp; ! 926: ! 927: { ! 928: Addrp t, q; ! 929: ! 930: if (tp->tag != TTEMP) ! 931: badtag ("altmpn",tp->tag); ! 932: ! 933: t = tp->memalloc; ! 934: if (t->vstg != STGUNKNOWN) ! 935: return (t); ! 936: ! 937: q = mkaltmpn (tp->ntempelt, tp->vtype, tp->vleng); ! 938: cpn (sizeof(struct Addrblock), (char*)q, (char*)t); ! 939: free ( (charptr) q); ! 940: return(t); ! 941: } ! 942: ! 943: ! 944: ! 945: /* create and allocate space immediately for a temporary */ ! 946: ! 947: Addrp mkaltemp(type,lengp) ! 948: int type; ! 949: expptr lengp; ! 950: { ! 951: return (mkaltmpn(1,type,lengp)); ! 952: } ! 953: ! 954: ! 955: ! 956: Addrp mkaltmpn(nelt,type,lengp) ! 957: int nelt; ! 958: register int type; ! 959: expptr lengp; ! 960: { ! 961: ftnint leng; ! 962: chainp p, oldp; ! 963: register Addrp q; ! 964: ! 965: if(type==TYUNKNOWN || type==TYERROR) ! 966: badtype("mkaltmpn", type); ! 967: ! 968: if(type==TYCHAR) ! 969: if( ISICON(lengp) ) ! 970: leng = lengp->constblock.const.ci; ! 971: else { ! 972: err("adjustable length"); ! 973: return( (Addrp) errnode() ); ! 974: } ! 975: ! 976: /* ! 977: * if a temporary of appropriate shape is on the templist, ! 978: * remove it from the list and return it ! 979: */ ! 980: ! 981: for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp) ! 982: { ! 983: q = (Addrp) (p->datap); ! 984: if(q->vtype==type && q->ntempelt==nelt && ! 985: (type!=TYCHAR || q->vleng->constblock.const.ci==leng) ) ! 986: { ! 987: if(oldp) ! 988: oldp->nextp = p->nextp; ! 989: else ! 990: templist = p->nextp; ! 991: free( (charptr) p); ! 992: ! 993: if (debugflag[14]) ! 994: fprintf(diagfile,"mkaltmpn reusing offset %d\n", ! 995: q->memoffset->constblock.const.ci); ! 996: return(q); ! 997: } ! 998: } ! 999: q = autovar(nelt, type, lengp); ! 1000: q->istemp = YES; ! 1001: ! 1002: if (debugflag[14]) ! 1003: fprintf(diagfile,"mkaltmpn new offset %d\n", ! 1004: q->memoffset->constblock.const.ci); ! 1005: return(q); ! 1006: } ! 1007: ! 1008: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ ! 1009: ! 1010: struct Extsym *comblock(len, s) ! 1011: register int len; ! 1012: register char *s; ! 1013: { ! 1014: struct Extsym *p; ! 1015: ! 1016: if(len == 0) ! 1017: { ! 1018: s = BLANKCOMMON; ! 1019: len = strlen(s); ! 1020: } ! 1021: p = mkext( varunder(len, s) ); ! 1022: if(p->extstg == STGUNKNOWN) ! 1023: p->extstg = STGCOMMON; ! 1024: else if(p->extstg != STGCOMMON) ! 1025: { ! 1026: errstr("%s cannot be a common block name", s); ! 1027: return(0); ! 1028: } ! 1029: ! 1030: return( p ); ! 1031: } ! 1032: ! 1033: ! 1034: incomm(c, v) ! 1035: struct Extsym *c; ! 1036: Namep v; ! 1037: { ! 1038: if(v->vstg != STGUNKNOWN) ! 1039: dclerr("incompatible common declaration", v); ! 1040: else ! 1041: { ! 1042: v->vstg = STGCOMMON; ! 1043: c->extp = hookup(c->extp, mkchain(v,CHNULL) ); ! 1044: } ! 1045: } ! 1046: ! 1047: ! 1048: ! 1049: ! 1050: settype(v, type, length) ! 1051: register Namep v; ! 1052: register int type; ! 1053: register int length; ! 1054: { ! 1055: if(type == TYUNKNOWN) ! 1056: return; ! 1057: ! 1058: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) ! 1059: { ! 1060: v->vtype = TYSUBR; ! 1061: frexpr(v->vleng); ! 1062: } ! 1063: else if(type < 0) /* storage class set */ ! 1064: { ! 1065: if(v->vstg == STGUNKNOWN) ! 1066: v->vstg = - type; ! 1067: else if(v->vstg != -type) ! 1068: dclerr("incompatible storage declarations", v); ! 1069: } ! 1070: else if(v->vtype == TYUNKNOWN) ! 1071: { ! 1072: if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0) ! 1073: v->vleng = ICON(length); ! 1074: } ! 1075: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) ) ! 1076: dclerr("incompatible type declarations", v); ! 1077: } ! 1078: ! 1079: ! 1080: ! 1081: ! 1082: ! 1083: lengtype(type, length) ! 1084: register int type; ! 1085: register int length; ! 1086: { ! 1087: switch(type) ! 1088: { ! 1089: case TYREAL: ! 1090: if(length == 8) ! 1091: return(TYDREAL); ! 1092: if(length == 4) ! 1093: goto ret; ! 1094: break; ! 1095: ! 1096: case TYCOMPLEX: ! 1097: if(length == 16) ! 1098: return(TYDCOMPLEX); ! 1099: if(length == 8) ! 1100: goto ret; ! 1101: break; ! 1102: ! 1103: case TYSHORT: ! 1104: case TYDREAL: ! 1105: case TYDCOMPLEX: ! 1106: case TYCHAR: ! 1107: case TYUNKNOWN: ! 1108: case TYSUBR: ! 1109: case TYERROR: ! 1110: goto ret; ! 1111: ! 1112: case TYLOGICAL: ! 1113: if(length == typesize[TYLOGICAL]) ! 1114: goto ret; ! 1115: break; ! 1116: ! 1117: case TYLONG: ! 1118: if(length == 0) ! 1119: return(tyint); ! 1120: if(length == 2) ! 1121: return(TYSHORT); ! 1122: if(length == 4) ! 1123: goto ret; ! 1124: break; ! 1125: default: ! 1126: badtype("lengtype", type); ! 1127: } ! 1128: ! 1129: if(length != 0) ! 1130: err("incompatible type-length combination"); ! 1131: ! 1132: ret: ! 1133: return(type); ! 1134: } ! 1135: ! 1136: ! 1137: ! 1138: ! 1139: ! 1140: setintr(v) ! 1141: register Namep v; ! 1142: { ! 1143: register int k; ! 1144: ! 1145: if(v->vstg == STGUNKNOWN) ! 1146: v->vstg = STGINTR; ! 1147: else if(v->vstg!=STGINTR) ! 1148: dclerr("incompatible use of intrinsic function", v); ! 1149: if(v->vclass==CLUNKNOWN) ! 1150: v->vclass = CLPROC; ! 1151: if(v->vprocclass == PUNKNOWN) ! 1152: v->vprocclass = PINTRINSIC; ! 1153: else if(v->vprocclass != PINTRINSIC) ! 1154: dclerr("invalid intrinsic declaration", v); ! 1155: if(k = intrfunct(v->varname)) ! 1156: v->vardesc.varno = k; ! 1157: else ! 1158: dclerr("unknown intrinsic function", v); ! 1159: } ! 1160: ! 1161: ! 1162: ! 1163: setext(v) ! 1164: register Namep v; ! 1165: { ! 1166: if(v->vclass == CLUNKNOWN) ! 1167: v->vclass = CLPROC; ! 1168: else if(v->vclass != CLPROC) ! 1169: dclerr("invalid external declaration", v); ! 1170: ! 1171: if(v->vprocclass == PUNKNOWN) ! 1172: v->vprocclass = PEXTERNAL; ! 1173: else if(v->vprocclass != PEXTERNAL) ! 1174: dclerr("invalid external declaration", v); ! 1175: } ! 1176: ! 1177: ! 1178: ! 1179: ! 1180: /* create dimensions block for array variable */ ! 1181: ! 1182: setbound(v, nd, dims) ! 1183: register Namep v; ! 1184: int nd; ! 1185: struct { expptr lb, ub; } dims[ ]; ! 1186: { ! 1187: register expptr q, t; ! 1188: register struct Dimblock *p; ! 1189: int i; ! 1190: ! 1191: if(v->vclass == CLUNKNOWN) ! 1192: v->vclass = CLVAR; ! 1193: else if(v->vclass != CLVAR) ! 1194: { ! 1195: dclerr("only variables may be arrays", v); ! 1196: return; ! 1197: } ! 1198: ! 1199: v->vdim = p = (struct Dimblock *) ! 1200: ckalloc( sizeof(int) + (3+6*nd)*sizeof(expptr) ); ! 1201: p->ndim = nd; ! 1202: p->nelt = ICON(1); ! 1203: ! 1204: for(i=0 ; i<nd ; ++i) ! 1205: { ! 1206: #ifdef SDB ! 1207: if(sdbflag) { ! 1208: /* Save the bounds trees built up by the grammar routines for use in stabs */ ! 1209: ! 1210: if(dims[i].lb == NULL) p->dims[i].lb=ICON(1); ! 1211: else p->dims[i].lb= (expptr) cpexpr(dims[i].lb); ! 1212: if(ISCONST(p->dims[i].lb)) p->dims[i].lbaddr = (expptr) PNULL; ! 1213: else p->dims[i].lbaddr = (expptr) autovar(1, tyint, PNULL); ! 1214: ! 1215: if(dims[i].ub == NULL) p->dims[i].ub=ICON(1); ! 1216: else p->dims[i].ub = (expptr) cpexpr(dims[i].ub); ! 1217: if(ISCONST(p->dims[i].ub)) p->dims[i].ubaddr = (expptr) PNULL; ! 1218: else p->dims[i].ubaddr = (expptr) autovar(1, tyint, PNULL); ! 1219: } ! 1220: #endif ! 1221: if( (q = dims[i].ub) == NULL) ! 1222: { ! 1223: if(i == nd-1) ! 1224: { ! 1225: frexpr(p->nelt); ! 1226: p->nelt = NULL; ! 1227: } ! 1228: else ! 1229: err("only last bound may be asterisk"); ! 1230: p->dims[i].dimsize = ICON(1);; ! 1231: p->dims[i].dimexpr = NULL; ! 1232: } ! 1233: else ! 1234: { ! 1235: if(dims[i].lb) ! 1236: { ! 1237: q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); ! 1238: q = mkexpr(OPPLUS, q, ICON(1) ); ! 1239: } ! 1240: if( ISCONST(q) ) ! 1241: { ! 1242: p->dims[i].dimsize = q; ! 1243: p->dims[i].dimexpr = (expptr) PNULL; ! 1244: } ! 1245: else { ! 1246: p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL); ! 1247: p->dims[i].dimexpr = q; ! 1248: } ! 1249: if(p->nelt) ! 1250: p->nelt = mkexpr(OPSTAR, p->nelt, ! 1251: cpexpr(p->dims[i].dimsize) ); ! 1252: } ! 1253: } ! 1254: ! 1255: q = dims[nd-1].lb; ! 1256: if(q == NULL) ! 1257: q = ICON(1); ! 1258: ! 1259: for(i = nd-2 ; i>=0 ; --i) ! 1260: { ! 1261: t = dims[i].lb; ! 1262: if(t == NULL) ! 1263: t = ICON(1); ! 1264: if(p->dims[i].dimsize) ! 1265: q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); ! 1266: } ! 1267: ! 1268: if( ISCONST(q) ) ! 1269: { ! 1270: p->baseoffset = q; ! 1271: p->basexpr = NULL; ! 1272: } ! 1273: else ! 1274: { ! 1275: p->baseoffset = (expptr) autovar(1, tyint, PNULL); ! 1276: p->basexpr = q; ! 1277: } ! 1278: } ! 1279: ! 1280: ! 1281: ! 1282: LOCAL enlist(size, np, ep) ! 1283: ftnint size; ! 1284: Namep np; ! 1285: struct Equivblock *ep; ! 1286: { ! 1287: register sizelist *sp; ! 1288: register sizelist *t; ! 1289: register varlist *p; ! 1290: ! 1291: sp = varsizes; ! 1292: ! 1293: if (sp == NULL) ! 1294: { ! 1295: sp = ALLOC(SizeList); ! 1296: sp->size = size; ! 1297: varsizes = sp; ! 1298: } ! 1299: else ! 1300: { ! 1301: while (sp->size != size) ! 1302: { ! 1303: if (sp->next != NULL && sp->next->size <= size) ! 1304: sp = sp->next; ! 1305: else ! 1306: { ! 1307: t = sp; ! 1308: sp = ALLOC(SizeList); ! 1309: sp->size = size; ! 1310: sp->next = t->next; ! 1311: t->next = sp; ! 1312: } ! 1313: } ! 1314: } ! 1315: ! 1316: p = ALLOC(VarList); ! 1317: p->next = sp->vars; ! 1318: p->np = np; ! 1319: p->ep = ep; ! 1320: ! 1321: sp->vars = p; ! 1322: ! 1323: return; ! 1324: } ! 1325: ! 1326: ! 1327: ! 1328: outlocvars() ! 1329: { ! 1330: ! 1331: register varlist *first, *last; ! 1332: register varlist *vp, *t; ! 1333: register sizelist *sp, *sp1; ! 1334: register Namep np; ! 1335: register struct Equivblock *ep; ! 1336: register int i; ! 1337: register int alt; ! 1338: register int type; ! 1339: char sname[100]; ! 1340: char setbuff[100]; ! 1341: ! 1342: sp = varsizes; ! 1343: if (sp == NULL) ! 1344: return; ! 1345: ! 1346: vp = sp->vars; ! 1347: if (vp->np != NULL) ! 1348: { ! 1349: np = vp->np; ! 1350: sprintf(setbuff, "\t.set\tv.%d,v.%d\n", bsslabel, ! 1351: np->vardesc.varno); ! 1352: } ! 1353: else ! 1354: { ! 1355: i = vp->ep - eqvclass; ! 1356: sprintf(setbuff, "\t.set\tv.%d,q.%d\n", bsslabel, i + eqvstart); ! 1357: } ! 1358: ! 1359: first = last = NULL; ! 1360: alt = NO; ! 1361: ! 1362: while (sp != NULL) ! 1363: { ! 1364: vp = sp->vars; ! 1365: while (vp != NULL) ! 1366: { ! 1367: t = vp->next; ! 1368: if (alt == YES) ! 1369: { ! 1370: alt = NO; ! 1371: vp->next = first; ! 1372: first = vp; ! 1373: } ! 1374: else ! 1375: { ! 1376: alt = YES; ! 1377: if (last != NULL) ! 1378: last->next = vp; ! 1379: else ! 1380: first = vp; ! 1381: vp->next = NULL; ! 1382: last = vp; ! 1383: } ! 1384: vp = t; ! 1385: } ! 1386: sp1 = sp; ! 1387: sp = sp->next; ! 1388: free((char *) sp1); ! 1389: } ! 1390: ! 1391: vp = first; ! 1392: while(vp != NULL) ! 1393: { ! 1394: if (vp->np != NULL) ! 1395: { ! 1396: np = vp->np; ! 1397: sprintf(sname, "v.%d", np->vardesc.varno); ! 1398: if (np->init) ! 1399: prlocdata(sname, np->varsize, np->vtype, np->initoffset, ! 1400: &(np->inlcomm)); ! 1401: else ! 1402: { ! 1403: pralign(typealign[np->vtype]); ! 1404: fprintf(initfile, "%s:\n\t.space\t%d\n", sname, ! 1405: np->varsize); ! 1406: } ! 1407: np->inlcomm = NO; ! 1408: } ! 1409: else ! 1410: { ! 1411: ep = vp->ep; ! 1412: i = ep - eqvclass; ! 1413: if (ep->eqvleng >= 8) ! 1414: type = TYDREAL; ! 1415: else if (ep->eqvleng >= 4) ! 1416: type = TYLONG; ! 1417: else if (ep->eqvleng >= 2) ! 1418: type = TYSHORT; ! 1419: else ! 1420: type = TYCHAR; ! 1421: sprintf(sname, "q.%d", i + eqvstart); ! 1422: if (ep->init) ! 1423: prlocdata(sname, ep->eqvleng, type, ep->initoffset, ! 1424: &(ep->inlcomm)); ! 1425: else ! 1426: { ! 1427: pralign(typealign[type]); ! 1428: fprintf(initfile, "%s:\n\t.space\t%d\n", sname, ep->eqvleng); ! 1429: } ! 1430: ep->inlcomm = NO; ! 1431: } ! 1432: t = vp; ! 1433: vp = vp->next; ! 1434: free((char *) t); ! 1435: } ! 1436: fprintf(initfile, "%s\n", setbuff); ! 1437: return; ! 1438: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.