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