Annotation of researchv10no/cmd/f2c/exec.c, revision 1.1.1.1

1.1       root        1: /****************************************************************
                      2: Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore.
                      3: 
                      4: Permission to use, copy, modify, and distribute this software
                      5: and its documentation for any purpose and without fee is hereby
                      6: granted, provided that the above copyright notice appear in all
                      7: copies and that both that the copyright notice and this
                      8: permission notice and warranty disclaimer appear in supporting
                      9: documentation, and that the names of AT&T Bell Laboratories or
                     10: Bellcore or any of their entities not be used in advertising or
                     11: publicity pertaining to distribution of the software without
                     12: specific, written prior permission.
                     13: 
                     14: AT&T and Bellcore disclaim all warranties with regard to this
                     15: software, including all implied warranties of merchantability
                     16: and fitness.  In no event shall AT&T or Bellcore be liable for
                     17: any special, indirect or consequential damages or any damages
                     18: whatsoever resulting from loss of use, data or profits, whether
                     19: in an action of contract, negligence or other tortious action,
                     20: arising out of or in connection with the use or performance of
                     21: this software.
                     22: ****************************************************************/
                     23: 
                     24: #include "defs.h"
                     25: #include "p1defs.h"
                     26: #include "names.h"
                     27: 
                     28: LOCAL void exar2(), popctl(), pushctl();
                     29: 
                     30: /*   Logical IF codes
                     31: */
                     32: 
                     33: 
                     34: exif(p)
                     35: expptr p;
                     36: {
                     37:     pushctl(CTLIF);
                     38:     putif(p, 0);       /* 0 => if, not elseif */
                     39: }
                     40: 
                     41: 
                     42: 
                     43: exelif(p)
                     44: expptr p;
                     45: {
                     46:     if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
                     47:        putif(p, 1);    /* 1 ==> elseif */
                     48:     else
                     49:        execerr("elseif out of place", CNULL);
                     50: }
                     51: 
                     52: 
                     53: 
                     54: 
                     55: 
                     56: exelse()
                     57: {
                     58:        register struct Ctlframe *c;
                     59: 
                     60:        for(c = ctlstack; c->ctltype == CTLIFX; --c);
                     61:        if(c->ctltype == CTLIF) {
                     62:                p1_else ();
                     63:                c->ctltype = CTLELSE;
                     64:                }
                     65:        else
                     66:                execerr("else out of place", CNULL);
                     67:        }
                     68: 
                     69: 
                     70: exendif()
                     71: {
                     72:        while(ctlstack->ctltype == CTLIFX) {
                     73:                popctl();
                     74:                p1else_end();
                     75:                }
                     76:        if(ctlstack->ctltype == CTLIF) {
                     77:                popctl();
                     78:                p1_endif ();
                     79:                }
                     80:        else if(ctlstack->ctltype == CTLELSE) {
                     81:                popctl();
                     82:                p1else_end ();
                     83:                }
                     84:        else
                     85:                execerr("endif out of place", CNULL);
                     86:        }
                     87: 
                     88: 
                     89: new_endif()
                     90: {
                     91:        if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
                     92:                pushctl(CTLIFX);
                     93:        else
                     94:                err("new_endif bug");
                     95:        }
                     96: 
                     97: /* pushctl -- Start a new control construct, initialize the labels (to
                     98:    zero) */
                     99: 
                    100:  LOCAL void
                    101: pushctl(code)
                    102:  int code;
                    103: {
                    104:        register int i;
                    105: 
                    106:        if(++ctlstack >= lastctl)
                    107:                many("loops or if-then-elses", 'c', maxctl);
                    108:        ctlstack->ctltype = code;
                    109:        for(i = 0 ; i < 4 ; ++i)
                    110:                ctlstack->ctlabels[i] = 0;
                    111:        ctlstack->dowhile = 0;
                    112:        ++blklevel;
                    113: }
                    114: 
                    115: 
                    116:  LOCAL void
                    117: popctl()
                    118: {
                    119:        if( ctlstack-- < ctls )
                    120:                Fatal("control stack empty");
                    121:        --blklevel;
                    122: }
                    123: 
                    124: 
                    125: 
                    126: /* poplab -- update the flags in   labeltab   */
                    127: 
                    128: LOCAL poplab()
                    129: {
                    130:        register struct Labelblock  *lp;
                    131: 
                    132:        for(lp = labeltab ; lp < highlabtab ; ++lp)
                    133:                if(lp->labdefined)
                    134:                {
                    135:                        /* mark all labels in inner blocks unreachable */
                    136:                        if(lp->blklevel > blklevel)
                    137:                                lp->labinacc = YES;
                    138:                }
                    139:                else if(lp->blklevel > blklevel)
                    140:                {
                    141:                        /* move all labels referred to in inner blocks out a level */
                    142:                        lp->blklevel = blklevel;
                    143:                }
                    144: }
                    145: 
                    146: 
                    147: /*  BRANCHING CODE
                    148: */
                    149: 
                    150: exgoto(lab)
                    151: struct Labelblock *lab;
                    152: {
                    153:        lab->labused = 1;
                    154:        p1_goto (lab -> stateno);
                    155: }
                    156: 
                    157: 
                    158: 
                    159: 
                    160: 
                    161: 
                    162: 
                    163: exequals(lp, rp)
                    164: register struct Primblock *lp;
                    165: register expptr rp;
                    166: {
                    167:        if(lp->tag != TPRIM)
                    168:        {
                    169:                err("assignment to a non-variable");
                    170:                frexpr((expptr)lp);
                    171:                frexpr(rp);
                    172:        }
                    173:        else if(lp->namep->vclass!=CLVAR && lp->argsp)
                    174:        {
                    175:                if(parstate >= INEXEC)
                    176:                        err("statement function amid executables");
                    177:                mkstfunct(lp, rp);
                    178:        }
                    179:        else
                    180:        {
                    181:                expptr new_lp, new_rp;
                    182: 
                    183:                if(parstate < INDATA)
                    184:                        enddcl();
                    185:                new_lp = mklhs (lp, keepsubs);
                    186:                new_rp = fixtype (rp);
                    187:                puteq(new_lp, new_rp);
                    188:        }
                    189: }
                    190: 
                    191: 
                    192: 
                    193: /* Make Statement Function */
                    194: 
                    195: long laststfcn = -1, thisstno;
                    196: int doing_stmtfcn;
                    197: 
                    198: mkstfunct(lp, rp)
                    199: struct Primblock *lp;
                    200: expptr rp;
                    201: {
                    202:        register struct Primblock *p;
                    203:        register Namep np;
                    204:        chainp args;
                    205: 
                    206:        laststfcn = thisstno;
                    207:        np = lp->namep;
                    208:        if(np->vclass == CLUNKNOWN)
                    209:                np->vclass = CLPROC;
                    210:        else
                    211:        {
                    212:                dclerr("redeclaration of statement function", np);
                    213:                return;
                    214:        }
                    215:        np->vprocclass = PSTFUNCT;
                    216:        np->vstg = STGSTFUNCT;
                    217: 
                    218: /* Set the type of the function */
                    219: 
                    220:        impldcl(np);
                    221:        if (np->vtype == TYCHAR && !np->vleng)
                    222:                err("character statement function with length (*)");
                    223:        args = (lp->argsp ? lp->argsp->listp : CHNULL);
                    224:        np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
                    225: 
                    226:        for(doing_stmtfcn = 1 ; args ; args = args->nextp)
                    227: 
                    228: /* It is an error for the formal parameters to have arguments or
                    229:    subscripts */
                    230: 
                    231:                if( ((tagptr)(args->datap))->tag!=TPRIM ||
                    232:                    (p = (struct Primblock *)(args->datap) )->argsp ||
                    233:                    p->fcharp || p->lcharp )
                    234:                        err("non-variable argument in statement function definition");
                    235:                else
                    236:                {
                    237: 
                    238: /* Replace the name on the left-hand side */
                    239: 
                    240:                        args->datap = (char *)p->namep;
                    241:                        vardcl(p -> namep);
                    242:                        free((char *)p);
                    243:                }
                    244:        doing_stmtfcn = 0;
                    245: }
                    246: 
                    247:  static void
                    248: mixed_type(np)
                    249:  Namep np;
                    250: {
                    251:        char buf[128];
                    252:        sprintf(buf, "%s function %.90s invoked as subroutine",
                    253:                ftn_types[np->vtype], np->fvarname);
                    254:        warn(buf);
                    255:        }
                    256: 
                    257: 
                    258: excall(name, args, nstars, labels)
                    259: Namep name;
                    260: struct Listblock *args;
                    261: int nstars;
                    262: struct Labelblock *labels[ ];
                    263: {
                    264:        register expptr p;
                    265: 
                    266:        if (name->vtype != TYSUBR) {
                    267:                if (name->vinfproc && !name->vcalled) {
                    268:                        name->vtype = TYSUBR;
                    269:                        frexpr(name->vleng);
                    270:                        name->vleng = 0;
                    271:                        }
                    272:                else if (!name->vimpltype && name->vtype != TYUNKNOWN)
                    273:                        mixed_type(name);
                    274:                else
                    275:                        settype(name, TYSUBR, (ftnint)0);
                    276:                }
                    277:        p = mkfunct( mkprim(name, args, CHNULL) );
                    278: 
                    279: /* Subroutines and their identifiers acquire the type INT */
                    280: 
                    281:        p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
                    282: 
                    283: /* Handle the alternate return mechanism */
                    284: 
                    285:        if(nstars > 0)
                    286:                putcmgo(putx(fixtype(p)), nstars, labels);
                    287:        else
                    288:                putexpr(p);
                    289: }
                    290: 
                    291: 
                    292: 
                    293: exstop(stop, p)
                    294: int stop;
                    295: register expptr p;
                    296: {
                    297:        char *str;
                    298:        int n;
                    299:        expptr mkstrcon();
                    300: 
                    301:        if(p)
                    302:        {
                    303:                if( ! ISCONST(p) )
                    304:                {
                    305:                        execerr("pause/stop argument must be constant", CNULL);
                    306:                        frexpr(p);
                    307:                        p = mkstrcon(0, CNULL);
                    308:                }
                    309:                else if( ISINT(p->constblock.vtype) )
                    310:                {
                    311:                        str = convic(p->constblock.Const.ci);
                    312:                        n = strlen(str);
                    313:                        if(n > 0)
                    314:                        {
                    315:                                p->constblock.Const.ccp = copyn(n, str);
                    316:                                p->constblock.Const.ccp1.blanks = 0;
                    317:                                p->constblock.vtype = TYCHAR;
                    318:                                p->constblock.vleng = (expptr) ICON(n);
                    319:                        }
                    320:                        else
                    321:                                p = (expptr) mkstrcon(0, CNULL);
                    322:                }
                    323:                else if(p->constblock.vtype != TYCHAR)
                    324:                {
                    325:                        execerr("pause/stop argument must be integer or string", CNULL);
                    326:                        p = (expptr) mkstrcon(0, CNULL);
                    327:                }
                    328:        }
                    329:        else    p = (expptr) mkstrcon(0, CNULL);
                    330: 
                    331:     {
                    332:        expptr subr_call;
                    333: 
                    334:        subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
                    335:        putexpr( subr_call );
                    336:     }
                    337: }
                    338: 
                    339: /* DO LOOP CODE */
                    340: 
                    341: #define DOINIT par[0]
                    342: #define DOLIMIT        par[1]
                    343: #define DOINCR par[2]
                    344: 
                    345: 
                    346: /* Macros for   ctlstack -> dostepsign   */
                    347: 
                    348: #define VARSTEP        0
                    349: #define POSSTEP        1
                    350: #define NEGSTEP        2
                    351: 
                    352: 
                    353: /* exdo -- generate DO loop code.  In the case of a variable increment,
                    354:    positive increment tests are placed above the body, negative increment
                    355:    tests are placed below (see   enddo()   ) */
                    356: 
                    357: exdo(range, loopname, spec)
                    358: int range;                     /* end label */
                    359: Namep loopname;
                    360: chainp spec;                   /* input spec must have at least 2 exprs */
                    361: {
                    362:        register expptr p;
                    363:        register Namep np;
                    364:        chainp cp;              /* loops over the fields in   spec */
                    365:        register int i;
                    366:        int dotype;             /* type of the index variable */
                    367:        int incsign;            /* sign of the increment, if it's constant
                    368:                                   */
                    369:        Addrp dovarp;           /* loop index variable */
                    370:        expptr doinit;          /* constant or register for init param */
                    371:        expptr par[3];          /* local specification parameters */
                    372: 
                    373:        expptr init, test, inc; /* Expressions in the resulting FOR loop */
                    374: 
                    375: 
                    376:        test = ENULL;
                    377: 
                    378:        pushctl(CTLDO);
                    379:        dorange = ctlstack->dolabel = range;
                    380:        ctlstack->loopname = loopname;
                    381: 
                    382: /* Declare the loop index */
                    383: 
                    384:        np = (Namep)spec->datap;
                    385:        ctlstack->donamep = NULL;
                    386:        if (!np) { /* do while */
                    387:                ctlstack->dowhile = 1;
                    388: #if 0
                    389:                if (loopname) {
                    390:                        if (loopname->vtype == TYUNKNOWN) {
                    391:                                loopname->vdcldone = 1;
                    392:                                loopname->vclass = CLLABEL;
                    393:                                loopname->vprocclass = PLABEL;
                    394:                                loopname->vtype = TYLABEL;
                    395:                                }
                    396:                        if (loopname->vtype == TYLABEL)
                    397:                                if (loopname->vdovar)
                    398:                                        dclerr("already in use as a loop name",
                    399:                                                loopname);
                    400:                                else
                    401:                                        loopname->vdovar = 1;
                    402:                        else
                    403:                                dclerr("already declared; cannot be a loop name",
                    404:                                        loopname);
                    405:                        }
                    406: #endif
                    407:                putwhile((expptr)spec->nextp);
                    408:                NOEXT("do while");
                    409:                spec->nextp = 0;
                    410:                frchain(&spec);
                    411:                return;
                    412:                }
                    413:        if(np->vdovar)
                    414:        {
                    415:                errstr("nested loops with variable %s", np->fvarname);
                    416:                ctlstack->donamep = NULL;
                    417:                return;
                    418:        }
                    419: 
                    420: /* Create a memory-resident version of the index variable */
                    421: 
                    422:        dovarp = mkplace(np);
                    423:        if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
                    424:        {
                    425:                err("bad type on do variable");
                    426:                return;
                    427:        }
                    428:        ctlstack->donamep = np;
                    429: 
                    430:        np->vdovar = YES;
                    431: 
                    432: /* Now   dovarp   points to the index to be used within the loop,   dostgp
                    433:    points to the one which may need to be stored */
                    434: 
                    435:        dotype = dovarp->vtype;
                    436: 
                    437: /* Count the input specifications and type-check each one independently;
                    438:    this just eliminates non-numeric values from the specification */
                    439: 
                    440:        for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
                    441:        {
                    442:                p = par[i++] = fixtype((tagptr)cp->datap);
                    443:                if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
                    444:                {
                    445:                        err("bad type on DO parameter");
                    446:                        return;
                    447:                }
                    448:        }
                    449: 
                    450:        frchain(&spec);
                    451:        switch(i)
                    452:        {
                    453:        case 0:
                    454:        case 1:
                    455:                err("too few DO parameters");
                    456:                return;
                    457: 
                    458:        default:
                    459:                err("too many DO parameters");
                    460:                return;
                    461: 
                    462:        case 2:
                    463:                DOINCR = (expptr) ICON(1);
                    464: 
                    465:        case 3:
                    466:                break;
                    467:        }
                    468: 
                    469: 
                    470: /* Now all of the local specification fields are set, but their types are
                    471:    not yet consistent */
                    472: 
                    473: /* Declare the loop initialization value, casting it properly and declaring a
                    474:    register if need be */
                    475: 
                    476:        if (ISCONST (DOINIT) || !onetripflag)
                    477: /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
                    478:    since mkconv is called just before */
                    479:                doinit = putx (mkconv (dotype, DOINIT));
                    480:        else {
                    481:            doinit = (expptr) mktmp(dotype, ENULL);
                    482:            puteq (cpexpr (doinit), DOINIT);
                    483:        } /* else */
                    484: 
                    485: /* Declare the loop ending value, casting it to the type of the index
                    486:    variable */
                    487: 
                    488:        if( ISCONST(DOLIMIT) )
                    489:                ctlstack->domax = mkconv(dotype, DOLIMIT);
                    490:        else {
                    491:                ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
                    492:                puteq (cpexpr (ctlstack -> domax), DOLIMIT);
                    493:        } /* else */
                    494: 
                    495: /* Declare the loop increment value, casting it to the type of the index
                    496:    variable */
                    497: 
                    498:        if( ISCONST(DOINCR) )
                    499:        {
                    500:                ctlstack->dostep = mkconv(dotype, DOINCR);
                    501:                if( (incsign = conssgn(ctlstack->dostep)) == 0)
                    502:                        err("zero DO increment");
                    503:                ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
                    504:        }
                    505:        else
                    506:        {
                    507:                ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
                    508:                ctlstack->dostepsign = VARSTEP;
                    509:                puteq (cpexpr (ctlstack -> dostep), DOINCR);
                    510:        }
                    511: 
                    512: /* All data is now properly typed and in the   ctlstack,   except for the
                    513:    initial value.  Assignments of temps have been generated already */
                    514: 
                    515:        switch (ctlstack -> dostepsign) {
                    516:            case VARSTEP:
                    517:                test = mkexpr (OPQUEST, mkexpr (OPLT,
                    518:                        cpexpr (ctlstack -> dostep), ICON(0)),
                    519:                        mkexpr (OPCOLON,
                    520:                            mkexpr (OPGE, cpexpr((expptr)dovarp),
                    521:                                    cpexpr (ctlstack -> domax)),
                    522:                            mkexpr (OPLE, cpexpr((expptr)dovarp),
                    523:                                    cpexpr (ctlstack -> domax))));
                    524:                break;
                    525:            case POSSTEP:
                    526:                test = mkexpr (OPLE, cpexpr((expptr)dovarp),
                    527:                        cpexpr (ctlstack -> domax));
                    528:                break;
                    529:            case NEGSTEP:
                    530:                test = mkexpr (OPGE, cpexpr((expptr)dovarp),
                    531:                        cpexpr (ctlstack -> domax));
                    532:                break;
                    533:            default:
                    534:                erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
                    535:                break;
                    536:        } /* switch (ctlstack -> dostepsign) */
                    537: 
                    538:        if (onetripflag)
                    539:            test = mkexpr (OPOR, test,
                    540:                    mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
                    541:        init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
                    542:        inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
                    543: 
                    544:        if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
                    545:                && ctlstack -> dostepsign != VARSTEP) {
                    546:            expptr tester;
                    547: 
                    548:            tester = mkexpr (OPMINUS, cpexpr (doinit),
                    549:                    cpexpr (ctlstack -> domax));
                    550:            if (incsign == conssgn (tester))
                    551:                warn ("DO range never executed");
                    552:            frexpr (tester);
                    553:        } /* if !onetripflag && */
                    554: 
                    555:        p1_for (init, test, inc);
                    556: }
                    557: 
                    558: exenddo(np)
                    559:  Namep np;
                    560: {
                    561:        Namep np1;
                    562:        int here;
                    563:        struct Ctlframe *cf;
                    564: 
                    565:        if( ctlstack < ctls )
                    566:                Fatal("control stack empty");
                    567:        here = ctlstack->dolabel;
                    568:        if (ctlstack->ctltype != CTLDO
                    569:        || here >= 0 && (!thislabel || thislabel->labelno != here)) {
                    570:                err("misplaced ENDDO");
                    571:                return;
                    572:                }
                    573:        if (np != ctlstack->loopname) {
                    574:                if (np1 = ctlstack->loopname)
                    575:                        errstr("expected \"enddo %s\"", np1->fvarname);
                    576:                else
                    577:                        err("expected unnamed ENDDO");
                    578:                for(cf = ctls; cf < ctlstack; cf++)
                    579:                        if (cf->ctltype == CTLDO && cf->loopname == np) {
                    580:                                here = cf->dolabel;
                    581:                                break;
                    582:                                }
                    583:                }
                    584:        enddo(here);
                    585:        }
                    586: 
                    587: 
                    588: enddo(here)
                    589: int here;
                    590: {
                    591:        register struct Ctlframe *q;
                    592:        Namep np;                       /* name of the current DO index */
                    593:        Addrp ap;
                    594:        register int i;
                    595:        register expptr e;
                    596: 
                    597: /* Many DO's can end at the same statement, so keep looping over all
                    598:    nested indicies */
                    599: 
                    600:        while(here == dorange)
                    601:        {
                    602:                if(np = ctlstack->donamep)
                    603:                        {
                    604:                        p1for_end ();
                    605: 
                    606: /* Now we're done with all of the tests, and the loop has terminated.
                    607:    Store the index value back in long-term memory */
                    608: 
                    609:                        if(ap = memversion(np))
                    610:                                puteq((expptr)ap, (expptr)mkplace(np));
                    611:                        for(i = 0 ; i < 4 ; ++i)
                    612:                                ctlstack->ctlabels[i] = 0;
                    613:                        deregister(ctlstack->donamep);
                    614:                        ctlstack->donamep->vdovar = NO;
                    615:                        e = ctlstack->dostep;
                    616:                        if (e->tag == TADDR && e->addrblock.istemp)
                    617:                                frtemp((Addrp)e);
                    618:                        else
                    619:                                frexpr(e);
                    620:                        e = ctlstack->domax;
                    621:                        if (e->tag == TADDR && e->addrblock.istemp)
                    622:                                frtemp((Addrp)e);
                    623:                        else
                    624:                                frexpr(e);
                    625:                        }
                    626:                else if (ctlstack->dowhile)
                    627:                        p1for_end ();
                    628: 
                    629: /* Set   dorange   to the closing label of the next most enclosing DO loop
                    630:    */
                    631: 
                    632:                popctl();
                    633:                poplab();
                    634:                dorange = 0;
                    635:                for(q = ctlstack ; q>=ctls ; --q)
                    636:                        if(q->ctltype == CTLDO)
                    637:                        {
                    638:                                dorange = q->dolabel;
                    639:                                break;
                    640:                        }
                    641:        }
                    642: }
                    643: 
                    644: exassign(vname, labelval)
                    645:  register Namep vname;
                    646: struct Labelblock *labelval;
                    647: {
                    648:        Addrp p;
                    649:        expptr mkaddcon();
                    650:        register Addrp q;
                    651:        char *fs;
                    652:        register chainp cp, cpprev;
                    653:        register ftnint k, stno;
                    654: 
                    655:        p = mkplace(vname);
                    656:        if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
                    657:                err("noninteger assign variable");
                    658:                return;
                    659:                }
                    660: 
                    661:        /* If the label hasn't been defined, then we do things twice:
                    662:         * once for an executable stmt label, once for a format
                    663:         */
                    664: 
                    665:        /* code for executable label... */
                    666: 
                    667: /* Now store the assigned value in a list associated with this variable.
                    668:    This will be used later to generate a switch() statement in the C output */
                    669: 
                    670:        fs = labelval->fmtstring;
                    671:        if (!labelval->labdefined || !fs) {
                    672: 
                    673:                if (vname -> vis_assigned == 0) {
                    674:                        vname -> varxptr.assigned_values = CHNULL;
                    675:                        vname -> vis_assigned = 1;
                    676:                        }
                    677: 
                    678:                /* don't duplicate labels... */
                    679: 
                    680:                stno = labelval->stateno;
                    681:                cpprev = 0;
                    682:                for(k = 0, cp = vname->varxptr.assigned_values;
                    683:                                cp; cpprev = cp, cp = cp->nextp, k++)
                    684:                        if ((ftnint)cp->datap == stno)
                    685:                                break;
                    686:                if (!cp) {
                    687:                        cp = mkchain((char *)stno, CHNULL);
                    688:                        if (cpprev)
                    689:                                cpprev->nextp = cp;
                    690:                        else
                    691:                                vname->varxptr.assigned_values = cp;
                    692:                        labelval->labused = 1;
                    693:                        }
                    694:                putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
                    695:                }
                    696: 
                    697:        /* Code for FORMAT label... */
                    698: 
                    699:        if (!labelval->labdefined || fs) {
                    700:                extern void fmtname();
                    701: 
                    702:                labelval->fmtlabused = 1;
                    703:                p = ALLOC(Addrblock);
                    704:                p->tag = TADDR;
                    705:                p->vtype = TYCHAR;
                    706:                p->vstg = STGAUTO;
                    707:                p->memoffset = ICON(0);
                    708:                fmtname(vname, p);
                    709:                q = ALLOC(Addrblock);
                    710:                q->tag = TADDR;
                    711:                q->vtype = TYCHAR;
                    712:                q->vstg = STGAUTO;
                    713:                q->ntempelt = 1;
                    714:                q->memoffset = ICON(0);
                    715:                q->uname_tag = UNAM_IDENT;
                    716:                sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
                    717:                putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
                    718:                }
                    719: 
                    720: } /* exassign */
                    721: 
                    722: 
                    723: 
                    724: exarif(expr, neglab, zerlab, poslab)
                    725: expptr expr;
                    726: struct Labelblock *neglab, *zerlab, *poslab;
                    727: {
                    728:     register int lm, lz, lp;
                    729: 
                    730:     lm = neglab->stateno;
                    731:     lz = zerlab->stateno;
                    732:     lp = poslab->stateno;
                    733:     expr = fixtype(expr);
                    734: 
                    735:     if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
                    736:     {
                    737:         err("invalid type of arithmetic if expression");
                    738:         frexpr(expr);
                    739:     }
                    740:     else
                    741:     {
                    742:         if (lm == lz && lz == lp)
                    743:             exgoto (neglab);
                    744:         else if(lm == lz)
                    745:             exar2(OPLE, expr, neglab, poslab);
                    746:         else if(lm == lp)
                    747:             exar2(OPNE, expr, neglab, zerlab);
                    748:         else if(lz == lp)
                    749:             exar2(OPGE, expr, zerlab, neglab);
                    750:         else {
                    751:             expptr t;
                    752: 
                    753:            if (!addressable (expr)) {
                    754:                t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
                    755:                expr = mkexpr (OPASSIGN, cpexpr (t), expr);
                    756:            } else
                    757:                t = (expptr) cpexpr (expr);
                    758: 
                    759:            p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
                    760:            exgoto(neglab);
                    761:            p1_elif (mkexpr (OPEQ, t, ICON (0)));
                    762:            exgoto(zerlab);
                    763:            p1_else ();
                    764:            exgoto(poslab);
                    765:            p1else_end ();
                    766:         } /* else */
                    767:     }
                    768: }
                    769: 
                    770: 
                    771: 
                    772: /* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
                    773:    goto l2 else goto l1.  If this seems backwards, that's because it is,
                    774:    in order to make the 1 pass algorithm work. */
                    775: 
                    776:  LOCAL void
                    777: exar2(op, e, l1, l2)
                    778:  int op;
                    779:  expptr e;
                    780:  struct Labelblock *l1, *l2;
                    781: {
                    782:        expptr comp;
                    783: 
                    784:        comp = mkexpr (op, e, ICON (0));
                    785:        p1_if(putx(fixtype(comp)));
                    786:        exgoto(l1);
                    787:        p1_else ();
                    788:        exgoto(l2);
                    789:        p1else_end ();
                    790: }
                    791: 
                    792: 
                    793: /* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
                    794:    implement the alternate return mechanism */
                    795: 
                    796: exreturn(p)
                    797: register expptr p;
                    798: {
                    799:        if(procclass != CLPROC)
                    800:                warn("RETURN statement in main or block data");
                    801:        if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
                    802:        {
                    803:                err("alternate return in nonsubroutine");
                    804:                p = 0;
                    805:        }
                    806: 
                    807:        if (p || proctype == TYSUBR) {
                    808:                if (p == ENULL) p = ICON (0);
                    809:                p = mkconv (TYLONG, fixtype (p));
                    810:                p1_subr_ret (p);
                    811:        } /* if p || proctype == TYSUBR */
                    812:        else
                    813:            p1_subr_ret((expptr)retslot);
                    814: }
                    815: 
                    816: 
                    817: exasgoto(labvar)
                    818: Namep labvar;
                    819: {
                    820:        register Addrp p;
                    821:        void p1_asgoto();
                    822: 
                    823:        p = mkplace(labvar);
                    824:        if( ! ISINT(p->vtype) )
                    825:                err("assigned goto variable must be integer");
                    826:        else {
                    827:                p1_asgoto (p);
                    828:        } /* else */
                    829: }

unix.superglobalmegacorp.com

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