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

   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

Defined macros