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