Return to exec.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / f77.tahoe / f77pass1

Annotation of 43BSDTahoe/usr.bin/f77/f77.tahoe/f77pass1/exec.c, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.