# 2.11BSD#431 - /usr/src/usr.bin/f77/proc.c

##### Functions

    autovar           X
    comblock          X
    dobss             X
    docomleng         X
    docommon          X
    doentry           X
    doext             X
    enddcl            X
    endproc           X
    entrypt           X
    epicode           X
    frtemp            X
    iarrlen           X
    incomm            X
    lengtype          X
    mktemp            X
    mktmpn            X
    newentry          X
    newproc           X
    nextarg           X
    procode           X
    retval            X
    setbound          X
    setext            X
    setintr           X
    settype           X
    startproc         X

       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(multitype)
     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

autovar defined in line 549; used 10 times

- in line 188, 256-259(2), 346, 616, 854, 882
- in /usr/src/usr.bin/f77/defs line 441
- in /usr/src/usr.bin/f77/expr.c line 1256
- in /usr/src/usr.bin/f77/io.c line 246

comblock defined in line 633; used 7 times

- in /usr/src/usr.bin/f77/gram.dcl line 63-66(3), 73-75(2), 174
- in /usr/src/usr.bin/f77/gram.head line 30

dobss defined in line 387; used 1 times

- in line 36

docomleng defined in line 516; used 1 times

- in line 57

docommon defined in line 471; used 1 times

- in line 55

doentry defined in line 286; used 2 times

- in line 59, 165

doext defined in line 441; used 1 times

- in /usr/src/usr.bin/f77/main.c line 119

enddcl defined in line 50; used 4 times

- in line 27
- in /usr/src/usr.bin/f77/exec.c line 152
- in /usr/src/usr.bin/f77/gram.dcl line 125
- in /usr/src/usr.bin/f77/gram.exec line 117

endproc defined in line 22; used 3 times

- in line 11
- in /usr/src/usr.bin/f77/gram.head line 69
- in /usr/src/usr.bin/f77/main.c line 117

entrypt defined in line 117; used 4 times

- in /usr/src/usr.bin/f77/gram.head line 107-116(4)

epicode defined in line 170; used 1 times

- in line 34

frtemp defined in line 538; used 3 times

- in /usr/src/usr.bin/f77/expr.c line 300
- in /usr/src/usr.bin/f77/putdmr.c line 1187-1188(2)

iarrlen defined in line 452; used 4 times

- in line 393, 413
- in /usr/src/usr.bin/f77/equiv.c line 4, 56

incomm defined in line 657; used 4 times

- in /usr/src/usr.bin/f77/gram.dcl line 63-69(4)

lengtype defined in line 707; used 3 times

- in line 133, 695
- in /usr/src/usr.bin/f77/init.c line 248

mktemp defined in line 624; used 23 times

- in /usr/src/usr.bin/f77/defs line 440
- in /usr/src/usr.bin/f77/exec.c line 342, 353
- in /usr/src/usr.bin/f77/expr.c line 813, 1092
- in /usr/src/usr.bin/f77/intr.c line 608
- in /usr/src/usr.bin/f77/io.c line 303, 475
- in /usr/src/usr.bin/f77/putdmr.c line 442, 501, 516, 549, 618, 628, 647, 775, 796, 804, 1077, 1084, 1116, 1164-1165(2)

mktmpn defined in line 586; used 4 times

- in line 628
- in /usr/src/usr.bin/f77/defs line 440
- in /usr/src/usr.bin/f77/putdmr.c line 896-897(2)

newentry defined in line 93; used 3 times

- in line 78
- in /usr/src/usr.bin/f77/defs line 438
- in /usr/src/usr.bin/f77/gram.head line 125

newproc defined in line 6; used 5 times

- in /usr/src/usr.bin/f77/gram.dcl line 120, 309
- in /usr/src/usr.bin/f77/gram.exec line 57, 114
- in /usr/src/usr.bin/f77/gram.head line 121

nextarg defined in line 376; used 7 times

- in line 328-329(2), 340, 353, 363-368(3)

procode defined in line 250; used 1 times

- in line 35

retval defined in line 212; used 2 times

- in line 194-198(2)

setbound defined in line 806; used 3 times

- in /usr/src/usr.bin/f77/gram.dcl line 18-22(2), 192

setext defined in line 787; used 2 times

- in /usr/src/usr.bin/f77/gram.dcl line 79-81(2)

setintr defined in line 764; used 2 times

- in /usr/src/usr.bin/f77/gram.dcl line 85-87(2)

settype defined in line 673; used 5 times

- in line 162
- in /usr/src/usr.bin/f77/exec.c line 202
- in /usr/src/usr.bin/f77/expr.c line 1291
- in /usr/src/usr.bin/f77/gram.dcl line 17-21(2)

startproc defined in line 66; used 6 times

- in /usr/src/usr.bin/f77/gram.dcl line 121, 310
- in /usr/src/usr.bin/f77/gram.exec line 58, 115
- in /usr/src/usr.bin/f77/gram.head line 103-105(2)

Last modified: 1994-01-04 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 2152 |