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

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

Defined functions

Defined macros