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