Return to exec.c CVS log

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

Annotation of 43BSD/usr.bin/f77/src/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.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: }

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