2.9BSD - /usr/src/cmd/f77/proc.c

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

Defined functions