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

##### Functions

    enddo             X
    exar2             X
    exarif            X
    exasgoto          X
    exassign          X
    excall            X
    exdo              X
    exelif            X
    exelse            X
    exendif           X
    exequals          X
    exgoto            X
    exif              X
    exreturn          X
    exstop            X
    mkstfunct         X
    popctl            X
    poplab            X
    pushctl           X

##### Macros

    DOINCR            X
    DOINIT            X
    DOLIMIT           X
    NEGSTEP           X
    POSSTEP           X
    VARSTEP           X

       1: #include "defs"
       2: #include "string_defs"
       3:
       4: /*   Logical IF codes
       5: */
       6:
       7:
       8: exif(p)
       9: expptr p;
      10: {
      11: pushctl(CTLIF);
      12: ctlstack->elselabel = newlabel();
      13: putif(p, ctlstack->elselabel);
      14: }
      15:
      16:
      17:
      18: exelif(p)
      19: expptr p;
      20: {
      21: if(ctlstack->ctltype == CTLIF)
      22:     {
      23:     if(ctlstack->endlabel == 0)
      24:         ctlstack->endlabel = newlabel();
      25:     putgoto(ctlstack->endlabel);
      26:     putlabel(ctlstack->elselabel);
      27:     ctlstack->elselabel = newlabel();
      28:     putif(p, ctlstack->elselabel);
      29:     }
      30:
      31: else    error("elseif out of place", 0,0,EXECERR);
      32: }
      33:
      34:
      35:
      36:
      37:
      38: exelse()
      39: {
      40: if(ctlstack->ctltype==CTLIF)
      41:     {
      42:     if(ctlstack->endlabel == 0)
      43:         ctlstack->endlabel = newlabel();
      44:     putgoto( ctlstack->endlabel );
      45:     putlabel(ctlstack->elselabel);
      46:     ctlstack->ctltype = CTLELSE;
      47:     }
      48:
      49: else    error("else out of place", 0,0,EXECERR);
      50: }
      51:
      52:
      53: exendif()
      54: {
      55: if(ctlstack->ctltype == CTLIF)
      56:     {
      57:     putlabel(ctlstack->elselabel);
      58:     if(ctlstack->endlabel)
      59:         putlabel(ctlstack->endlabel);
      60:     popctl();
      61:     }
      62: else if(ctlstack->ctltype == CTLELSE)
      63:     {
      64:     putlabel(ctlstack->endlabel);
      65:     popctl();
      66:     }
      67:
      68: else
      69:     error("endif out of place", 0,0,EXECERR);
      70: }
      71:
      72:
      73:
      74: LOCAL pushctl(code)
      75: int code;
      76: {
      77: register int i;
      78:
      79: if(++ctlstack >= lastctl)
      80:     error("nesting too deep",0,0,FATAL);
      81: ctlstack->ctltype = code;
      82: for(i = 0 ; i < 4 ; ++i)
      83:     ctlstack->ctlabels[i] = 0;
      84: ++blklevel;
      85: }
      86:
      87:
      88: LOCAL popctl()
      89: {
      90: if( ctlstack-- < ctls )
      91:     error("control stack empty",0,0,FATAL);
      92: --blklevel;
      93: }
      94:
      95:
      96:
      97: LOCAL poplab()
      98: {
      99: register struct labelblock  *lp;
     100:
     101: for(lp = labeltab ; lp < highlabtab ; ++lp)
     102:     if(lp->labdefined)
     103:         {
     104:         /* mark all labels in inner blocks unreachable */
     105:         if(lp->blklevel > blklevel)
     106:             lp->labinacc = YES;
     107:         }
     108:     else if(lp->blklevel > blklevel)
     109:         {
     110:         /* move all labels referred to in inner blocks out a level */
     111:         lp->blklevel = blklevel;
     112:         }
     113: }
     114:
     115:
     116:
     117: /*  BRANCHING CODE
     118: */
     119:
     120: exgoto(lab)
     121: struct labelblock *lab;
     122: {
     123: putgoto(lab->labelno);
     124: }
     125:
     126:
     127:
     128:
     129:
     130:
     131:
     132: exequals(lp, rp)
     133: register struct primblock *lp;
     134: register expptr rp;
     135: {
     136: if(lp->tag != TPRIM)
     137:     {
     138:     error("assignment to a non-variable",0,0,ERR);
     139:     frexpr(lp);
     140:     frexpr(rp);
     141:     }
     142: else if(lp->namep->vclass!=CLVAR && lp->argsp)
     143:     {
     144:     if(parstate >= INEXEC)
     145:         error("statement function amid executables",0,0,ERR);
     146:     else
     147:         mkstfunct(lp, rp);
     148:     }
     149: else
     150:     {
     151:     if(parstate < INDATA)
     152:         enddcl();
     153:     puteq(mklhs(lp), rp);
     154:     }
     155: }
     156:
     157:
     158:
     159: mkstfunct(lp, rp)
     160: struct primblock *lp;
     161: expptr rp;
     162: {
     163: register struct primblock *p;
     164: register struct nameblock *np;
     165: chainp args;
     166:
     167: np = lp->namep;
     168: if(np->vclass == CLUNKNOWN)
     169:     np->vclass = CLPROC;
     170: else
     171:     {
     172:     error("redeclaration of statement function", np, 0, DCLERR);
     173:     return;
     174:     }
     175: np->vprocclass = PSTFUNCT;
     176: np->vstg = STGSTFUNCT;
     177: impldcl(np);
     178: args = (lp->argsp ? lp->argsp->listp : NULL);
     179: np->vardesc.vstfdesc = mkchain(args , rp );
     180:
     181: for( ; args ; args = args->nextp)
     182:     if( (p = args->datap)->tag!=TPRIM ||
     183:         p->argsp || p->fcharp || p->lcharp)
     184:         error("non-variable argument in statement function definition",0,0,ERR);
     185:     else
     186:         {
     187:         vardcl(args->datap = p->namep);
     188:         free(p);
     189:         }
     190: }
     191:
     192:
     193:
     194: excall(name, args, nstars, labels)
     195: struct hashentry *name;
     196: struct listblock *args;
     197: int nstars;
     198: struct labelblock *labels[ ];
     199: {
     200: register expptr p;
     201:
     202: settype(name, TYSUBR, NULL);
     203: p = mkfunct( mkprim(name, args, NULL, NULL) );
     204: p->vtype = p->leftp->vtype = TYINT;
     205: if(nstars > 0)
     206:     putcmgo(p, nstars, labels);
     207: else putexpr(p);
     208: }
     209:
     210:
     211:
     212: exstop(stop, p)
     213: int stop;
     214: register expptr p;
     215: {
     216: char *q;
     217: int n;
     218: struct constblock *mkstrcon();
     219:
     220: if(p)
     221:     {
     222:     if( ! ISCONST(p) )
     223:         {
     224:         error("pause/stop argument must be constant", 0,0,EXECERR);
     225:         frexpr(p);
     226:         p = mkstrcon(0, 0);
     227:         }
     228:     else if( ISINT(p->vtype) )
     229:         {
     230:         q = convic(p->const.ci);
     231:         n = strlen(q);
     232:         if(n > 0)
     233:             {
     234:             p->const.ccp = copyn(n, q);
     235:             p->vtype = TYCHAR;
     236:             p->vleng = ICON(n);
     237:             }
     238:         else
     239:             p = mkstrcon(0, 0);
     240:         }
     241:     else if(p->vtype != TYCHAR)
     242:         {
     243:         error("pause/stop argument must be integer or string",
     244:             0,0,EXECERR);
     245:         p = mkstrcon(0, 0);
     246:         }
     247:     }
     248: else    p = mkstrcon(0, 0);
     249:
     250: putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
     251: }
     252:
     253: /* DO LOOP CODE */
     254:
     255: #define DOINIT  par[0]
     256: #define DOLIMIT par[1]
     257: #define DOINCR  par[2]
     258:
     259: #define VARSTEP 0
     260: #define POSSTEP 1
     261: #define NEGSTEP 2
     262:
     263:
     264: exdo(range, spec)
     265: int range;
     266: chainp spec;
     267: {
     268: register expptr p, q;
     269: expptr *q1;
     270: register struct nameblock *np;
     271: chainp cp;
     272: register int i;
     273: int dotype, incsign;
     274: struct addrblock *dovarp, *dostgp;
     275: expptr par[3];
     276:
     277: pushctl(CTLDO);
     278: dorange = ctlstack->dolabel = range;
     279: np = spec->datap;
     280: ctlstack->donamep = NULL;
     281: if(np->vdovar)
     282:     {
     283:     error("nested loops with variable %s", varstr(VL,np->varname),0,ERR1);
     284:     ctlstack->donamep = NULL;
     285:     return;
     286:     }
     287:
     288: dovarp = mklhs( mkprim(np, 0,0,0) );
     289: if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
     290:     {
     291:     error("bad type on do variable",0,0,ERR);
     292:     return;
     293:     }
     294: ctlstack->donamep = np;
     295:
     296: np->vdovar = YES;
     297: if( enregister(np) )
     298:     {
     299:     /* stgp points to a storage version, varp to a register version */
     300:     dostgp = dovarp;
     301:     dovarp = mklhs( mkprim(np, 0,0,0) );
     302:     }
     303: else
     304:     dostgp = NULL;
     305: dotype = dovarp->vtype;
     306:
     307: for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
     308:     {
     309:     p = par[i++] = fixtype(cp->datap);
     310:     if( ! ONEOF(p->vtype, MSKINT|MSKREAL) )
     311:         {
     312:         error("bad type on DO parameter",0,0,ERR);
     313:         return;
     314:         }
     315:     }
     316:
     317: frchain(&spec);
     318: switch(i)
     319:     {
     320:     case 0:
     321:     case 1:
     322:         error("too few DO parameters",0,0,ERR);
     323:         return;
     324:
     325:     default:
     326:         error("too many DO parameters",0,0,ERR);
     327:         return;
     328:
     329:     case 2:
     330:         DOINCR = ICON(1);
     331:
     332:     case 3:
     333:         break;
     334:     }
     335:
     336: ctlstack->endlabel = newlabel();
     337: ctlstack->dobodylabel = newlabel();
     338:
     339: if( ISCONST(DOLIMIT) )
     340:     ctlstack->domax = mkconv(dotype, DOLIMIT);
     341: else
     342:     ctlstack->domax = mktemp(dotype, NULL);
     343:
     344: if( ISCONST(DOINCR) )
     345:     {
     346:     ctlstack->dostep = mkconv(dotype, DOINCR);
     347:     if( (incsign = conssgn(ctlstack->dostep)) == 0)
     348:         error("zero DO increment",0,0,ERR);
     349:     ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
     350:     }
     351: else
     352:     {
     353:     ctlstack->dostep = mktemp(dotype, NULL);
     354:     ctlstack->dostepsign = VARSTEP;
     355:     ctlstack->doposlabel = newlabel();
     356:     ctlstack->doneglabel = newlabel();
     357:     }
     358:
     359: if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
     360:     {
     361:     puteq(cpexpr(dovarp), cpexpr(DOINIT));
     362:     if( onetripflag )
     363:         frexpr(DOINIT);
     364:     else
     365:         {
     366:         q = mkexpr(OPPLUS, ICON(1),
     367:             mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
     368:         if(incsign != conssgn(q))
     369:             {
     370:             error("DO range never executed",0,0,WARN);
     371:             putgoto(ctlstack->endlabel);
     372:             }
     373:         frexpr(q);
     374:         }
     375:     }
     376: else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
     377:     {
     378:     if( ISCONST(ctlstack->domax) )
     379:         q = cpexpr(ctlstack->domax);
     380:     else
     381:         q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
     382:
     383:     q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
     384:     q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
     385:     putif(q, ctlstack->endlabel);
     386:     }
     387: else
     388:     {
     389:     if(! ISCONST(ctlstack->domax) )
     390:         puteq( cpexpr(ctlstack->domax), DOLIMIT);
     391:     q = DOINIT;
     392:     if( ! onetripflag )
     393:         q = mkexpr(OPMINUS, q,
     394:             mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
     395:     puteq( cpexpr(dovarp), q);
     396:     if(onetripflag && ctlstack->dostepsign==VARSTEP)
     397:         puteq( cpexpr(ctlstack->dostep), DOINCR);
     398:     }
     399:
     400: if(ctlstack->dostepsign == VARSTEP)
     401:     {
     402:     if(onetripflag)
     403:         putgoto(ctlstack->dobodylabel);
     404:     else
     405:         putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
     406:             ctlstack->doneglabel );
     407:     putlabel(ctlstack->doposlabel);
     408:     putif( mkexpr(OPLE,
     409:         mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
     410:         cpexpr(ctlstack->domax) ),
     411:             ctlstack->endlabel);
     412:     }
     413: putlabel(ctlstack->dobodylabel);
     414: if(dostgp)
     415:     puteq(dostgp, cpexpr(dovarp));
     416: frexpr(dovarp);
     417: }
     418:
     419:
     420:
     421: enddo(here)
     422: int here;
     423: {
     424: register struct ctlframe *q;
     425: register expptr t;
     426: struct nameblock *np;
     427: struct addrblock *ap;
     428: register int i;
     429:
     430: while(here == dorange)
     431:     {
     432:     if(np = ctlstack->donamep)
     433:         {
     434:         t = mkexpr(OPPLUSEQ, mklhs(mkprim(ctlstack->donamep, 0,0,0)),
     435:             cpexpr(ctlstack->dostep) );
     436:
     437:         if(ctlstack->dostepsign == VARSTEP)
     438:             {
     439:             putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
     440:             putlabel(ctlstack->doneglabel);
     441:             putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
     442:             }
     443:         else
     444:             putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
     445:                 t, ctlstack->domax),
     446:                 ctlstack->dobodylabel);
     447:         putlabel(ctlstack->endlabel);
     448:         if(ap = memversion(np))
     449:             puteq(ap, mklhs( mkprim(np,0,0,0)) );
     450:         for(i = 0 ; i < 4 ; ++i)
     451:             ctlstack->ctlabels[i] = 0;
     452:         deregister(ctlstack->donamep);
     453:         ctlstack->donamep->vdovar = NO;
     454:         frexpr(ctlstack->dostep);
     455:         }
     456:
     457:     popctl();
     458:     poplab();
     459:     dorange = 0;
     460:     for(q = ctlstack ; q>=ctls ; --q)
     461:         if(q->ctltype == CTLDO)
     462:             {
     463:             dorange = q->dolabel;
     464:             break;
     465:             }
     466:     }
     467: }
     468:
     469: exassign(vname, labelval)
     470: struct nameblock *vname;
     471: struct labelblock *labelval;
     472: {
     473: struct addrblock *p;
     474: struct constblock *mkaddcon();
     475:
     476: p = mklhs(mkprim(vname,0,0,0));
     477: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
     478:     error("noninteger assign variable",0,0,ERR);
     479: else
     480:     puteq(p, mkaddcon(labelval->labelno) );
     481: }
     482:
     483:
     484:
     485: exarif(expr, neglab, zerlab, poslab)
     486: expptr expr;
     487: struct labelblock *neglab, *zerlab, *poslab;
     488: {
     489: register int lm, lz, lp;
     490:
     491: lm = neglab->labelno;
     492: lz = zerlab->labelno;
     493: lp = poslab->labelno;
     494: expr = fixtype(expr);
     495:
     496: if( ! ONEOF(expr->vtype, MSKINT|MSKREAL) )
     497:     {
     498:     error("invalid type of arithmetic if expression",0,0,ERR);
     499:     frexpr(expr);
     500:     }
     501: else
     502:     {
     503:     if(lm == lz)
     504:         exar2(OPLE, expr, lm, lp);
     505:     else if(lm == lp)
     506:         exar2(OPNE, expr, lm, lz);
     507:     else if(lz == lp)
     508:         exar2(OPGE, expr, lz, lm);
     509:     else
     510:         prarif(expr, lm, lz, lp);
     511:     }
     512: }
     513:
     514:
     515:
     516: LOCAL exar2(op, e, l1, l2)
     517: int op;
     518: expptr e;
     519: int l1, l2;
     520: {
     521: putif( mkexpr(op, e, ICON(0)), l2);
     522: putgoto(l1);
     523: }
     524:
     525:
     526: exreturn(p)
     527: register expptr p;
     528: {
     529: if(procclass != CLPROC)
     530:     error("RETURN statement in main or block data",0,0,WARN);
     531: if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
     532:     {
     533:     error("alternate return in nonsubroutine",0,0,ERR);
     534:     p = 0;
     535:     }
     536:
     537: if(p)
     538:     {
     539:     putforce(TYINT, p);
     540:     putgoto(retlabel);
     541:     }
     542: else
     543:     putgoto(proctype==TYSUBR ? ret0label : retlabel);
     544: }
     545:
     546:
     547:
     548: exasgoto(labvar)
     549: struct hashentry *labvar;
     550: {
     551: register struct addrblock *p;
     552:
     553: p = mklhs( mkprim(labvar,0,0,0) );
     554: if( ! ISINT(p->vtype) )
     555:     error("assigned goto variable must be integer",0,0,ERR);
     556: else
     557:     putbranch(p);
     558: }

#### Defined functions

enddo defined in line 421; used 2 times

- in /usr/src/usr.bin/f77/gram.head line 60
- in /usr/src/usr.bin/f77/io.c line 452

exar2 defined in line 516; used 3 times

- in line 504-508(3)

exarif defined in line 485; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 37

exasgoto defined in line 548; used 2 times

- in /usr/src/usr.bin/f77/gram.exec line 66-68(2)

exassign defined in line 469; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 31

excall defined in line 194; used 3 times

- in /usr/src/usr.bin/f77/gram.exec line 39-44(3)

exdo defined in line 264; used 2 times

- in /usr/src/usr.bin/f77/gram.exec line 7
- in /usr/src/usr.bin/f77/io.c line 450

exelif defined in line 18; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 13

exelse defined in line 38; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 15

exendif defined in line 53; used 2 times

- in /usr/src/usr.bin/f77/gram.exec line 10, 17

exequals defined in line 132; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 29

exgoto defined in line 120; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 64

exif defined in line 8; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 21

exreturn defined in line 526; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 49

exstop defined in line 212; used 1 times

- in /usr/src/usr.bin/f77/gram.exec line 51

mkstfunct defined in line 159; used 1 times

- in line 147

popctl defined in line 88; used 3 times

- in line 60-65(2), 457

poplab defined in line 97; used 1 times

- in line 458

pushctl defined in line 74; used 2 times

- in line 11, 277

#### Defined macros

DOINCR defined in line 257; used 5 times

- in line 330, 344-346(2), 394-397(2)

DOINIT defined in line 255; used 6 times

- in line 359-367(4), 383, 391

DOLIMIT defined in line 256; used 4 times

- in line 339-340(2), 381, 390

NEGSTEP defined in line 261; used 1 times

- in line 349

POSSTEP defined in line 260; used 3 times

- in line 349, 384, 444

VARSTEP defined in line 259; used 6 times

- in line 354-359(2), 376, 396-400(2), 437

Last modified: 1987-02-17 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1573 |