Return to exec.c CVS log

Up to [Research Unix] / researchv10no / cmd / f77

Annotation of researchv10no/cmd/f77/exec.c, revision 1.1

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

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