UNIX 7th Ed. - /usr/src/cmd/f77/proc.c

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

Defined functions