4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/exec.c

   1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)exec.c	5.5 (Berkeley) 1/7/86";
   9: #endif not lint
  10: 
  11: /*
  12:  * exec.c
  13:  *
  14:  * Routines for handling the semantics of control structures.
  15:  * F77 compiler, pass 1.
  16:  *
  17:  * University of Utah CS Dept modification history:
  18:  *
  19:  * $Log:	exec.c,v $
  20:  * Revision 5.6  85/12/20  19:42:46  donn
  21:  * Change style of error reporting in last fix.
  22:  *
  23:  * Revision 5.5  85/12/20  18:54:10  donn
  24:  * Complain about calls to things which aren't subroutines.
  25:  *
  26:  * Revision 5.4  85/12/18  19:57:58  donn
  27:  * Assignment statements are executable statements -- advance the magic
  28:  * parser state to forbid DATA statements and statement functions.
  29:  *
  30:  * Revision 5.3  85/11/25  00:23:49  donn
  31:  * 4.3 beta
  32:  *
  33:  * Revision 5.2  85/08/10  04:07:36  donn
  34:  * Changed an error message to correct spelling and be more accurate.
  35:  * From Jerry Berkman.
  36:  *
  37:  * Revision 2.3  85/03/18  08:03:31  donn
  38:  * Hacks for conversions from type address to numeric type -- prevent addresses
  39:  * from being stored in shorts and prevent warnings about implicit conversions.
  40:  *
  41:  * Revision 2.2  84/09/03  23:18:30  donn
  42:  * When a DO loop had the same variable as its loop variable and its limit,
  43:  * the limit temporary was assigned to AFTER the original value of the variable
  44:  * was destroyed by assigning the initial value to the loop variable.  I
  45:  * swapped the operands of a comparison and changed the direction of the
  46:  * operator...  This only affected programs when optimizing.  (This may not
  47:  * be enough if something alters the order of evaluation of side effects
  48:  * later on... sigh.)
  49:  *
  50:  * Revision 2.1  84/07/19  12:02:53  donn
  51:  * Changed comment headers for UofU.
  52:  *
  53:  * Revision 1.3  84/07/12  18:35:12  donn
  54:  * Added change to enddo() to detect open 'if' blocks at the ends of loops.
  55:  *
  56:  * Revision 1.2  84/06/08  11:22:53  donn
  57:  * Fixed bug in exdo() -- if a loop parameter contained an instance of the loop
  58:  * variable and the optimizer was off, the loop variable got converted to
  59:  * register before the parameters were processed and so the loop parameters
  60:  * were initialized from garbage in the register instead of the memory version
  61:  * of the loop variable.
  62:  *
  63:  */
  64: 
  65: #include "defs.h"
  66: #include "optim.h"
  67: 
  68: 
  69: /*   Logical IF codes
  70: */
  71: 
  72: 
  73: exif(p)
  74: expptr p;
  75: {
  76: register int k;
  77: pushctl(CTLIF);
  78: ctlstack->elselabel = newlabel();
  79: 
  80: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
  81:     {
  82:     if(k != TYERROR)
  83:         err("non-logical expression in IF statement");
  84:     frexpr(p);
  85:     }
  86: else if (optimflag)
  87:     optbuff (SKIFN, p, ctlstack->elselabel, 0);
  88: else
  89:     putif (p, ctlstack->elselabel);
  90: }
  91: 
  92: 
  93: 
  94: exelif(p)
  95: expptr p;
  96: {
  97: int k,oldelse;
  98: 
  99: if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
 100:     {
 101:     if(k != TYERROR)
 102:         err("non-logical expression in IF statement");
 103:     frexpr(p);
 104:     }
 105: else    {
 106:         if(ctlstack->ctltype == CTLIF)
 107:         {
 108:         if(ctlstack->endlabel == 0) ctlstack->endlabel = newlabel();
 109:             oldelse=ctlstack->elselabel;
 110:         ctlstack->elselabel = newlabel();
 111:         if (optimflag)
 112:             {
 113:             optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
 114:             optbuff (SKLABEL, 0, oldelse, 0);
 115:             optbuff (SKIFN, p, ctlstack->elselabel, 0);
 116:             }
 117:         else
 118:             {
 119:             putgoto (ctlstack->endlabel);
 120:             putlabel (oldelse);
 121:             putif (p, ctlstack->elselabel);
 122:             }
 123:         }
 124:         else    execerr("elseif out of place", CNULL);
 125:         }
 126: }
 127: 
 128: 
 129: 
 130: 
 131: 
 132: exelse()
 133: {
 134: if(ctlstack->ctltype==CTLIF)
 135:     {
 136:     if(ctlstack->endlabel == 0)
 137:         ctlstack->endlabel = newlabel();
 138:     ctlstack->ctltype = CTLELSE;
 139:     if (optimflag)
 140:         {
 141:         optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
 142:         optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
 143:         }
 144:     else
 145:         {
 146:         putgoto (ctlstack->endlabel);
 147:         putlabel (ctlstack->elselabel);
 148:         }
 149:     }
 150: 
 151: else    execerr("else out of place", CNULL);
 152: }
 153: 
 154: 
 155: exendif()
 156: {
 157: if (ctlstack->ctltype == CTLIF)
 158:     {
 159:     if (optimflag)
 160:         {
 161:         optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
 162:         if (ctlstack->endlabel)
 163:             optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
 164:         }
 165:     else
 166:         {
 167:         putlabel (ctlstack->elselabel);
 168:         if (ctlstack->endlabel)
 169:             putlabel (ctlstack->endlabel);
 170:         }
 171:     popctl ();
 172:     }
 173: else if (ctlstack->ctltype == CTLELSE)
 174:     {
 175:     if (optimflag)
 176:         optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
 177:     else
 178:         putlabel (ctlstack->endlabel);
 179:     popctl ();
 180:     }
 181: else
 182:     execerr("endif out of place", CNULL);
 183: }
 184: 
 185: 
 186: 
 187: LOCAL pushctl(code)
 188: int code;
 189: {
 190: register int i;
 191: 
 192: /* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */
 193: if(++ctlstack >= lastctl)
 194:     many("loops or if-then-elses", 'c');
 195: ctlstack->ctltype = code;
 196: for(i = 0 ; i < 4 ; ++i)
 197:     ctlstack->ctlabels[i] = 0;
 198: ++blklevel;
 199: }
 200: 
 201: 
 202: LOCAL popctl()
 203: {
 204: if( ctlstack-- < ctls )
 205:     fatal("control stack empty");
 206: --blklevel;
 207: }
 208: 
 209: 
 210: 
 211: LOCAL poplab()
 212: {
 213: register struct Labelblock  *lp;
 214: 
 215: for(lp = labeltab ; lp < highlabtab ; ++lp)
 216:     if(lp->labdefined)
 217:         {
 218:         /* mark all labels in inner blocks unreachable */
 219:         if(lp->blklevel > blklevel)
 220:             lp->labinacc = YES;
 221:         }
 222:     else if(lp->blklevel > blklevel)
 223:         {
 224:         /* move all labels referred to in inner blocks out a level */
 225:         lp->blklevel = blklevel;
 226:         }
 227: }
 228: 
 229: 
 230: 
 231: /*  BRANCHING CODE
 232: */
 233: 
 234: exgoto(lab)
 235: struct Labelblock *lab;
 236: {
 237: if (optimflag)
 238:     optbuff (SKGOTO, 0, lab->labelno, 0);
 239: else
 240:     putgoto (lab->labelno);
 241: }
 242: 
 243: 
 244: 
 245: 
 246: 
 247: 
 248: 
 249: exequals(lp, rp)
 250: register struct Primblock *lp;
 251: register expptr rp;
 252: {
 253: register Namep np;
 254: 
 255: if(lp->tag != TPRIM)
 256:     {
 257:     err("assignment to a non-variable");
 258:     frexpr(lp);
 259:     frexpr(rp);
 260:     }
 261: else if(lp->namep->vclass!=CLVAR && lp->argsp)
 262:     {
 263:     if(parstate >= INEXEC)
 264:         err("undimensioned array or statement function out of order");
 265:     else
 266:         mkstfunct(lp, rp);
 267:     }
 268: else
 269:     {
 270:     np = (Namep) lp->namep;
 271:     if (np->vclass == CLPROC && np->vprocclass == PTHISPROC
 272:         && proctype == TYSUBR)
 273:         {
 274:         err("assignment to a subroutine name");
 275:         return;
 276:         }
 277:     if(parstate < INDATA)
 278:         enddcl();
 279:     parstate = INEXEC;
 280:     if (optimflag)
 281:         optbuff (SKEQ, mkexpr(OPASSIGN, mklhs(lp), fixtype(rp)), 0, 0);
 282:     else
 283:         puteq (mklhs(lp), fixtype(rp));
 284:     }
 285: }
 286: 
 287: 
 288: 
 289: mkstfunct(lp, rp)
 290: struct Primblock *lp;
 291: expptr rp;
 292: {
 293: register struct Primblock *p;
 294: register Namep np;
 295: chainp args;
 296: 
 297: if(parstate < INDATA)
 298:     {
 299:     enddcl();
 300:     parstate = INDATA;
 301:     }
 302: 
 303: np = lp->namep;
 304: if(np->vclass == CLUNKNOWN)
 305:     np->vclass = CLPROC;
 306: else
 307:     {
 308:     dclerr("redeclaration of statement function", np);
 309:     return;
 310:     }
 311: np->vprocclass = PSTFUNCT;
 312: np->vstg = STGSTFUNCT;
 313: impldcl(np);
 314: args = (lp->argsp ? lp->argsp->listp : CHNULL);
 315: np->varxptr.vstfdesc = mkchain(args , rp );
 316: 
 317: for( ; args ; args = args->nextp)
 318:     if( args->datap->tag!=TPRIM ||
 319:         (p = (struct Primblock *) (args->datap) )->argsp ||
 320:         p->fcharp || p->lcharp )
 321:         err("non-variable argument in statement function definition");
 322:     else
 323:         {
 324:         args->datap = (tagptr) (p->namep);
 325:         vardcl(p->namep);
 326:         free(p);
 327:         }
 328: }
 329: 
 330: 
 331: 
 332: excall(name, args, nstars, labels)
 333: Namep name;
 334: struct Listblock *args;
 335: int nstars;
 336: struct Labelblock *labels[ ];
 337: {
 338: register expptr p;
 339: 
 340: if (name->vdcldone)
 341:     if (name->vclass != CLPROC && name->vclass != CLENTRY)
 342:         {
 343:         dclerr("call to non-subroutine", name);
 344:         return;
 345:         }
 346:     else if (name->vtype != TYSUBR)
 347:         {
 348:         dclerr("subroutine invocation of function", name);
 349:         return;
 350:         }
 351: settype(name, TYSUBR, ENULL);
 352: p = mkfunct( mkprim(name, args, CHNULL) );
 353: p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
 354: if (nstars > 0)
 355:     if (optimflag)
 356:         optbuff (SKCMGOTO, p, nstars, labels);
 357:     else
 358:         putcmgo (p, nstars, labels);
 359: else
 360:     if (optimflag)
 361:         optbuff (SKCALL, p, 0, 0);
 362:     else
 363:         putexpr (p);
 364: }
 365: 
 366: 
 367: 
 368: exstop(stop, p)
 369: int stop;
 370: register expptr p;
 371: {
 372: char *q;
 373: int n;
 374: expptr mkstrcon();
 375: 
 376: if(p)
 377:     {
 378:     if( ! ISCONST(p) )
 379:         {
 380:         execerr("pause/stop argument must be constant", CNULL);
 381:         frexpr(p);
 382:         p = mkstrcon(0, CNULL);
 383:         }
 384:     else if( ISINT(p->constblock.vtype) )
 385:         {
 386:         q = convic(p->constblock.const.ci);
 387:         n = strlen(q);
 388:         if(n > 0)
 389:             {
 390:             p->constblock.const.ccp = copyn(n, q);
 391:             p->constblock.vtype = TYCHAR;
 392:             p->constblock.vleng = (expptr) ICON(n);
 393:             }
 394:         else
 395:             p = (expptr) mkstrcon(0, CNULL);
 396:         }
 397:     else if(p->constblock.vtype != TYCHAR)
 398:         {
 399:         execerr("pause/stop argument must be integer or string", CNULL);
 400:         p = (expptr) mkstrcon(0, CNULL);
 401:         }
 402:     }
 403: else    p = (expptr) mkstrcon(0, CNULL);
 404: 
 405: if (optimflag)
 406:     optbuff ((stop ? SKSTOP : SKPAUSE), p, 0, 0);
 407: else
 408:     putexpr (call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p));
 409: }
 410: 
 411: 
 412: /* UCB DO LOOP CODE */
 413: 
 414: #define DOINIT  par[0]
 415: #define DOLIMIT par[1]
 416: #define DOINCR  par[2]
 417: 
 418: #define CONSTINIT  const[0]
 419: #define CONSTLIMIT const[1]
 420: #define CONSTINCR  const[2]
 421: 
 422: #define VARSTEP 0
 423: #define POSSTEP 1
 424: #define NEGSTEP 2
 425: 
 426: 
 427: exdo(range, spec)
 428: int range;
 429: chainp spec;
 430: 
 431: {
 432:   register expptr p, q;
 433:   expptr q1;
 434:   register Namep np;
 435:   chainp cp;
 436:   register int i;
 437:   int dotype, incsign;
 438:   Addrp dovarp, dostgp;
 439:   expptr par[3];
 440:   expptr const[3];
 441:   Slotp doslot;
 442: 
 443:   pushctl(CTLDO);
 444:   dorange = ctlstack->dolabel = range;
 445:   np = (Namep) (spec->datap);
 446:   ctlstack->donamep = NULL;
 447:   if(np->vdovar)
 448:     {
 449:       errstr("nested loops with variable %s", varstr(VL,np->varname));
 450:       return;
 451:     }
 452: 
 453:   dovarp = mkplace(np);
 454:   dotype = dovarp->vtype;
 455: 
 456:   if( ! ONEOF(dotype, MSKINT|MSKREAL) )
 457:     {
 458:       err("bad type on DO variable");
 459:       return;
 460:     }
 461: 
 462: 
 463:   for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
 464:     {
 465:       p = fixtype((expptr) cpexpr((tagptr) q = cp->datap));
 466:       if(!ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
 467:     {
 468:       err("bad type on DO parameter");
 469:       return;
 470:     }
 471: 
 472: 
 473:       if (ISCONST(q))
 474:     const[i] = mkconv(dotype, q);
 475:       else
 476:     {
 477:       frexpr(q);
 478:       const[i] = NULL;
 479:     }
 480: 
 481:       par[i++] = mkconv(dotype, p);
 482:     }
 483: 
 484:   frchain(&spec);
 485:   switch(i)
 486:     {
 487:     case 0:
 488:     case 1:
 489:       err("too few DO parameters");
 490:       return;
 491: 
 492:     case 2:
 493:       DOINCR = (expptr) ICON(1);
 494:       CONSTINCR = ICON(1);
 495: 
 496:     case 3:
 497:       break;
 498: 
 499:     default:
 500:       err("too many DO parameters");
 501:       return;
 502:     }
 503: 
 504:   ctlstack->donamep = np;
 505: 
 506:   np->vdovar = YES;
 507:   if( !optimflag && enregister(np) )
 508:     {
 509:       /* stgp points to a storage version, varp to a register version */
 510:       dostgp = dovarp;
 511:       dovarp = mkplace(np);
 512:     }
 513:   else
 514:     dostgp = NULL;
 515: 
 516:   for (i = 0; i < 4; i++)
 517:     ctlstack->ctlabels[i] = newlabel();
 518: 
 519:   if( CONSTLIMIT )
 520:     ctlstack->domax = DOLIMIT;
 521:   else
 522:     ctlstack->domax = (expptr) mktemp(dotype, PNULL);
 523: 
 524:   if( CONSTINCR )
 525:     {
 526:       ctlstack->dostep = DOINCR;
 527:       if( (incsign = conssgn(CONSTINCR)) == 0)
 528:     err("zero DO increment");
 529:       ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
 530:     }
 531:   else
 532:     {
 533:       ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
 534:       ctlstack->dostepsign = VARSTEP;
 535:     }
 536: 
 537: if (optimflag)
 538:     doslot = optbuff (SKDOHEAD,0,0,ctlstack);
 539: 
 540: if( CONSTLIMIT && CONSTINIT && ctlstack->dostepsign!=VARSTEP)
 541:     {
 542:     if (optimflag)
 543:         optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp),cpexpr(DOINIT)),
 544:             0,0);
 545:     else
 546:         puteq (cpexpr(dovarp), cpexpr(DOINIT));
 547:     if( ! onetripflag )
 548:         {
 549:         q = mkexpr(OPMINUS, cpexpr(CONSTLIMIT), cpexpr(CONSTINIT));
 550:         if((incsign * conssgn(q)) == -1)
 551:             {
 552:             warn("DO range never executed");
 553:             if (optimflag)
 554:                 optbuff (SKGOTO,0,ctlstack->endlabel,0);
 555:             else
 556:                 putgoto (ctlstack->endlabel);
 557:             }
 558:         frexpr(q);
 559:         }
 560:     }
 561: 
 562: 
 563: else if (ctlstack->dostepsign != VARSTEP && !onetripflag)
 564:     {
 565:     if (CONSTLIMIT)
 566:         q = (expptr) cpexpr(ctlstack->domax);
 567:     else
 568:         q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
 569:     q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
 570:     q = mkexpr( (ctlstack->dostepsign == POSSTEP ? OPGE : OPLE),
 571:            q, q1);
 572:     if (optimflag)
 573:         optbuff (SKIFN,q, ctlstack->endlabel,0);
 574:     else
 575:         putif (q, ctlstack->endlabel);
 576:     }
 577: else
 578:     {
 579:     if (!CONSTLIMIT)
 580:         if (optimflag)
 581:         optbuff (SKEQ,
 582:             mkexpr(OPASSIGN,cpexpr(ctlstack->domax),DOLIMIT),0,0);
 583:         else
 584:         puteq (cpexpr(ctlstack->domax), DOLIMIT);
 585:     q = DOINIT;
 586:     if (!onetripflag)
 587:         q = mkexpr(OPMINUS, q,
 588:             mkexpr(OPASSIGN, cpexpr(ctlstack->dostep),
 589:                    DOINCR) );
 590:     if (optimflag)
 591:         optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp), q),0,0);
 592:     else
 593:         puteq (cpexpr(dovarp), q);
 594:     if (onetripflag && ctlstack->dostepsign == VARSTEP)
 595:         if (optimflag)
 596:         optbuff (SKEQ,
 597:             mkexpr(OPASSIGN,cpexpr(ctlstack->dostep),DOINCR),0,0);
 598:         else
 599:         puteq (cpexpr(ctlstack->dostep), DOINCR);
 600:     }
 601: 
 602: if (ctlstack->dostepsign == VARSTEP)
 603:     {
 604:     expptr incr,test;
 605:     if (onetripflag)
 606:         if (optimflag)
 607:             optbuff (SKGOTO,0,ctlstack->dobodylabel,0);
 608:         else
 609:             putgoto (ctlstack->dobodylabel);
 610:     else
 611:         if (optimflag)
 612:         optbuff (SKIFN,mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
 613:             ctlstack->doneglabel,0);
 614:         else
 615:         putif (mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
 616:             ctlstack->doneglabel);
 617:     if (optimflag)
 618:         optbuff (SKLABEL,0,ctlstack->doposlabel,0);
 619:     else
 620:         putlabel (ctlstack->doposlabel);
 621:     incr = mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep));
 622:     test = mkexpr(OPLE, incr, cpexpr(ctlstack->domax));
 623:     if (optimflag)
 624:         optbuff (SKIFN,test, ctlstack->endlabel,0);
 625:     else
 626:         putif (test, ctlstack->endlabel);
 627:     }
 628: 
 629: if (optimflag)
 630:     optbuff (SKLABEL,0,ctlstack->dobodylabel,0);
 631: else
 632:     putlabel (ctlstack->dobodylabel);
 633: if (dostgp)
 634:     {
 635:     if (optimflag)
 636:         optbuff (SKEQ,mkexpr(OPASSIGN,dostgp, dovarp),0,0);
 637:     else
 638:         puteq (dostgp, dovarp);
 639:     }
 640: else
 641:     frexpr(dovarp);
 642: if (optimflag)
 643:     doslot->nullslot = optbuff (SKNULL,0,0,0);
 644: 
 645: frexpr(CONSTINIT);
 646: frexpr(CONSTLIMIT);
 647: frexpr(CONSTINCR);
 648: }
 649: 
 650: 
 651: enddo(here)
 652: int here;
 653: 
 654: {
 655:   register struct Ctlframe *q;
 656:   Namep np;
 657:   Addrp ap, rv;
 658:   expptr t;
 659:   register int i;
 660:   Slotp doslot;
 661: 
 662:   while (here == dorange)
 663:     {
 664:       while (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLELSE)
 665:     {
 666:       execerr("missing endif", CNULL);
 667:       exendif();
 668:     }
 669: 
 670:       if (np = ctlstack->donamep)
 671:     {
 672:     rv = mkplace (np);
 673: 
 674:     t = mkexpr(OPPLUSEQ, cpexpr(rv), cpexpr(ctlstack->dostep) );
 675: 
 676:     if (optimflag)
 677:         doslot = optbuff (SKENDDO,0,0,ctlstack);
 678: 
 679:     if (ctlstack->dostepsign == VARSTEP)
 680:         if (optimflag)
 681:             {
 682:             optbuff (SKIFN,
 683:                 mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
 684:                 ctlstack->doposlabel,0);
 685:             optbuff (SKLABEL,0,ctlstack->doneglabel,0);
 686:             optbuff (SKIFN,mkexpr(OPLT, t, ctlstack->domax),
 687:                 ctlstack->dobodylabel,0);
 688:             }
 689:         else
 690:             {
 691:             putif (mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
 692:                 ctlstack->doposlabel);
 693:             putlabel (ctlstack->doneglabel);
 694:             putif (mkexpr(OPLT, t, ctlstack->domax),
 695:                 ctlstack->dobodylabel);
 696:             }
 697:     else
 698:         {
 699:         int op;
 700:         op = (ctlstack->dostepsign == POSSTEP ? OPGT : OPLT);
 701:         if (optimflag)
 702:             optbuff (SKIFN, mkexpr(op,t,ctlstack->domax),
 703:                 ctlstack->dobodylabel,0);
 704:         else
 705:             putif (mkexpr(op, t, ctlstack->domax),
 706:                 ctlstack->dobodylabel);
 707:         }
 708:     if (optimflag)
 709:         optbuff (SKLABEL,0,ctlstack->endlabel,0);
 710:     else
 711:         putlabel (ctlstack->endlabel);
 712: 
 713:     if (ap = memversion(np))
 714:         {
 715:         if (optimflag)
 716:             optbuff (SKEQ,mkexpr(OPASSIGN,ap, rv),0,0);
 717:         else
 718:             puteq (ap, rv);
 719:         }
 720:     else
 721:         frexpr(rv);
 722:     for (i = 0; i < 4; i++)
 723:         ctlstack->ctlabels[i] = 0;
 724:     if (!optimflag)
 725:         deregister(ctlstack->donamep);
 726:     ctlstack->donamep->vdovar = NO;
 727:     if (optimflag)
 728:         doslot->nullslot = optbuff (SKNULL,0,0,0);
 729:     }
 730: 
 731:       popctl();
 732:       poplab();
 733: 
 734:       dorange = 0;
 735:       for (q = ctlstack; q >= ctls; --q)
 736:     if (q->ctltype == CTLDO)
 737:       {
 738:         dorange = q->dolabel;
 739:         break;
 740:       }
 741:     }
 742: }
 743: 
 744: 
 745: exassign(vname, labelval)
 746: Namep vname;
 747: struct Labelblock *labelval;
 748: {
 749: Addrp p;
 750: expptr mkaddcon();
 751: 
 752: p = mkplace(vname);
 753: #if SZADDR > SZSHORT
 754: if( p->vtype == TYSHORT )
 755:     err("insufficient precision in ASSIGN variable");
 756: else
 757: #endif
 758: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
 759:     err("noninteger assign variable");
 760: else
 761:     {
 762:     if (optimflag)
 763:         optbuff (SKASSIGN, p, labelval->labelno, 0);
 764:     else
 765:         puteq (p, intrconv(p->vtype, mkaddcon(labelval->labelno)));
 766:     }
 767: }
 768: 
 769: 
 770: 
 771: exarif(expr, neglab, zerlab, poslab)
 772: expptr expr;
 773: struct Labelblock *neglab, *zerlab, *poslab;
 774: {
 775: register int lm, lz, lp;
 776: struct Labelblock *labels[3];
 777: 
 778: lm = neglab->labelno;
 779: lz = zerlab->labelno;
 780: lp = poslab->labelno;
 781: expr = fixtype(expr);
 782: 
 783: if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
 784:     {
 785:     err("invalid type of arithmetic if expression");
 786:     frexpr(expr);
 787:     }
 788: else
 789:     {
 790:     if(lm == lz)
 791:         exar2(OPLE, expr, lm, lp);
 792:     else if(lm == lp)
 793:         exar2(OPNE, expr, lm, lz);
 794:     else if(lz == lp)
 795:         exar2(OPGE, expr, lz, lm);
 796:     else
 797:         if (optimflag)
 798:             {
 799:             labels[0] = neglab;
 800:             labels[1] = zerlab;
 801:             labels[2] = poslab;
 802:             optbuff (SKARIF, expr, 0, labels);
 803:             }
 804:         else
 805:             prarif(expr, lm, lz, lp);
 806:     }
 807: }
 808: 
 809: 
 810: 
 811: LOCAL exar2 (op, e, l1, l2)
 812: int op;
 813: expptr  e;
 814: int l1,l2;
 815: {
 816: if (optimflag)
 817:     {
 818:     optbuff (SKIFN, mkexpr(op, e, ICON(0)), l2, 0);
 819:     optbuff (SKGOTO, 0, l1, 0);
 820:     }
 821: else
 822:     {
 823:     putif (mkexpr(op, e, ICON(0)), l2);
 824:     putgoto (l1);
 825:     }
 826: }
 827: 
 828: 
 829: exreturn(p)
 830: register expptr p;
 831: {
 832: if(procclass != CLPROC)
 833:     warn("RETURN statement in main or block data");
 834: if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
 835:     {
 836:     err("alternate return in nonsubroutine");
 837:     p = 0;
 838:     }
 839: 
 840: if(p)
 841:     if (optimflag)
 842:         optbuff (SKRETURN, p, retlabel, 0);
 843:     else
 844:         {
 845:         putforce (TYINT, p);
 846:         putgoto (retlabel);
 847:         }
 848: else
 849:     if (optimflag)
 850:         optbuff (SKRETURN, p,
 851:              (proctype==TYSUBR ? ret0label : retlabel), 0);
 852:     else
 853:         putgoto (proctype==TYSUBR ? ret0label : retlabel);
 854: }
 855: 
 856: 
 857: 
 858: exasgoto(labvar)
 859: struct Hashentry *labvar;
 860: {
 861: register Addrp p;
 862: 
 863: p = mkplace(labvar);
 864: if( ! ISINT(p->vtype) )
 865:     err("assigned goto variable must be integer");
 866: else
 867:     if (optimflag)
 868:         optbuff (SKASGOTO, p, 0, 0);
 869:     else
 870:         putbranch (p);
 871: }

Defined functions

Defined variables

Defined macros