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