![[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] / 41BSD / cmd / f77|
Return to proc.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / f77 |
1.1 ! root 1: #include "defs" ! 2: #include "machdefs" ! 3: ! 4: #ifdef SDB ! 5: # include <a.out.h> ! 6: char *stabline(); ! 7: # ifndef N_SO ! 8: # include <stab.h> ! 9: # endif ! 10: #endif ! 11: ! 12: /* start a new procedure */ ! 13: ! 14: newproc() ! 15: { ! 16: if(parstate != OUTSIDE) ! 17: { ! 18: execerr("missing end statement", CNULL); ! 19: endproc(); ! 20: } ! 21: ! 22: parstate = INSIDE; ! 23: procclass = CLMAIN; /* default */ ! 24: } ! 25: ! 26: ! 27: ! 28: /* end of procedure. generate variables, epilogs, and prologs */ ! 29: ! 30: endproc() ! 31: { ! 32: struct Labelblock *lp; ! 33: ! 34: if(parstate < INDATA) ! 35: enddcl(); ! 36: if(ctlstack >= ctls) ! 37: err("DO loop or BLOCK IF not closed"); ! 38: for(lp = labeltab ; lp < labtabend ; ++lp) ! 39: if(lp->stateno!=0 && lp->labdefined==NO) ! 40: errstr("missing statement number %s", convic(lp->stateno) ); ! 41: ! 42: epicode(); ! 43: procode(); ! 44: donmlist(); ! 45: dobss(); ! 46: prdbginfo(); ! 47: ! 48: #if FAMILY == PCC ! 49: putbracket(); ! 50: #endif ! 51: ! 52: procinit(); /* clean up for next procedure */ ! 53: } ! 54: ! 55: ! 56: ! 57: /* End of declaration section of procedure. Allocate storage. */ ! 58: ! 59: enddcl() ! 60: { ! 61: register struct Entrypoint *ep; ! 62: ! 63: parstate = INEXEC; ! 64: docommon(); ! 65: doequiv(); ! 66: docomleng(); ! 67: for(ep = entries ; ep ; ep = ep->entnextp) ! 68: doentry(ep); ! 69: } ! 70: ! 71: /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ ! 72: ! 73: /* Main program or Block data */ ! 74: ! 75: startproc(progname, class) ! 76: struct Extsym * progname; ! 77: int class; ! 78: { ! 79: register struct Entrypoint *p; ! 80: ! 81: p = ALLOC(Entrypoint); ! 82: if(class == CLMAIN) ! 83: puthead("MAIN__", CLMAIN); ! 84: else ! 85: puthead(CNULL, CLBLOCK); ! 86: if(class == CLMAIN) ! 87: newentry( mkname(5, "MAIN_") ); ! 88: p->entryname = progname; ! 89: p->entrylabel = newlabel(); ! 90: entries = p; ! 91: ! 92: procclass = class; ! 93: retlabel = newlabel(); ! 94: fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); ! 95: if(progname) ! 96: fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) ); ! 97: fprintf(diagfile, ":\n"); ! 98: #ifdef SDB ! 99: if(sdbflag && class==CLMAIN) ! 100: { ! 101: char buff[10]; ! 102: sprintf(buff, "L%d", p->entrylabel); ! 103: prstab("MAIN_", N_FUN, lineno, buff); ! 104: p2pass( stabline("MAIN_", N_FNAME, 0, 0) ); ! 105: if(progname) ! 106: { ! 107: prstab(nounder(XL,progname->extname), N_ENTRY, lineno,buff); ! 108: /* p2pass(stabline(nounder(XL,progname->extname),N_FNAME,0,0)); */ ! 109: } ! 110: } ! 111: #endif ! 112: } ! 113: ! 114: /* subroutine or function statement */ ! 115: ! 116: struct Extsym *newentry(v) ! 117: register Namep v; ! 118: { ! 119: register struct Extsym *p; ! 120: ! 121: p = mkext( varunder(VL, v->varname) ); ! 122: ! 123: if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) ! 124: { ! 125: if(p == 0) ! 126: dclerr("invalid entry name", v); ! 127: else dclerr("external name already used", v); ! 128: return(0); ! 129: } ! 130: v->vstg = STGAUTO; ! 131: v->vprocclass = PTHISPROC; ! 132: v->vclass = CLPROC; ! 133: p->extstg = STGEXT; ! 134: p->extinit = YES; ! 135: return(p); ! 136: } ! 137: ! 138: ! 139: entrypt(class, type, length, entry, args) ! 140: int class, type; ! 141: ftnint length; ! 142: struct Extsym *entry; ! 143: chainp args; ! 144: { ! 145: register Namep q; ! 146: register struct Entrypoint *p, *ep; ! 147: ! 148: if(class != CLENTRY) ! 149: puthead( varstr(XL, procname = entry->extname), class); ! 150: if(class == CLENTRY) ! 151: fprintf(diagfile, " entry "); ! 152: fprintf(diagfile, " %s:\n", nounder(XL, entry->extname)); ! 153: q = mkname(VL, nounder(XL,entry->extname) ); ! 154: ! 155: if( (type = lengtype(type, (int) length)) != TYCHAR) ! 156: length = 0; ! 157: if(class == CLPROC) ! 158: { ! 159: procclass = CLPROC; ! 160: proctype = type; ! 161: procleng = length; ! 162: ! 163: retlabel = newlabel(); ! 164: if(type == TYSUBR) ! 165: ret0label = newlabel(); ! 166: } ! 167: ! 168: p = ALLOC(Entrypoint); ! 169: ! 170: if(entries) /* put new block at end of entries list */ ! 171: { ! 172: for(ep = entries; ep->entnextp; ep = ep->entnextp) ! 173: ; ! 174: ep->entnextp = p; ! 175: } ! 176: else ! 177: entries = p; ! 178: ! 179: p->entryname = entry; ! 180: p->arglist = args; ! 181: p->entrylabel = newlabel(); ! 182: p->enamep = q; ! 183: ! 184: #ifdef SDB ! 185: if(sdbflag) ! 186: { ! 187: char buff[10]; ! 188: sprintf(buff, "L%d", p->entrylabel); ! 189: prstab(nounder(XL, entry->extname), ! 190: (class==CLENTRY ? N_ENTRY : N_FUN), ! 191: lineno, buff); ! 192: if(class != CLENTRY) ! 193: p2pass( stabline( nounder(XL,entry->extname), N_FNAME, 0, 0) ); ! 194: } ! 195: #endif ! 196: ! 197: if(class == CLENTRY) ! 198: { ! 199: class = CLPROC; ! 200: if(proctype == TYSUBR) ! 201: type = TYSUBR; ! 202: } ! 203: ! 204: q->vclass = class; ! 205: q->vprocclass = PTHISPROC; ! 206: settype(q, type, (int) length); ! 207: /* hold all initial entry points till end of declarations */ ! 208: if(parstate >= INDATA) ! 209: doentry(p); ! 210: } ! 211: ! 212: /* generate epilogs */ ! 213: ! 214: LOCAL epicode() ! 215: { ! 216: register int i; ! 217: ! 218: if(procclass==CLPROC) ! 219: { ! 220: if(proctype==TYSUBR) ! 221: { ! 222: putlabel(ret0label); ! 223: if(substars) ! 224: putforce(TYINT, ICON(0) ); ! 225: putlabel(retlabel); ! 226: goret(TYSUBR); ! 227: } ! 228: else { ! 229: putlabel(retlabel); ! 230: if(multitype) ! 231: { ! 232: typeaddr = autovar(1, TYADDR, PNULL); ! 233: putbranch( cpexpr(typeaddr) ); ! 234: for(i = 0; i < NTYPES ; ++i) ! 235: if(rtvlabel[i] != 0) ! 236: { ! 237: putlabel(rtvlabel[i]); ! 238: retval(i); ! 239: } ! 240: } ! 241: else ! 242: retval(proctype); ! 243: } ! 244: } ! 245: ! 246: else if(procclass != CLBLOCK) ! 247: { ! 248: putlabel(retlabel); ! 249: goret(TYSUBR); ! 250: } ! 251: } ! 252: ! 253: ! 254: /* generate code to return value of type t */ ! 255: ! 256: LOCAL retval(t) ! 257: register int t; ! 258: { ! 259: register Addrp p; ! 260: ! 261: switch(t) ! 262: { ! 263: case TYCHAR: ! 264: case TYCOMPLEX: ! 265: case TYDCOMPLEX: ! 266: break; ! 267: ! 268: case TYLOGICAL: ! 269: t = tylogical; ! 270: case TYADDR: ! 271: case TYSHORT: ! 272: case TYLONG: ! 273: p = (Addrp) cpexpr(retslot); ! 274: p->vtype = t; ! 275: putforce(t, p); ! 276: break; ! 277: ! 278: case TYREAL: ! 279: case TYDREAL: ! 280: p = (Addrp) cpexpr(retslot); ! 281: p->vtype = t; ! 282: putforce(t, p); ! 283: break; ! 284: ! 285: default: ! 286: badtype("retval", t); ! 287: } ! 288: goret(t); ! 289: } ! 290: ! 291: ! 292: /* Allocate extra argument array if needed. Generate prologs. */ ! 293: ! 294: LOCAL procode() ! 295: { ! 296: register struct Entrypoint *p; ! 297: Addrp argvec; ! 298: ! 299: #if TARGET==GCOS ! 300: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); ! 301: #else ! 302: if(lastargslot>0 && nentry>1) ! 303: #if TARGET == VAX ! 304: argvec = autovar(1 + lastargslot/SZADDR, TYADDR, PNULL); ! 305: #else ! 306: argvec = autovar(lastargslot/SZADDR, TYADDR, PNULL); ! 307: #endif ! 308: else ! 309: argvec = NULL; ! 310: #endif ! 311: ! 312: ! 313: #if TARGET == PDP11 ! 314: /* for the optimizer */ ! 315: if(fudgelabel) ! 316: putlabel(fudgelabel); ! 317: #endif ! 318: ! 319: for(p = entries ; p ; p = p->entnextp) ! 320: prolog(p, argvec); ! 321: ! 322: #if FAMILY == PCC ! 323: putrbrack(procno); ! 324: #endif ! 325: ! 326: prendproc(); ! 327: } ! 328: ! 329: /* ! 330: manipulate argument lists (allocate argument slot positions) ! 331: * keep track of return types and labels ! 332: */ ! 333: ! 334: LOCAL doentry(ep) ! 335: struct Entrypoint *ep; ! 336: { ! 337: register int type; ! 338: register Namep np; ! 339: chainp p; ! 340: register Namep q; ! 341: Addrp mkarg(); ! 342: ! 343: ++nentry; ! 344: if(procclass == CLMAIN) ! 345: { ! 346: putlabel(ep->entrylabel); ! 347: return; ! 348: } ! 349: else if(procclass == CLBLOCK) ! 350: return; ! 351: ! 352: impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) ); ! 353: type = np->vtype; ! 354: if(proctype == TYUNKNOWN) ! 355: if( (proctype = type) == TYCHAR) ! 356: procleng = (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)); ! 357: ! 358: if(proctype == TYCHAR) ! 359: { ! 360: if(type != TYCHAR) ! 361: err("noncharacter entry of character function"); ! 362: else if( (np->vleng ? np->vleng->constblock.const.ci : (ftnint) (-1)) != procleng) ! 363: err("mismatched character entry lengths"); ! 364: } ! 365: else if(type == TYCHAR) ! 366: err("character entry of noncharacter function"); ! 367: else if(type != proctype) ! 368: multitype = YES; ! 369: if(rtvlabel[type] == 0) ! 370: rtvlabel[type] = newlabel(); ! 371: ep->typelabel = rtvlabel[type]; ! 372: ! 373: if(type == TYCHAR) ! 374: { ! 375: if(chslot < 0) ! 376: { ! 377: chslot = nextarg(TYADDR); ! 378: chlgslot = nextarg(TYLENG); ! 379: } ! 380: np->vstg = STGARG; ! 381: np->vardesc.varno = chslot; ! 382: if(procleng < 0) ! 383: np->vleng = (expptr) mkarg(TYLENG, chlgslot); ! 384: } ! 385: else if( ISCOMPLEX(type) ) ! 386: { ! 387: np->vstg = STGARG; ! 388: if(cxslot < 0) ! 389: cxslot = nextarg(TYADDR); ! 390: np->vardesc.varno = cxslot; ! 391: } ! 392: else if(type != TYSUBR) ! 393: { ! 394: if(nentry == 1) ! 395: retslot = autovar(1, TYDREAL, PNULL); ! 396: np->vstg = STGAUTO; ! 397: np->voffset = retslot->memoffset->constblock.const.ci; ! 398: } ! 399: ! 400: for(p = ep->arglist ; p ; p = p->nextp) ! 401: if(! (( q = (Namep) (p->datap) )->vdcldone) ) ! 402: q->vardesc.varno = nextarg(TYADDR); ! 403: ! 404: for(p = ep->arglist ; p ; p = p->nextp) ! 405: if(! (( q = (Namep) (p->datap) )->vdcldone) ) ! 406: { ! 407: impldcl(q); ! 408: q->vdcldone = YES; ! 409: #ifdef SDB ! 410: if(sdbflag) ! 411: prstab(varstr(VL,q->varname), N_PSYM, ! 412: stabtype(q), ! 413: convic(q->vardesc.varno + ARGOFFSET) ); ! 414: #endif ! 415: if(q->vtype == TYCHAR) ! 416: { ! 417: if(q->vleng == NULL) /* character*(*) */ ! 418: q->vleng = (expptr) ! 419: mkarg(TYLENG, nextarg(TYLENG) ); ! 420: else if(nentry == 1) ! 421: nextarg(TYLENG); ! 422: } ! 423: else if(q->vclass==CLPROC && nentry==1) ! 424: nextarg(TYLENG) ; ! 425: } ! 426: ! 427: putlabel(ep->entrylabel); ! 428: } ! 429: ! 430: ! 431: ! 432: LOCAL nextarg(type) ! 433: int type; ! 434: { ! 435: int k; ! 436: k = lastargslot; ! 437: lastargslot += typesize[type]; ! 438: return(k); ! 439: } ! 440: ! 441: /* generate variable references */ ! 442: ! 443: LOCAL dobss() ! 444: { ! 445: register struct Hashentry *p; ! 446: register Namep q; ! 447: register int i; ! 448: int align; ! 449: ftnint leng, iarrl; ! 450: char *memname(); ! 451: int qstg, qclass, qtype; ! 452: ! 453: pruse(asmfile, USEBSS); ! 454: ! 455: for(p = hashtab ; p<lasthash ; ++p) ! 456: if(q = p->varp) ! 457: { ! 458: qstg = q->vstg; ! 459: qtype = q->vtype; ! 460: qclass = q->vclass; ! 461: ! 462: #ifdef SDB ! 463: if(sdbflag && qclass==CLVAR) switch(qstg) ! 464: { ! 465: case STGAUTO: ! 466: prstab(varstr(VL,q->varname), N_LSYM, ! 467: stabtype(q), ! 468: convic( - q->voffset)) ; ! 469: prstleng(q, iarrlen(q)); ! 470: break; ! 471: ! 472: case STGBSS: ! 473: prstab(varstr(VL,q->varname), N_LCSYM, ! 474: stabtype(q), ! 475: memname(qstg,q->vardesc.varno) ); ! 476: prstleng(q, iarrlen(q)); ! 477: break; ! 478: ! 479: case STGINIT: ! 480: prstab(varstr(VL,q->varname), N_STSYM, ! 481: stabtype(q), ! 482: memname(qstg,q->vardesc.varno) ); ! 483: prstleng(q, iarrlen(q)); ! 484: break; ! 485: } ! 486: #endif ! 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==CLVAR && qstg==STGBSS) ! 492: { ! 493: align = (qtype==TYCHAR ? ALILONG : typealign[qtype]); ! 494: if(bssleng % align != 0) ! 495: { ! 496: bssleng = roundup(bssleng, align); ! 497: preven(align); ! 498: } ! 499: prlocvar(memname(STGBSS,q->vardesc.varno), iarrl = iarrlen(q) ); ! 500: bssleng += iarrl; ! 501: } ! 502: else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG) ! 503: mkext(varunder(VL, q->varname)) ->extstg = STGEXT; ! 504: ! 505: if(qclass==CLVAR && qstg!=STGARG) ! 506: { ! 507: if(q->vdim && !ISICON(q->vdim->nelt) ) ! 508: dclerr("adjustable dimension on non-argument", q); ! 509: if(qtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng))) ! 510: dclerr("adjustable leng on nonargument", q); ! 511: } ! 512: } ! 513: ! 514: for(i = 0 ; i < nequiv ; ++i) ! 515: if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 ) ! 516: { ! 517: bssleng = roundup(bssleng, ALIDOUBLE); ! 518: preven(ALIDOUBLE); ! 519: prlocvar( memname(STGEQUIV, i), leng); ! 520: bssleng += leng; ! 521: } ! 522: } ! 523: ! 524: ! 525: ! 526: donmlist() ! 527: { ! 528: register struct Hashentry *p; ! 529: register Namep q; ! 530: ! 531: pruse(asmfile, USEINIT); ! 532: ! 533: for(p=hashtab; p<lasthash; ++p) ! 534: if( (q = p->varp) && q->vclass==CLNAMELIST) ! 535: namelist(q); ! 536: } ! 537: ! 538: ! 539: doext() ! 540: { ! 541: struct Extsym *p; ! 542: ! 543: for(p = extsymtab ; p<nextext ; ++p) ! 544: prext( varstr(XL, p->extname), p->maxleng, p->extinit); ! 545: } ! 546: ! 547: ! 548: ! 549: ! 550: ftnint iarrlen(q) ! 551: register Namep q; ! 552: { ! 553: ftnint leng; ! 554: ! 555: leng = typesize[q->vtype]; ! 556: if(leng <= 0) ! 557: return(-1); ! 558: if(q->vdim) ! 559: if( ISICON(q->vdim->nelt) ) ! 560: leng *= q->vdim->nelt->constblock.const.ci; ! 561: else return(-1); ! 562: if(q->vleng) ! 563: if( ISICON(q->vleng) ) ! 564: leng *= q->vleng->constblock.const.ci; ! 565: else return(-1); ! 566: return(leng); ! 567: } ! 568: ! 569: /* This routine creates a static block representing the namelist. ! 570: An equivalent declaration of the structure produced is: ! 571: struct namelist ! 572: { ! 573: char namelistname[16]; ! 574: struct namelistentry ! 575: { ! 576: char varname[16]; ! 577: char *varaddr; ! 578: int type; # negative means -type= number of chars ! 579: struct dimensions *dimp; # null means scalar ! 580: } names[]; ! 581: }; ! 582: ! 583: struct dimensions ! 584: { ! 585: int numberofdimensions; ! 586: int numberofelements ! 587: int baseoffset; ! 588: int span[numberofdimensions]; ! 589: }; ! 590: where the namelistentry list terminates with a null varname ! 591: If dimp is not null, then the corner element of the array is at ! 592: varaddr. However, the element with subscripts (i1,...,in) is at ! 593: varaddr - dimp->baseoffset + sizeoftype * (i1+span[0]*(i2+span[1]*...) ! 594: */ ! 595: ! 596: namelist(np) ! 597: Namep np; ! 598: { ! 599: register chainp q; ! 600: register Namep v; ! 601: register struct Dimblock *dp; ! 602: char *memname(); ! 603: int type, dimno, dimoffset; ! 604: flag bad; ! 605: ! 606: ! 607: preven(ALILONG); ! 608: fprintf(asmfile, LABELFMT, memname(STGINIT, np->vardesc.varno)); ! 609: putstr(asmfile, varstr(VL, np->varname), 16); ! 610: dimno = ++lastvarno; ! 611: dimoffset = 0; ! 612: bad = NO; ! 613: ! 614: for(q = np->varxptr.namelist ; q ; q = q->nextp) ! 615: { ! 616: vardcl( v = (Namep) (q->datap) ); ! 617: type = v->vtype; ! 618: if( ONEOF(v->vstg, MSKSTATIC) ) ! 619: { ! 620: preven(ALILONG); ! 621: putstr(asmfile, varstr(VL,v->varname), 16); ! 622: praddr(asmfile, v->vstg, v->vardesc.varno, v->voffset); ! 623: prconi(asmfile, TYINT, ! 624: type==TYCHAR ? ! 625: -(v->vleng->constblock.const.ci) : (ftnint) type); ! 626: if(v->vdim) ! 627: { ! 628: praddr(asmfile, STGINIT, dimno, (ftnint)dimoffset); ! 629: dimoffset += 3 + v->vdim->ndim; ! 630: } ! 631: else ! 632: praddr(asmfile, STGNULL,0,(ftnint) 0); ! 633: } ! 634: else ! 635: { ! 636: dclerr("may not appear in namelist", v); ! 637: bad = YES; ! 638: } ! 639: } ! 640: ! 641: if(bad) ! 642: return; ! 643: ! 644: putstr(asmfile, "", 16); ! 645: ! 646: if(dimoffset > 0) ! 647: { ! 648: fprintf(asmfile, LABELFMT, memname(STGINIT,dimno)); ! 649: for(q = np->varxptr.namelist ; q ; q = q->nextp) ! 650: if(dp = q->datap->nameblock.vdim) ! 651: { ! 652: int i; ! 653: prconi(asmfile, TYINT, (ftnint) (dp->ndim) ); ! 654: prconi(asmfile, TYINT, ! 655: (ftnint) (dp->nelt->constblock.const.ci) ); ! 656: prconi(asmfile, TYINT, ! 657: (ftnint) (dp->baseoffset->constblock.const.ci)); ! 658: for(i=0; i<dp->ndim ; ++i) ! 659: prconi(asmfile, TYINT, ! 660: dp->dims[i].dimsize->constblock.const.ci); ! 661: } ! 662: } ! 663: ! 664: } ! 665: ! 666: LOCAL docommon() ! 667: { ! 668: register struct Extsym *p; ! 669: register chainp q; ! 670: struct Dimblock *t; ! 671: expptr neltp; ! 672: register Namep v; ! 673: ftnint size; ! 674: int type; ! 675: ! 676: for(p = extsymtab ; p<nextext ; ++p) ! 677: if(p->extstg==STGCOMMON) ! 678: { ! 679: #ifdef SDB ! 680: if(sdbflag) ! 681: prstab(CNULL, N_BCOMM, 0, 0); ! 682: #endif ! 683: for(q = p->extp ; q ; q = q->nextp) ! 684: { ! 685: v = (Namep) (q->datap); ! 686: if(v->vdcldone == NO) ! 687: vardcl(v); ! 688: type = v->vtype; ! 689: if(p->extleng % typealign[type] != 0) ! 690: { ! 691: dclerr("common alignment", v); ! 692: p->extleng = roundup(p->extleng, typealign[type]); ! 693: } ! 694: v->voffset = p->extleng; ! 695: v->vardesc.varno = p - extsymtab; ! 696: if(type == TYCHAR) ! 697: size = v->vleng->constblock.const.ci; ! 698: else size = typesize[type]; ! 699: if(t = v->vdim) ! 700: if( (neltp = t->nelt) && ISCONST(neltp) ) ! 701: size *= neltp->constblock.const.ci; ! 702: else ! 703: dclerr("adjustable array in common", v); ! 704: p->extleng += size; ! 705: #ifdef SDB ! 706: if(sdbflag) ! 707: { ! 708: prstssym(v); ! 709: prstleng(v, size); ! 710: } ! 711: #endif ! 712: } ! 713: ! 714: frchain( &(p->extp) ); ! 715: #ifdef SDB ! 716: if(sdbflag) ! 717: prstab(varstr(XL,p->extname), N_ECOMM, 0, 0); ! 718: #endif ! 719: } ! 720: } ! 721: ! 722: ! 723: ! 724: ! 725: ! 726: LOCAL docomleng() ! 727: { ! 728: register struct Extsym *p; ! 729: ! 730: for(p = extsymtab ; p < nextext ; ++p) ! 731: if(p->extstg == STGCOMMON) ! 732: { ! 733: if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng ! 734: && !eqn(XL,"_BLNK__ ",p->extname) ) ! 735: warn1("incompatible lengths for common block %s", ! 736: nounder(XL, p->extname) ); ! 737: if(p->maxleng < p->extleng) ! 738: p->maxleng = p->extleng; ! 739: p->extleng = 0; ! 740: } ! 741: } ! 742: ! 743: ! 744: ! 745: ! 746: /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ ! 747: ! 748: frtemp(p) ! 749: Addrp p; ! 750: { ! 751: /* restore clobbered character string lengths */ ! 752: if(p->vtype==TYCHAR && p->varleng!=0) ! 753: { ! 754: frexpr(p->vleng); ! 755: p->vleng = ICON(p->varleng); ! 756: } ! 757: ! 758: /* put block on chain of temps to be reclaimed */ ! 759: holdtemps = mkchain(p, holdtemps); ! 760: } ! 761: ! 762: ! 763: ! 764: ! 765: /* allocate an automatic variable slot */ ! 766: ! 767: Addrp autovar(nelt, t, lengp) ! 768: register int nelt, t; ! 769: expptr lengp; ! 770: { ! 771: ftnint leng; ! 772: register Addrp q; ! 773: ! 774: if(t == TYCHAR) ! 775: if( ISICON(lengp) ) ! 776: leng = lengp->constblock.const.ci; ! 777: else { ! 778: fatal("automatic variable of nonconstant length"); ! 779: } ! 780: else ! 781: leng = typesize[t]; ! 782: autoleng = roundup( autoleng, typealign[t]); ! 783: ! 784: q = ALLOC(Addrblock); ! 785: q->tag = TADDR; ! 786: q->vtype = t; ! 787: if(t == TYCHAR) ! 788: { ! 789: q->vleng = ICON(leng); ! 790: q->varleng = leng; ! 791: } ! 792: q->vstg = STGAUTO; ! 793: q->ntempelt = nelt; ! 794: #if TARGET==PDP11 || TARGET==VAX ! 795: /* stack grows downward */ ! 796: autoleng += nelt*leng; ! 797: q->memoffset = ICON( - autoleng ); ! 798: #else ! 799: q->memoffset = ICON( autoleng ); ! 800: autoleng += nelt*leng; ! 801: #endif ! 802: ! 803: return(q); ! 804: } ! 805: ! 806: ! 807: Addrp mktmpn(nelt, type, lengp) ! 808: int nelt; ! 809: register int type; ! 810: expptr lengp; ! 811: { ! 812: ftnint leng; ! 813: chainp p, oldp; ! 814: register Addrp q; ! 815: ! 816: if(type==TYUNKNOWN || type==TYERROR) ! 817: badtype("mktmpn", type); ! 818: ! 819: if(type==TYCHAR) ! 820: if( ISICON(lengp) ) ! 821: leng = lengp->constblock.const.ci; ! 822: else { ! 823: err("adjustable length"); ! 824: return( errnode() ); ! 825: } ! 826: /* ! 827: * if an temporary of appropriate shape is on the templist, ! 828: * remove it from the list and return it ! 829: */ ! 830: ! 831: for(oldp=CHNULL, p=templist ; p ; oldp=p, p=p->nextp) ! 832: { ! 833: q = (Addrp) (p->datap); ! 834: if(q->vtype==type && q->ntempelt==nelt && ! 835: (type!=TYCHAR || q->vleng->constblock.const.ci==leng) ) ! 836: { ! 837: if(oldp) ! 838: oldp->nextp = p->nextp; ! 839: else ! 840: templist = p->nextp; ! 841: free( (charptr) p); ! 842: return(q); ! 843: } ! 844: } ! 845: q = autovar(nelt, type, lengp); ! 846: q->istemp = YES; ! 847: return(q); ! 848: } ! 849: ! 850: ! 851: ! 852: ! 853: Addrp mktemp(type, lengp) ! 854: int type; ! 855: expptr lengp; ! 856: { ! 857: return( mktmpn(1,type,lengp) ); ! 858: } ! 859: ! 860: /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ ! 861: ! 862: struct Extsym *comblock(len, s) ! 863: register int len; ! 864: register char *s; ! 865: { ! 866: struct Extsym *p; ! 867: ! 868: if(len == 0) ! 869: { ! 870: s = BLANKCOMMON; ! 871: len = strlen(s); ! 872: } ! 873: p = mkext( varunder(len, s) ); ! 874: if(p->extstg == STGUNKNOWN) ! 875: p->extstg = STGCOMMON; ! 876: else if(p->extstg != STGCOMMON) ! 877: { ! 878: errstr("%s cannot be a common block name", s); ! 879: return(0); ! 880: } ! 881: ! 882: return( p ); ! 883: } ! 884: ! 885: ! 886: incomm(c, v) ! 887: struct Extsym *c; ! 888: Namep v; ! 889: { ! 890: if(v->vstg != STGUNKNOWN) ! 891: dclerr("incompatible common declaration", v); ! 892: else ! 893: { ! 894: v->vstg = STGCOMMON; ! 895: c->extp = hookup(c->extp, mkchain(v,CHNULL) ); ! 896: } ! 897: } ! 898: ! 899: ! 900: ! 901: ! 902: settype(v, type, length) ! 903: register Namep v; ! 904: register int type; ! 905: register int length; ! 906: { ! 907: if(type == TYUNKNOWN) ! 908: return; ! 909: ! 910: if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) ! 911: { ! 912: v->vtype = TYSUBR; ! 913: frexpr(v->vleng); ! 914: } ! 915: else if(type < 0) /* storage class set */ ! 916: { ! 917: if(v->vstg == STGUNKNOWN) ! 918: v->vstg = - type; ! 919: else if(v->vstg != -type) ! 920: dclerr("incompatible storage declarations", v); ! 921: } ! 922: else if(v->vtype == TYUNKNOWN) ! 923: { ! 924: if( (v->vtype = lengtype(type, length))==TYCHAR && length>=0) ! 925: v->vleng = ICON(length); ! 926: } ! 927: else if(v->vtype!=type || (type==TYCHAR && v->vleng->constblock.const.ci!=length) ) ! 928: dclerr("incompatible type declarations", v); ! 929: } ! 930: ! 931: ! 932: ! 933: ! 934: ! 935: lengtype(type, length) ! 936: register int type; ! 937: register int length; ! 938: { ! 939: switch(type) ! 940: { ! 941: case TYREAL: ! 942: if(length == 8) ! 943: return(TYDREAL); ! 944: if(length == 4) ! 945: goto ret; ! 946: break; ! 947: ! 948: case TYCOMPLEX: ! 949: if(length == 16) ! 950: return(TYDCOMPLEX); ! 951: if(length == 8) ! 952: goto ret; ! 953: break; ! 954: ! 955: case TYSHORT: ! 956: case TYDREAL: ! 957: case TYDCOMPLEX: ! 958: case TYCHAR: ! 959: case TYUNKNOWN: ! 960: case TYSUBR: ! 961: case TYERROR: ! 962: goto ret; ! 963: ! 964: case TYLOGICAL: ! 965: if(length == typesize[TYLOGICAL]) ! 966: goto ret; ! 967: break; ! 968: ! 969: case TYLONG: ! 970: if(length == 0) ! 971: return(tyint); ! 972: if(length == 2) ! 973: return(TYSHORT); ! 974: if(length == 4) ! 975: goto ret; ! 976: break; ! 977: default: ! 978: badtype("lengtype", type); ! 979: } ! 980: ! 981: if(length != 0) ! 982: err("incompatible type-length combination"); ! 983: ! 984: ret: ! 985: return(type); ! 986: } ! 987: ! 988: ! 989: ! 990: ! 991: ! 992: setintr(v) ! 993: register Namep v; ! 994: { ! 995: register int k; ! 996: ! 997: if(v->vstg == STGUNKNOWN) ! 998: v->vstg = STGINTR; ! 999: else if(v->vstg!=STGINTR) ! 1000: dclerr("incompatible use of intrinsic function", v); ! 1001: if(v->vclass==CLUNKNOWN) ! 1002: v->vclass = CLPROC; ! 1003: if(v->vprocclass == PUNKNOWN) ! 1004: v->vprocclass = PINTRINSIC; ! 1005: else if(v->vprocclass != PINTRINSIC) ! 1006: dclerr("invalid intrinsic declaration", v); ! 1007: if(k = intrfunct(v->varname)) ! 1008: v->vardesc.varno = k; ! 1009: else ! 1010: dclerr("unknown intrinsic function", v); ! 1011: } ! 1012: ! 1013: ! 1014: ! 1015: setext(v) ! 1016: register Namep v; ! 1017: { ! 1018: if(v->vclass == CLUNKNOWN) ! 1019: v->vclass = CLPROC; ! 1020: else if(v->vclass != CLPROC) ! 1021: dclerr("invalid external declaration", v); ! 1022: ! 1023: if(v->vprocclass == PUNKNOWN) ! 1024: v->vprocclass = PEXTERNAL; ! 1025: else if(v->vprocclass != PEXTERNAL) ! 1026: dclerr("invalid external declaration", v); ! 1027: } ! 1028: ! 1029: ! 1030: ! 1031: ! 1032: /* create dimensions block for array variable */ ! 1033: ! 1034: setbound(v, nd, dims) ! 1035: register Namep v; ! 1036: int nd; ! 1037: struct { expptr lb, ub; } dims[ ]; ! 1038: { ! 1039: register expptr q, t; ! 1040: register struct Dimblock *p; ! 1041: int i; ! 1042: ! 1043: if(v->vclass == CLUNKNOWN) ! 1044: v->vclass = CLVAR; ! 1045: else if(v->vclass != CLVAR) ! 1046: { ! 1047: dclerr("only variables may be arrays", v); ! 1048: return; ! 1049: } ! 1050: ! 1051: v->vdim = p = (struct Dimblock *) ! 1052: ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); ! 1053: p->ndim = nd; ! 1054: p->nelt = ICON(1); ! 1055: ! 1056: for(i=0 ; i<nd ; ++i) ! 1057: { ! 1058: if( (q = dims[i].ub) == NULL) ! 1059: { ! 1060: if(i == nd-1) ! 1061: { ! 1062: frexpr(p->nelt); ! 1063: p->nelt = NULL; ! 1064: } ! 1065: else ! 1066: err("only last bound may be asterisk"); ! 1067: p->dims[i].dimsize = ICON(1);; ! 1068: p->dims[i].dimexpr = NULL; ! 1069: } ! 1070: else ! 1071: { ! 1072: if(dims[i].lb) ! 1073: { ! 1074: q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); ! 1075: q = mkexpr(OPPLUS, q, ICON(1) ); ! 1076: } ! 1077: if( ISCONST(q) ) ! 1078: { ! 1079: p->dims[i].dimsize = q; ! 1080: p->dims[i].dimexpr = (expptr) PNULL; ! 1081: } ! 1082: else { ! 1083: p->dims[i].dimsize = (expptr) autovar(1, tyint, PNULL); ! 1084: p->dims[i].dimexpr = q; ! 1085: } ! 1086: if(p->nelt) ! 1087: p->nelt = mkexpr(OPSTAR, p->nelt, ! 1088: cpexpr(p->dims[i].dimsize) ); ! 1089: } ! 1090: } ! 1091: ! 1092: q = dims[nd-1].lb; ! 1093: if(q == NULL) ! 1094: q = ICON(1); ! 1095: ! 1096: for(i = nd-2 ; i>=0 ; --i) ! 1097: { ! 1098: t = dims[i].lb; ! 1099: if(t == NULL) ! 1100: t = ICON(1); ! 1101: if(p->dims[i].dimsize) ! 1102: q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); ! 1103: } ! 1104: ! 1105: if( ISCONST(q) ) ! 1106: { ! 1107: p->baseoffset = q; ! 1108: p->basexpr = NULL; ! 1109: } ! 1110: else ! 1111: { ! 1112: p->baseoffset = (expptr) autovar(1, tyint, PNULL); ! 1113: p->basexpr = q; ! 1114: } ! 1115: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.