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