Return to expr.c CVS log

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

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

1.1     ! root        1: #include "defs"
        !             2: 
        !             3: LOCAL expptr fold(), mkpower(), stfcall();
        !             4: LOCAL letter(), conspower(), consbinop(), zdiv();
        !             5: 
        !             6: /* little routines to create constant blocks */
        !             7: 
        !             8: Constp mkconst(t)
        !             9: register int t;
        !            10: {
        !            11:        register Constp p;
        !            12: 
        !            13:        p = ALLOC(Constblock);
        !            14:        p->tag = TCONST;
        !            15:        p->vtype = t;
        !            16:        return(p);
        !            17: }
        !            18: 
        !            19: 
        !            20: expptr mklogcon(l)
        !            21: register int l;
        !            22: {
        !            23:        register Constp  p;
        !            24: 
        !            25:        p = mkconst(TYLOGICAL);
        !            26:        p->Const.ci = l;
        !            27:        return( (expptr) p );
        !            28: }
        !            29: 
        !            30: 
        !            31: 
        !            32: expptr mkintcon(l)
        !            33: ftnint l;
        !            34: {
        !            35:        register Constp p;
        !            36: 
        !            37:        p = mkconst(TYLONG);
        !            38:        p->Const.ci = l;
        !            39: #ifdef MAXSHORT
        !            40:        if(l >= -MAXSHORT   &&   l <= MAXSHORT)
        !            41:                p->vtype = TYSHORT;
        !            42: #endif
        !            43:        return( (expptr) p );
        !            44: }
        !            45: 
        !            46: 
        !            47: 
        !            48: expptr mkaddcon(l)
        !            49: register int l;
        !            50: {
        !            51:        register Constp p;
        !            52: 
        !            53:        p = mkconst(TYADDR);
        !            54:        p->Const.ci = l;
        !            55:        return( (expptr) p );
        !            56: }
        !            57: 
        !            58: 
        !            59: 
        !            60: expptr mkrealcon(t, d)
        !            61: register int t;
        !            62: double d;
        !            63: {
        !            64:        register Constp p;
        !            65: 
        !            66:        p = mkconst(t);
        !            67:        p->Const.cd[0] = d;
        !            68:        return( (expptr) p );
        !            69: }
        !            70: 
        !            71: 
        !            72: expptr mkbitcon(shift, leng, s)
        !            73: int shift;
        !            74: int leng;
        !            75: char *s;
        !            76: {
        !            77:        register Constp p;
        !            78: 
        !            79:        p = mkconst(TYUNKNOWN);
        !            80:        p->Const.ci = 0;
        !            81:        while(--leng >= 0)
        !            82:                if(*s != ' ')
        !            83:                        p->Const.ci = (p->Const.ci << shift) | hextoi(*s++);
        !            84:        return( (expptr) p );
        !            85: }
        !            86: 
        !            87: 
        !            88: 
        !            89: 
        !            90: 
        !            91: expptr mkstrcon(l,v)
        !            92: int l;
        !            93: register char *v;
        !            94: {
        !            95:        register Constp p;
        !            96:        register char *s;
        !            97: 
        !            98:        p = mkconst(TYCHAR);
        !            99:        p->vleng = ICON(l);
        !           100:        p->Const.ccp = s = (char *) ckalloc(l);
        !           101:        while(--l >= 0)
        !           102:                *s++ = *v++;
        !           103:        return( (expptr) p );
        !           104: }
        !           105: 
        !           106: 
        !           107: expptr mkcxcon(realp,imagp)
        !           108: register expptr realp, imagp;
        !           109: {
        !           110:        int rtype, itype;
        !           111:        register Constp p;
        !           112:        expptr errnode();
        !           113: 
        !           114:        rtype = realp->headblock.vtype;
        !           115:        itype = imagp->headblock.vtype;
        !           116: 
        !           117:        if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
        !           118:        {
        !           119:                p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX);
        !           120:                if( ISINT(rtype) )
        !           121:                        p->Const.cd[0] = realp->constblock.Const.ci;
        !           122:                else    p->Const.cd[0] = realp->constblock.Const.cd[0];
        !           123:                if( ISINT(itype) )
        !           124:                        p->Const.cd[1] = imagp->constblock.Const.ci;
        !           125:                else    p->Const.cd[1] = imagp->constblock.Const.cd[0];
        !           126:        }
        !           127:        else
        !           128:        {
        !           129:                err("invalid complex constant");
        !           130:                p = (Constp)errnode();
        !           131:        }
        !           132: 
        !           133:        frexpr(realp);
        !           134:        frexpr(imagp);
        !           135:        return( (expptr) p );
        !           136: }
        !           137: 
        !           138: 
        !           139: expptr errnode()
        !           140: {
        !           141:        struct Errorblock *p;
        !           142:        p = ALLOC(Errorblock);
        !           143:        p->tag = TERROR;
        !           144:        p->vtype = TYERROR;
        !           145:        return( (expptr) p );
        !           146: }
        !           147: 
        !           148: 
        !           149: 
        !           150: 
        !           151: 
        !           152: expptr mkconv(t, p)
        !           153: register int t;
        !           154: register expptr p;
        !           155: {
        !           156:        register expptr q;
        !           157:        register int pt;
        !           158:        expptr opconv();
        !           159: 
        !           160:        if(t==TYUNKNOWN || t==TYERROR)
        !           161:                badtype("mkconv", t);
        !           162:        pt = p->headblock.vtype;
        !           163:        if(t == pt)
        !           164:                return(p);
        !           165: 
        !           166:        else if( ISCONST(p) && pt!=TYADDR)
        !           167:        {
        !           168:                q = (expptr) mkconst(t);
        !           169:                consconv(t, &(q->constblock.Const),
        !           170:                    p->constblock.vtype, &(p->constblock.Const) );
        !           171:                frexpr(p);
        !           172:        }
        !           173: #if TARGET == PDP11
        !           174:        else if(ISINT(t) && pt==TYCHAR)
        !           175:        {
        !           176:                q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
        !           177:                if(t == TYLONG)
        !           178:                        q = opconv(q, TYLONG);
        !           179:        }
        !           180: #endif
        !           181:        else
        !           182:                q = opconv(p, t);
        !           183: 
        !           184:        if(t == TYCHAR)
        !           185:                q->constblock.vleng = ICON(1);
        !           186:        return(q);
        !           187: }
        !           188: 
        !           189: 
        !           190: 
        !           191: expptr opconv(p, t)
        !           192: expptr p;
        !           193: int t;
        !           194: {
        !           195:        register expptr q;
        !           196: 
        !           197:        q = mkexpr(OPCONV, p, PNULL);
        !           198:        q->headblock.vtype = t;
        !           199:        return(q);
        !           200: }
        !           201: 
        !           202: 
        !           203: 
        !           204: expptr addrof(p)
        !           205: expptr p;
        !           206: {
        !           207:        return( mkexpr(OPADDR, p, PNULL) );
        !           208: }
        !           209: 
        !           210: 
        !           211: 
        !           212: tagptr cpexpr(p)
        !           213: register tagptr p;
        !           214: {
        !           215:        register tagptr e;
        !           216:        int tag;
        !           217:        register chainp ep, pp;
        !           218:        tagptr cpblock();
        !           219: 
        !           220:        static int blksize[ ] =
        !           221:        {       
        !           222:                0,
        !           223:                sizeof(struct Nameblock),
        !           224:                sizeof(struct Constblock),
        !           225:                sizeof(struct Exprblock),
        !           226:                sizeof(struct Addrblock),
        !           227:                sizeof(struct Primblock),
        !           228:                sizeof(struct Listblock),
        !           229:                sizeof(struct Errorblock)
        !           230:        };
        !           231: 
        !           232:        if(p == NULL)
        !           233:                return(NULL);
        !           234: 
        !           235:        if( (tag = p->tag) == TNAME)
        !           236:                return(p);
        !           237: 
        !           238:        e = cpblock( blksize[p->tag] , p);
        !           239: 
        !           240:        switch(tag)
        !           241:        {
        !           242:        case TCONST:
        !           243:                if(e->constblock.vtype == TYCHAR)
        !           244:                {
        !           245:                        e->constblock.Const.ccp =
        !           246:                            copyn(e->constblock.vleng->constblock.Const.ci+1,
        !           247:                                /*was 1+strlen(e->constblock.Const.ccp) */
        !           248:                            e->constblock.Const.ccp);
        !           249:                        e->constblock.vleng =
        !           250:                            (expptr) cpexpr(e->constblock.vleng);
        !           251:                }
        !           252:        case TERROR:
        !           253:                break;
        !           254: 
        !           255:        case TEXPR:
        !           256:                e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
        !           257:                e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
        !           258:                break;
        !           259: 
        !           260:        case TLIST:
        !           261:                if(pp = p->listblock.listp)
        !           262:                {
        !           263:                        ep = e->listblock.listp =
        !           264:                            mkchain( cpexpr(pp->datap), CHNULL);
        !           265:                        for(pp = pp->nextp ; pp ; pp = pp->nextp)
        !           266:                                ep = ep->nextp =
        !           267:                                    mkchain( cpexpr(pp->datap), CHNULL);
        !           268:                }
        !           269:                break;
        !           270: 
        !           271:        case TADDR:
        !           272:                e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
        !           273:                e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
        !           274:                e->addrblock.istemp = NO;
        !           275:                break;
        !           276: 
        !           277:        case TPRIM:
        !           278:                e->primblock.argsp = (struct Listblock *)
        !           279:                    cpexpr(e->primblock.argsp);
        !           280:                e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
        !           281:                e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
        !           282:                break;
        !           283: 
        !           284:        default:
        !           285:                badtag("cpexpr", tag);
        !           286:        }
        !           287: 
        !           288:        return(e);
        !           289: }
        !           290: 
        !           291: frexpr(p)
        !           292: register tagptr p;
        !           293: {
        !           294:        register chainp q;
        !           295: 
        !           296:        if(p == NULL)
        !           297:                return;
        !           298: 
        !           299:        switch(p->tag)
        !           300:        {
        !           301:        case TCONST:
        !           302:                if( ISCHAR(p) )
        !           303:                {
        !           304:                        free( (charptr) (p->constblock.Const.ccp) );
        !           305:                        frexpr(p->constblock.vleng);
        !           306:                }
        !           307:                break;
        !           308: 
        !           309:        case TADDR:
        !           310:                if(p->addrblock.istemp)
        !           311:                {
        !           312:                        frtemp(p);
        !           313:                        return;
        !           314:                }
        !           315:                frexpr(p->addrblock.vleng);
        !           316:                frexpr(p->addrblock.memoffset);
        !           317:                break;
        !           318: 
        !           319:        case TERROR:
        !           320:                break;
        !           321: 
        !           322:        case TNAME:
        !           323:                return;
        !           324: 
        !           325:        case TPRIM:
        !           326:                frexpr(p->primblock.argsp);
        !           327:                frexpr(p->primblock.fcharp);
        !           328:                frexpr(p->primblock.lcharp);
        !           329:                break;
        !           330: 
        !           331:        case TEXPR:
        !           332:                frexpr(p->exprblock.leftp);
        !           333:                if(p->exprblock.rightp)
        !           334:                        frexpr(p->exprblock.rightp);
        !           335:                break;
        !           336: 
        !           337:        case TLIST:
        !           338:                for(q = p->listblock.listp ; q ; q = q->nextp)
        !           339:                        frexpr(q->datap);
        !           340:                frchain( &(p->listblock.listp) );
        !           341:                break;
        !           342: 
        !           343:        default:
        !           344:                badtag("frexpr", p->tag);
        !           345:        }
        !           346: 
        !           347:        free( (charptr) p );
        !           348: }
        !           349: 
        !           350: /* fix up types in expression; replace subtrees and convert
        !           351:    names to address blocks */
        !           352: 
        !           353: expptr fixtype(p)
        !           354: register tagptr p;
        !           355: {
        !           356: 
        !           357:        if(p == 0)
        !           358:                return(0);
        !           359: 
        !           360:        switch(p->tag)
        !           361:        {
        !           362:        case TCONST:
        !           363:                if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR) )
        !           364:                        return( (expptr) p);
        !           365: #if TARGET == VAX
        !           366:                if(ONEOF(p->constblock.vtype,MSKREAL) &&
        !           367:                    p->constblock.Const.cd[0]==0)
        !           368:                        return( (expptr) p);
        !           369: #endif
        !           370:                return( (expptr) putconst(p) );
        !           371: 
        !           372:        case TADDR:
        !           373:                p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
        !           374:                return( (expptr) p);
        !           375: 
        !           376:        case TERROR:
        !           377:                return( (expptr) p);
        !           378: 
        !           379:        default:
        !           380:                badtag("fixtype", p->tag);
        !           381: 
        !           382:        case TEXPR:
        !           383:                return( fixexpr(p) );
        !           384: 
        !           385:        case TLIST:
        !           386:                return( (expptr) p );
        !           387: 
        !           388:        case TPRIM:
        !           389:                if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
        !           390:                {
        !           391:                        if(p->primblock.namep->vtype == TYSUBR)
        !           392:                        {
        !           393:                                err("function invocation of subroutine");
        !           394:                                return( errnode() );
        !           395:                        }
        !           396:                        else
        !           397:                                return( mkfunct(p) );
        !           398:                }
        !           399:                else    return( mklhs(p) );
        !           400:        }
        !           401: }
        !           402: 
        !           403: 
        !           404: 
        !           405: 
        !           406: 
        !           407: /* special case tree transformations and cleanups of expression trees */
        !           408: 
        !           409: expptr fixexpr(p)
        !           410: register Exprp p;
        !           411: {
        !           412:        expptr lp;
        !           413:        register expptr rp;
        !           414:        register expptr q;
        !           415:        int opcode, ltype, rtype, ptype, mtype;
        !           416: 
        !           417:        if( ISERROR(p) )
        !           418:                return( (expptr) p );
        !           419:        else if(p->tag != TEXPR)
        !           420:                badtag("fixexpr", p->tag);
        !           421:        opcode = p->opcode;
        !           422:        lp = p->leftp = fixtype(p->leftp);
        !           423:        ltype = lp->headblock.vtype;
        !           424:        if(opcode==OPASSIGN && lp->tag!=TADDR)
        !           425:        {
        !           426:                err("left side of assignment must be variable");
        !           427:                frexpr(p);
        !           428:                return( errnode() );
        !           429:        }
        !           430: 
        !           431:        if(p->rightp)
        !           432:        {
        !           433:                rp = p->rightp = fixtype(p->rightp);
        !           434:                rtype = rp->headblock.vtype;
        !           435:        }
        !           436:        else
        !           437:        {
        !           438:                rp = NULL;
        !           439:                rtype = 0;
        !           440:        }
        !           441: 
        !           442:        if(ltype==TYERROR || rtype==TYERROR)
        !           443:        {
        !           444:                frexpr(p);
        !           445:                return( errnode() );
        !           446:        }
        !           447: 
        !           448:        /* force folding if possible */
        !           449:        if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
        !           450:        {
        !           451:                q = mkexpr(opcode, lp, rp);
        !           452:                if( ISCONST(q) )
        !           453:                        return(q);
        !           454:                free( (charptr) q );    /* constants did not fold */
        !           455:        }
        !           456: 
        !           457:        if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
        !           458:        {
        !           459:                frexpr(p);
        !           460:                return( errnode() );
        !           461:        }
        !           462: 
        !           463:        switch(opcode)
        !           464:        {
        !           465:        case OPCONCAT:
        !           466:                if(p->vleng == NULL)
        !           467:                        p->vleng = mkexpr(OPPLUS,
        !           468:                            cpexpr(lp->headblock.vleng),
        !           469:                            cpexpr(rp->headblock.vleng) );
        !           470:                break;
        !           471: 
        !           472:        case OPASSIGN:
        !           473:        case OPPLUSEQ:
        !           474:        case OPSTAREQ:
        !           475:                if(ltype == rtype)
        !           476:                        break;
        !           477:                if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
        !           478:                        break;
        !           479:                if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
        !           480:                        break;
        !           481:                if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
        !           482: #if FAMILY==PCC
        !           483:                    && typesize[ltype]>=typesize[rtype] )
        !           484: #else
        !           485:                        && typesize[ltype]==typesize[rtype] )
        !           486: #endif
        !           487:                            break;
        !           488:                p->rightp = fixtype( mkconv(ptype, rp) );
        !           489:                break;
        !           490: 
        !           491:        case OPSLASH:
        !           492:                if( ISCOMPLEX(rtype) )
        !           493:                {
        !           494:                        p = (Exprp) call2(ptype,
        !           495:                            ptype==TYCOMPLEX? "c_div" : "z_div",
        !           496:                            mkconv(ptype, lp), mkconv(ptype, rp) );
        !           497:                        break;
        !           498:                }
        !           499:        case OPPLUS:
        !           500:        case OPMINUS:
        !           501:        case OPSTAR:
        !           502:        case OPMOD:
        !           503:                if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
        !           504:                    (rtype==TYREAL && ! ISCONST(rp) ) ))
        !           505:                        break;
        !           506:                if( ISCOMPLEX(ptype) )
        !           507:                        break;
        !           508:                if(ltype != ptype)
        !           509:                        p->leftp = fixtype(mkconv(ptype,lp));
        !           510:                if(rtype != ptype)
        !           511:                        p->rightp = fixtype(mkconv(ptype,rp));
        !           512:                break;
        !           513: 
        !           514:        case OPPOWER:
        !           515:                return( mkpower(p) );
        !           516: 
        !           517:        case OPLT:
        !           518:        case OPLE:
        !           519:        case OPGT:
        !           520:        case OPGE:
        !           521:        case OPEQ:
        !           522:        case OPNE:
        !           523:                if(ltype == rtype)
        !           524:                        break;
        !           525:                mtype = cktype(OPMINUS, ltype, rtype);
        !           526:                if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
        !           527:                    (rtype==TYREAL && ! ISCONST(rp)) ))
        !           528:                        break;
        !           529:                if( ISCOMPLEX(mtype) )
        !           530:                        break;
        !           531:                if(ltype != mtype)
        !           532:                        p->leftp = fixtype(mkconv(mtype,lp));
        !           533:                if(rtype != mtype)
        !           534:                        p->rightp = fixtype(mkconv(mtype,rp));
        !           535:                break;
        !           536: 
        !           537: 
        !           538:        case OPCONV:
        !           539:                ptype = cktype(OPCONV, p->vtype, ltype);
        !           540:                if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
        !           541:                {
        !           542:                        lp->exprblock.rightp =
        !           543:                            fixtype( mkconv(ptype, lp->exprblock.rightp) );
        !           544:                        free( (charptr) p );
        !           545:                        p = (Exprp) lp;
        !           546:                }
        !           547:                break;
        !           548: 
        !           549:        case OPADDR:
        !           550:                if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
        !           551:                        fatal("addr of addr");
        !           552:                break;
        !           553: 
        !           554:        case OPCOMMA:
        !           555:        case OPQUEST:
        !           556:        case OPCOLON:
        !           557:                break;
        !           558: 
        !           559:        case OPMIN:
        !           560:        case OPMAX:
        !           561:                ptype = p->vtype;
        !           562:                break;
        !           563: 
        !           564:        default:
        !           565:                break;
        !           566:        }
        !           567: 
        !           568:        p->vtype = ptype;
        !           569:        return((expptr) p);
        !           570: }
        !           571: 
        !           572: #if SZINT < SZLONG
        !           573: /*
        !           574:    for efficient subscripting, replace long ints by shorts
        !           575:    in easy places
        !           576: */
        !           577: 
        !           578: expptr shorten(p)
        !           579: register expptr p;
        !           580: {
        !           581:        register expptr q;
        !           582: 
        !           583:        if(p->headblock.vtype != TYLONG)
        !           584:                return(p);
        !           585: 
        !           586:        switch(p->tag)
        !           587:        {
        !           588:        case TERROR:
        !           589:        case TLIST:
        !           590:                return(p);
        !           591: 
        !           592:        case TCONST:
        !           593:        case TADDR:
        !           594:                return( mkconv(TYINT,p) );
        !           595: 
        !           596:        case TEXPR:
        !           597:                break;
        !           598: 
        !           599:        default:
        !           600:                badtag("shorten", p->tag);
        !           601:        }
        !           602: 
        !           603:        switch(p->exprblock.opcode)
        !           604:        {
        !           605:        case OPPLUS:
        !           606:        case OPMINUS:
        !           607:        case OPSTAR:
        !           608:                q = shorten( cpexpr(p->exprblock.rightp) );
        !           609:                if(q->headblock.vtype == TYINT)
        !           610:                {
        !           611:                        p->exprblock.leftp = shorten(p->exprblock.leftp);
        !           612:                        if(p->exprblock.leftp->headblock.vtype == TYLONG)
        !           613:                                frexpr(q);
        !           614:                        else
        !           615:                        {
        !           616:                                frexpr(p->exprblock.rightp);
        !           617:                                p->exprblock.rightp = q;
        !           618:                                p->exprblock.vtype = TYINT;
        !           619:                        }
        !           620:                }
        !           621:                break;
        !           622: 
        !           623:        case OPNEG:
        !           624:                p->exprblock.leftp = shorten(p->exprblock.leftp);
        !           625:                if(p->exprblock.leftp->headblock.vtype == TYINT)
        !           626:                        p->exprblock.vtype = TYINT;
        !           627:                break;
        !           628: 
        !           629:        case OPCALL:
        !           630:        case OPCCALL:
        !           631:                p = mkconv(TYINT,p);
        !           632:                break;
        !           633:        default:
        !           634:                break;
        !           635:        }
        !           636: 
        !           637:        return(p);
        !           638: }
        !           639: #endif
        !           640: 
        !           641: /* fix an argument list, taking due care for special first level cases */
        !           642: 
        !           643: fixargs(doput, p0)
        !           644: int doput;     /* doput is true if the function is not intrinsic */
        !           645: struct Listblock *p0;
        !           646: {
        !           647:        register chainp p;
        !           648:        register tagptr q, t;
        !           649:        register int qtag;
        !           650:        int nargs;
        !           651:        Addrp mkscalar();
        !           652: 
        !           653:        nargs = 0;
        !           654:        if(p0)
        !           655:                for(p = p0->listp ; p ; p = p->nextp)
        !           656:                {
        !           657:                        ++nargs;
        !           658:                        q = p->datap;
        !           659:                        qtag = q->tag;
        !           660:                        if(qtag == TCONST)
        !           661:                        {
        !           662:                                if(q->constblock.vtype == TYSHORT)
        !           663:                                        q = (tagptr) mkconv(tyint, q);
        !           664:                                /* leave constant arguments of intrinsics alone --
        !           665:                 * the expression might still simplify.
        !           666:                 */
        !           667:                                p->datap = doput ? (tagptr) putconst(q) : q ;
        !           668:                        }
        !           669:                        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           670:                            q->primblock.namep->vclass==CLPROC)
        !           671:                                p->datap = (tagptr) mkaddr(q->primblock.namep);
        !           672:                        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           673:                            q->primblock.namep->vdim!=NULL)
        !           674:                                p->datap = (tagptr) mkscalar(q->primblock.namep);
        !           675:                        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           676:                            q->primblock.namep->vdovar && 
        !           677:                            (t = (tagptr) memversion(q->primblock.namep)) )
        !           678:                                p->datap = (tagptr) fixtype(t);
        !           679:                        else
        !           680:                                p->datap = (tagptr) fixtype(q);
        !           681:                }
        !           682:        return(nargs);
        !           683: }
        !           684: 
        !           685: 
        !           686: Addrp mkscalar(np)
        !           687: register Namep np;
        !           688: {
        !           689:        register Addrp ap;
        !           690: 
        !           691:        vardcl(np);
        !           692:        ap = mkaddr(np);
        !           693: 
        !           694: #if TARGET == VAX
        !           695:        /* on the VAX, prolog causes array arguments
        !           696:           to point at the (0,...,0) element, except when
        !           697:           subscript checking is on
        !           698:        */
        !           699:        if( !checksubs && np->vstg==STGARG)
        !           700:        {
        !           701:                register struct Dimblock *dp;
        !           702:                dp = np->vdim;
        !           703:                frexpr(ap->memoffset);
        !           704:                ap->memoffset = mkexpr(OPSTAR,
        !           705:                    (np->vtype==TYCHAR ?
        !           706:                    cpexpr(np->vleng) :
        !           707:                    (tagptr)ICON(typesize[np->vtype]) ),
        !           708:                    cpexpr(dp->baseoffset) );
        !           709:        }
        !           710: #endif
        !           711:        return(ap);
        !           712: }
        !           713: 
        !           714: 
        !           715: 
        !           716: 
        !           717: 
        !           718: expptr mkfunct(p)
        !           719: register struct Primblock *p;
        !           720: {
        !           721:        struct Entrypoint *ep;
        !           722:        Addrp ap;
        !           723:        struct Extsym *extp;
        !           724:        register Namep np;
        !           725:        register expptr q;
        !           726:        expptr intrcall();
        !           727:        int k, nargs;
        !           728:        int class;
        !           729: 
        !           730:        if(p->tag != TPRIM)
        !           731:                return( errnode() );
        !           732: 
        !           733:        np = p->namep;
        !           734:        class = np->vclass;
        !           735: 
        !           736:        if(class == CLUNKNOWN)
        !           737:        {
        !           738:                np->vclass = class = CLPROC;
        !           739:                if(np->vstg == STGUNKNOWN)
        !           740:                {
        !           741:                        if(np->vtype!=TYSUBR && (k = intrfunct(np->varname)) )
        !           742:                        {
        !           743:                                np->vstg = STGINTR;
        !           744:                                np->vardesc.varno = k;
        !           745:                                np->vprocclass = PINTRINSIC;
        !           746:                        }
        !           747:                        else
        !           748:                        {
        !           749:                                extp = mkext( varunder(VL,np->varname) );
        !           750:                                extp->extstg = STGEXT;
        !           751:                                np->vstg = STGEXT;
        !           752:                                np->vardesc.varno = extp - extsymtab;
        !           753:                                np->vprocclass = PEXTERNAL;
        !           754:                        }
        !           755:                }
        !           756:                else if(np->vstg==STGARG)
        !           757:                {
        !           758:                        if(np->vtype == TYCHAR || bugwarn & 2)
        !           759:                                warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
        !           760:                        np->vprocclass = PEXTERNAL;
        !           761:                }
        !           762:        }
        !           763: 
        !           764:        if(class != CLPROC)
        !           765:                fatali("invalid class code %d for function", class);
        !           766:        if(p->fcharp || p->lcharp)
        !           767:        {
        !           768:                err("no substring of function call");
        !           769:                goto error;
        !           770:        }
        !           771:        impldcl(np);
        !           772:        nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
        !           773: 
        !           774:        switch(np->vprocclass)
        !           775:        {
        !           776:        case PEXTERNAL:
        !           777:                ap = mkaddr(np);
        !           778: call:
        !           779:                q = mkexpr(OPCALL, ap, p->argsp);
        !           780:                if( (q->exprblock.vtype = np->vtype) == TYUNKNOWN)
        !           781:                {
        !           782:                        err("attempt to use untyped function");
        !           783:                        goto error;
        !           784:                }
        !           785:                if(np->vleng)
        !           786:                        q->exprblock.vleng = (expptr) cpexpr(np->vleng);
        !           787:                break;
        !           788: 
        !           789:        case PINTRINSIC:
        !           790:                q = intrcall(np, p->argsp, nargs);
        !           791:                break;
        !           792: 
        !           793:        case PSTFUNCT:
        !           794:                q = stfcall(np, p->argsp);
        !           795:                break;
        !           796: 
        !           797:        case PTHISPROC:
        !           798:                warn("recursive call");
        !           799:                for(ep = entries ; ep ; ep = ep->entnextp)
        !           800:                        if(ep->enamep == np)
        !           801:                                break;
        !           802:                if(ep == NULL)
        !           803:                        fatal("mkfunct: impossible recursion");
        !           804:                ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
        !           805:                goto call;
        !           806: 
        !           807:        default:
        !           808:                fatali("mkfunct: impossible vprocclass %d",
        !           809:                    (int) (np->vprocclass) );
        !           810:        }
        !           811:        free( (charptr) p );
        !           812:        return(q);
        !           813: 
        !           814: error:
        !           815:        frexpr(p);
        !           816:        return( errnode() );
        !           817: }
        !           818: 
        !           819: 
        !           820: 
        !           821: LOCAL expptr stfcall(np, actlist)
        !           822: Namep np;
        !           823: struct Listblock *actlist;
        !           824: {
        !           825:        register chainp actuals;
        !           826:        int nargs;
        !           827:        chainp oactp, formals;
        !           828:        int type;
        !           829:        expptr q, rhs, ap;
        !           830:        Namep tnp;
        !           831:        register struct Rplblock *rp;
        !           832:        struct Rplblock *tlist;
        !           833: 
        !           834:        if(actlist)
        !           835:        {
        !           836:                actuals = actlist->listp;
        !           837:                free( (charptr) actlist);
        !           838:        }
        !           839:        else
        !           840:                actuals = NULL;
        !           841:        oactp = actuals;
        !           842: 
        !           843:        nargs = 0;
        !           844:        tlist = NULL;
        !           845:        if( (type = np->vtype) == TYUNKNOWN)
        !           846:        {
        !           847:                err("attempt to use untyped statement function");
        !           848:                q = errnode();
        !           849:                goto ret;
        !           850:        }
        !           851:        formals = (chainp) (np->varxptr.vstfdesc->datap);
        !           852:        rhs = (expptr) (np->varxptr.vstfdesc->nextp);
        !           853: 
        !           854:        /* copy actual arguments into temporaries */
        !           855:        while(actuals!=NULL && formals!=NULL)
        !           856:        {
        !           857:                rp = ALLOC(Rplblock);
        !           858:                rp->rplnp = tnp = (Namep) (formals->datap);
        !           859:                ap = fixtype(actuals->datap);
        !           860:                if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
        !           861:                    && (ap->tag==TCONST || ap->tag==TADDR) )
        !           862:                {
        !           863:                        rp->rplvp = (expptr) ap;
        !           864:                        rp->rplxp = NULL;
        !           865:                        rp->rpltag = ap->tag;
        !           866:                }
        !           867:                else    {
        !           868:                        rp->rplvp = (expptr) mktemp(tnp->vtype, tnp->vleng);
        !           869:                        rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
        !           870:                        if( (rp->rpltag = rp->rplxp->tag) == TERROR)
        !           871:                                err("disagreement of argument types in statement function call");
        !           872:                }
        !           873:                rp->rplnextp = tlist;
        !           874:                tlist = rp;
        !           875:                actuals = actuals->nextp;
        !           876:                formals = formals->nextp;
        !           877:                ++nargs;
        !           878:        }
        !           879: 
        !           880:        if(actuals!=NULL || formals!=NULL)
        !           881:                err("statement function definition and argument list differ");
        !           882: 
        !           883:        /*
        !           884:    now push down names involved in formal argument list, then
        !           885:    evaluate rhs of statement function definition in this environment
        !           886: */
        !           887: 
        !           888:        if(tlist)       /* put tlist in front of the rpllist */
        !           889:        {
        !           890:                for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
        !           891:                        ;
        !           892:                rp->rplnextp = rpllist;
        !           893:                rpllist = tlist;
        !           894:        }
        !           895: 
        !           896:        q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
        !           897: 
        !           898:        /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
        !           899:        while(--nargs >= 0)
        !           900:        {
        !           901:                if(rpllist->rplxp)
        !           902:                        q = mkexpr(OPCOMMA, rpllist->rplxp, q);
        !           903:                rp = rpllist->rplnextp;
        !           904:                frexpr(rpllist->rplvp);
        !           905:                free(rpllist);
        !           906:                rpllist = rp;
        !           907:        }
        !           908: 
        !           909: ret:
        !           910:        frchain( &oactp );
        !           911:        return(q);
        !           912: }
        !           913: 
        !           914: 
        !           915: static int replaced;
        !           916: 
        !           917: Addrp mkplace(np)
        !           918: register Namep np;
        !           919: {
        !           920:        register Addrp s;
        !           921:        register struct Rplblock *rp;
        !           922:        int regn;
        !           923: 
        !           924:        /* is name on the replace list? */
        !           925: 
        !           926:        for(rp = rpllist ; rp ; rp = rp->rplnextp)
        !           927:        {
        !           928:                if(np == rp->rplnp)
        !           929:                {
        !           930:                        replaced = 1;
        !           931:                        if(rp->rpltag == TNAME)
        !           932:                        {
        !           933:                                np = (Namep) (rp->rplvp);
        !           934:                                break;
        !           935:                        }
        !           936:                        else    return( (Addrp) cpexpr(rp->rplvp) );
        !           937:                }
        !           938:        }
        !           939: 
        !           940:        /* is variable a DO index in a register ? */
        !           941: 
        !           942:        if(np->vdovar && ( (regn = inregister(np)) >= 0) )
        !           943:                if(np->vtype == TYERROR)
        !           944:                        return( (Addrp)errnode() );
        !           945:                else
        !           946:                {
        !           947:                        s = ALLOC(Addrblock);
        !           948:                        s->tag = TADDR;
        !           949:                        s->vstg = STGREG;
        !           950:                        s->vtype = TYIREG;
        !           951:                        s->memno = regn;
        !           952:                        s->memoffset = ICON(0);
        !           953:                        return(s);
        !           954:                }
        !           955: 
        !           956:        vardcl(np);
        !           957:        return(mkaddr(np));
        !           958: }
        !           959: 
        !           960: 
        !           961: 
        !           962: 
        !           963: expptr mklhs(p)
        !           964: register struct Primblock *p;
        !           965: {
        !           966:        expptr suboffset();
        !           967:        register Addrp s;
        !           968:        Namep np;
        !           969: 
        !           970:        if(p->tag != TPRIM)
        !           971:                return( (expptr) p );
        !           972:        np = p->namep;
        !           973: 
        !           974:        replaced = 0;
        !           975:        s = mkplace(np);
        !           976:        if(s->tag!=TADDR || s->vstg==STGREG)
        !           977:        {
        !           978:                free( (charptr) p );
        !           979:                return( (expptr) s );
        !           980:        }
        !           981: 
        !           982:        /* compute the address modified by subscripts */
        !           983: 
        !           984:        if (replaced && bugwarn == 1 && (p->argsp || p->namep->vdim))
        !           985:                warnb1("old f77 complained at stmt func arg %s",
        !           986:                        varstr(VL, np->varname));
        !           987:        if (!replaced || bugwarn & 2)
        !           988:                s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
        !           989:        frexpr(p->argsp);
        !           990:        p->argsp = NULL;
        !           991: 
        !           992:        /* now do substring part */
        !           993: 
        !           994:        if(p->fcharp || p->lcharp)
        !           995:        {
        !           996:                if(np->vtype != TYCHAR)
        !           997:                        errstr("substring of noncharacter %s", varstr(VL,np->varname));
        !           998:                else    {
        !           999:                        if(p->lcharp == NULL)
        !          1000:                                p->lcharp = (expptr) cpexpr(s->vleng);
        !          1001:                        if(p->fcharp)
        !          1002:                                s->vleng = mkexpr(OPMINUS, p->lcharp,
        !          1003:                                    mkexpr(OPMINUS, p->fcharp, ICON(1) ));
        !          1004:                        else    {
        !          1005:                                frexpr(s->vleng);
        !          1006:                                s->vleng = p->lcharp;
        !          1007:                        }
        !          1008:                }
        !          1009:        }
        !          1010: 
        !          1011:        s->vleng = fixtype( s->vleng );
        !          1012:        s->memoffset = fixtype( s->memoffset );
        !          1013:        free( (charptr) p );
        !          1014:        return( (expptr) s );
        !          1015: }
        !          1016: 
        !          1017: 
        !          1018: 
        !          1019: 
        !          1020: 
        !          1021: deregister(np)
        !          1022: Namep np;
        !          1023: {
        !          1024:        if(nregvar>0 && regnamep[nregvar-1]==np)
        !          1025:        {
        !          1026:                --nregvar;
        !          1027: #if FAMILY == DMR
        !          1028:                putnreg();
        !          1029: #endif
        !          1030:        }
        !          1031: }
        !          1032: 
        !          1033: 
        !          1034: 
        !          1035: 
        !          1036: Addrp memversion(np)
        !          1037: register Namep np;
        !          1038: {
        !          1039:        register Addrp s;
        !          1040: 
        !          1041:        if(np->vdovar==NO || (inregister(np)<0) )
        !          1042:                return(NULL);
        !          1043:        np->vdovar = NO;
        !          1044:        s = mkplace(np);
        !          1045:        np->vdovar = YES;
        !          1046:        return(s);
        !          1047: }
        !          1048: 
        !          1049: 
        !          1050: 
        !          1051: inregister(np)
        !          1052: register Namep np;
        !          1053: {
        !          1054:        register int i;
        !          1055: 
        !          1056:        for(i = 0 ; i < nregvar ; ++i)
        !          1057:                if(regnamep[i] == np)
        !          1058:                        return( regnum[i] );
        !          1059:        return(-1);
        !          1060: }
        !          1061: 
        !          1062: 
        !          1063: 
        !          1064: 
        !          1065: enregister(np)
        !          1066: Namep np;
        !          1067: {
        !          1068:        if( inregister(np) >= 0)
        !          1069:                return(YES);
        !          1070:        if(nregvar >= maxregvar)
        !          1071:                return(NO);
        !          1072:        vardcl(np);
        !          1073:        if( ONEOF(np->vtype, MSKIREG) )
        !          1074:        {
        !          1075:                regnamep[nregvar++] = np;
        !          1076:                if(nregvar > highregvar)
        !          1077:                        highregvar = nregvar;
        !          1078: #if FAMILY == DMR
        !          1079:                putnreg();
        !          1080: #endif
        !          1081:                return(YES);
        !          1082:        }
        !          1083:        else
        !          1084:                return(NO);
        !          1085: }
        !          1086: 
        !          1087: 
        !          1088: 
        !          1089: 
        !          1090: expptr suboffset(p)
        !          1091: register struct Primblock *p;
        !          1092: {
        !          1093:        int n;
        !          1094:        expptr size;
        !          1095:        chainp cp;
        !          1096:        expptr offp, prod;
        !          1097:        expptr subcheck();
        !          1098:        struct Dimblock *dimp;
        !          1099:        expptr sub[MAXDIM+1];
        !          1100:        register Namep np;
        !          1101: 
        !          1102:        np = p->namep;
        !          1103:        offp = ICON(0);
        !          1104:        n = 0;
        !          1105:        if(p->argsp)
        !          1106:                for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
        !          1107:                {
        !          1108:                        sub[n++] = fixtype(cpexpr(cp->datap));
        !          1109:                        if(n > maxdim)
        !          1110:                        {
        !          1111:                                erri("more than %d subscripts", maxdim);
        !          1112:                                break;
        !          1113:                        }
        !          1114:                }
        !          1115: 
        !          1116:        dimp = np->vdim;
        !          1117:        if(n>0 && dimp==NULL)
        !          1118:                err("subscripts on scalar variable");
        !          1119:        else if(dimp && dimp->ndim!=n)
        !          1120:                errstr("wrong number of subscripts on %s",
        !          1121:                    varstr(VL, np->varname) );
        !          1122:        else if(n > 0)
        !          1123:        {
        !          1124:                prod = sub[--n];
        !          1125:                while( --n >= 0)
        !          1126:                        prod = mkexpr(OPPLUS, sub[n],
        !          1127:                            mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
        !          1128: #if TARGET == VAX
        !          1129:                if(checksubs || np->vstg!=STGARG)
        !          1130:                        prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
        !          1131: #else
        !          1132:                prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
        !          1133: #endif
        !          1134:                if(checksubs)
        !          1135:                        prod = subcheck(np, prod);
        !          1136:                size = np->vtype == TYCHAR ?
        !          1137:                    (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
        !          1138:                prod = mkexpr(OPSTAR, prod, size);
        !          1139:                offp = mkexpr(OPPLUS, offp, prod);
        !          1140:        }
        !          1141: 
        !          1142:        if(p->fcharp && np->vtype==TYCHAR)
        !          1143:                offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
        !          1144: 
        !          1145:        return(offp);
        !          1146: }
        !          1147: 
        !          1148: 
        !          1149: 
        !          1150: 
        !          1151: expptr subcheck(np, p)
        !          1152: Namep np;
        !          1153: register expptr p;
        !          1154: {
        !          1155:        struct Dimblock *dimp;
        !          1156:        expptr t, checkvar, checkcond, badcall;
        !          1157: 
        !          1158:        dimp = np->vdim;
        !          1159:        if(dimp->nelt == NULL)
        !          1160:                return(p);      /* don't check arrays with * bounds */
        !          1161:        checkvar = NULL;
        !          1162:        checkcond = NULL;
        !          1163:        if( ISICON(p) )
        !          1164:        {
        !          1165:                if(p->constblock.Const.ci < 0)
        !          1166:                        goto badsub;
        !          1167:                if( ISICON(dimp->nelt) )
        !          1168:                        if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
        !          1169:                                return(p);
        !          1170:                        else
        !          1171:                                goto badsub;
        !          1172:        }
        !          1173:        if(p->tag==TADDR && p->addrblock.vstg==STGREG)
        !          1174:        {
        !          1175:                checkvar = (expptr) cpexpr(p);
        !          1176:                t = p;
        !          1177:        }
        !          1178:        else    {
        !          1179:                checkvar = (expptr) mktemp(p->headblock.vtype, ENULL);
        !          1180:                t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
        !          1181:        }
        !          1182:        checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
        !          1183:        if( ! ISICON(p) )
        !          1184:                checkcond = mkexpr(OPAND, checkcond,
        !          1185:                    mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
        !          1186: 
        !          1187:        badcall = call4(p->headblock.vtype, "s_rnge",
        !          1188:            mkstrcon(VL, np->varname),
        !          1189:            mkconv(TYLONG,  cpexpr(checkvar)),
        !          1190:            mkstrcon(XL, procname),
        !          1191:            ICON(lineno) );
        !          1192:        badcall->exprblock.opcode = OPCCALL;
        !          1193:        p = mkexpr(OPQUEST, checkcond,
        !          1194:            mkexpr(OPCOLON, checkvar, badcall));
        !          1195: 
        !          1196:        return(p);
        !          1197: 
        !          1198: badsub:
        !          1199:        frexpr(p);
        !          1200:        errstr("subscript on variable %s out of range", varstr(VL,np->varname));
        !          1201:        return ( ICON(0) );
        !          1202: }
        !          1203: 
        !          1204: 
        !          1205: 
        !          1206: 
        !          1207: Addrp mkaddr(p)
        !          1208: register Namep p;
        !          1209: {
        !          1210:        struct Extsym *extp;
        !          1211:        register Addrp t;
        !          1212:        Addrp intraddr();
        !          1213: 
        !          1214:        switch( p->vstg)
        !          1215:        {
        !          1216:        case STGUNKNOWN:
        !          1217:                if(p->vclass != CLPROC)
        !          1218:                        break;
        !          1219:                extp = mkext( varunder(VL, p->varname) );
        !          1220:                extp->extstg = STGEXT;
        !          1221:                p->vstg = STGEXT;
        !          1222:                p->vardesc.varno = extp - extsymtab;
        !          1223:                p->vprocclass = PEXTERNAL;
        !          1224: 
        !          1225:        case STGCOMMON:
        !          1226:        case STGEXT:
        !          1227:        case STGBSS:
        !          1228:        case STGINIT:
        !          1229:        case STGEQUIV:
        !          1230:        case STGARG:
        !          1231:        case STGLENG:
        !          1232:        case STGAUTO:
        !          1233:                t = ALLOC(Addrblock);
        !          1234:                t->tag = TADDR;
        !          1235:                if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
        !          1236:                        t->vclass = CLVAR;
        !          1237:                else
        !          1238:                        t->vclass = p->vclass;
        !          1239:                t->vtype = p->vtype;
        !          1240:                t->vstg = p->vstg;
        !          1241:                t->memno = p->vardesc.varno;
        !          1242:                t->memoffset = ICON(p->voffset);
        !          1243:                if(p->vleng)
        !          1244:                {
        !          1245:                        t->vleng = (expptr) cpexpr(p->vleng);
        !          1246:                        if( ISICON(t->vleng) )
        !          1247:                                t->varleng = t->vleng->constblock.Const.ci;
        !          1248:                }
        !          1249:                return(t);
        !          1250: 
        !          1251:        case STGINTR:
        !          1252:                return( intraddr(p) );
        !          1253: 
        !          1254:        }
        !          1255:        /*debug*/fprintf(diagfile,"mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
        !          1256:        badstg("mkaddr", p->vstg);
        !          1257:        /* NOTREACHED */
        !          1258: }
        !          1259: 
        !          1260: 
        !          1261: 
        !          1262: 
        !          1263: Addrp mkarg(type, argno)
        !          1264: int type, argno;
        !          1265: {
        !          1266:        register Addrp p;
        !          1267: 
        !          1268:        p = ALLOC(Addrblock);
        !          1269:        p->tag = TADDR;
        !          1270:        p->vtype = type;
        !          1271:        p->vclass = CLVAR;
        !          1272:        p->vstg = (type==TYLENG ? STGLENG : STGARG);
        !          1273:        p->memno = argno;
        !          1274:        return(p);
        !          1275: }
        !          1276: 
        !          1277: 
        !          1278: 
        !          1279: 
        !          1280: expptr mkprim(v, args, substr)
        !          1281: register union
        !          1282:        {
        !          1283:        struct Paramblock paramblock;
        !          1284:        struct Nameblock nameblock;
        !          1285:        struct Headblock headblock;
        !          1286: } *v;
        !          1287: struct Listblock *args;
        !          1288: chainp substr;
        !          1289: {
        !          1290:        register struct Primblock *p;
        !          1291: 
        !          1292:        if(v->headblock.vclass == CLPARAM)
        !          1293:        {
        !          1294:                if(args || substr)
        !          1295:                {
        !          1296:                        errstr("no qualifiers on parameter name %s",
        !          1297:                            varstr(VL,v->paramblock.varname));
        !          1298:                        frexpr(args);
        !          1299:                        if(substr)
        !          1300:                        {
        !          1301:                                frexpr(substr->datap);
        !          1302:                                frexpr(substr->nextp->datap);
        !          1303:                                frchain(&substr);
        !          1304:                        }
        !          1305:                        frexpr(v);
        !          1306:                        return( errnode() );
        !          1307:                }
        !          1308:                return( (expptr) cpexpr(v->paramblock.paramval) );
        !          1309:        }
        !          1310: 
        !          1311:        p = ALLOC(Primblock);
        !          1312:        p->tag = TPRIM;
        !          1313:        p->vtype = v->nameblock.vtype;
        !          1314:        p->namep = (Namep) v;
        !          1315:        p->argsp = args;
        !          1316:        if(substr)
        !          1317:        {
        !          1318:                p->fcharp = (expptr) (substr->datap);
        !          1319:                p->lcharp = (expptr) (substr->nextp->datap);
        !          1320:                frchain(&substr);
        !          1321:        }
        !          1322:        return( (expptr) p);
        !          1323: }
        !          1324: 
        !          1325: 
        !          1326: 
        !          1327: vardcl(v)
        !          1328: register Namep v;
        !          1329: {
        !          1330:        int nelt;
        !          1331:        struct Dimblock *t;
        !          1332:        Addrp p;
        !          1333:        expptr neltp;
        !          1334: 
        !          1335:        if(v->vdcldone)
        !          1336:                return;
        !          1337:        if(v->vclass == CLNAMELIST)
        !          1338:                return;
        !          1339: 
        !          1340:        if(v->vtype == TYUNKNOWN)
        !          1341:                impldcl(v);
        !          1342:        if(v->vclass == CLUNKNOWN)
        !          1343:                v->vclass = CLVAR;
        !          1344:        else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
        !          1345:        {
        !          1346:                dclerr("used as variable", v);
        !          1347:                return;
        !          1348:        }
        !          1349:        if(v->vstg==STGUNKNOWN)
        !          1350:                v->vstg = implstg[ letter(v->varname[0]) ];
        !          1351: 
        !          1352:        switch(v->vstg)
        !          1353:        {
        !          1354:        case STGBSS:
        !          1355:                v->vardesc.varno = ++lastvarno;
        !          1356:                break;
        !          1357:        case STGAUTO:
        !          1358:                if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
        !          1359:                        break;
        !          1360:                nelt = 1;
        !          1361:                if(t = v->vdim)
        !          1362:                        if( (neltp = t->nelt) && ISCONST(neltp) )
        !          1363:                                nelt = neltp->constblock.Const.ci;
        !          1364:                        else
        !          1365:                                dclerr("adjustable automatic array", v);
        !          1366:                p = autovar(nelt, v->vtype, v->vleng);
        !          1367:                v->voffset = p->memoffset->constblock.Const.ci;
        !          1368:                frexpr(p);
        !          1369:                break;
        !          1370: 
        !          1371:        default:
        !          1372:                break;
        !          1373:        }
        !          1374:        v->vdcldone = YES;
        !          1375: }
        !          1376: 
        !          1377: 
        !          1378: 
        !          1379: 
        !          1380: impldcl(p)
        !          1381: register Namep p;
        !          1382: {
        !          1383:        register int k;
        !          1384:        int type, leng;
        !          1385: 
        !          1386:        if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
        !          1387:                return;
        !          1388:        if(p->vtype == TYUNKNOWN)
        !          1389:        {
        !          1390:                k = letter(p->varname[0]);
        !          1391:                type = impltype[ k ];
        !          1392:                leng = implleng[ k ];
        !          1393:                if(type == TYUNKNOWN)
        !          1394:                {
        !          1395:                        if(p->vclass == CLPROC)
        !          1396:                                return;
        !          1397:                        dclerr("attempt to use undefined variable", p);
        !          1398:                        type = TYERROR;
        !          1399:                        leng = 1;
        !          1400:                }
        !          1401:                settype(p, type, leng);
        !          1402:        }
        !          1403: }
        !          1404: 
        !          1405: 
        !          1406: 
        !          1407: 
        !          1408: LOCAL letter(c)
        !          1409: register int c;
        !          1410: {
        !          1411:        if( isupper(c) )
        !          1412:                c = tolower(c);
        !          1413:        return(c - 'a');
        !          1414: }
        !          1415: 
        !          1416: #define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
        !          1417: #define COMMUTE        { e = lp;  lp = rp;  rp = e; }
        !          1418: 
        !          1419: 
        !          1420: expptr mkexpr(opcode, lp, rp)
        !          1421: int opcode;
        !          1422: register expptr lp, rp;
        !          1423: {
        !          1424:        register expptr e, e1;
        !          1425:        int etype;
        !          1426:        int ltype, rtype;
        !          1427:        int ltag, rtag;
        !          1428: 
        !          1429:        ltype = lp->headblock.vtype;
        !          1430:        ltag = lp->tag;
        !          1431:        if(rp && opcode!=OPCALL && opcode!=OPCCALL)
        !          1432:        {
        !          1433:                rtype = rp->headblock.vtype;
        !          1434:                rtag = rp->tag;
        !          1435:        }
        !          1436:        else rtype = 0;
        !          1437: 
        !          1438:        etype = cktype(opcode, ltype, rtype);
        !          1439:        if(etype == TYERROR)
        !          1440:                goto error;
        !          1441: 
        !          1442:        switch(opcode)
        !          1443:        {
        !          1444:                /* check for multiplication by 0 and 1 and addition to 0 */
        !          1445: 
        !          1446:        case OPSTAR:
        !          1447:                if( ISCONST(lp) )
        !          1448:                        COMMUTE
        !          1449: 
        !          1450:                            if( ISICON(rp) )
        !          1451:                        {
        !          1452:                                if(rp->constblock.Const.ci == 0)
        !          1453:                                        goto retright;
        !          1454:                                goto mulop;
        !          1455:                        }
        !          1456:                break;
        !          1457: 
        !          1458:        case OPSLASH:
        !          1459:        case OPMOD:
        !          1460:                if( ICONEQ(rp, 0) )
        !          1461:                {
        !          1462:                        err("attempted division by zero");
        !          1463:                        rp = ICON(1);
        !          1464:                        break;
        !          1465:                }
        !          1466:                if(opcode == OPMOD)
        !          1467:                        break;
        !          1468: 
        !          1469: 
        !          1470: mulop:
        !          1471:                if( ISICON(rp) )
        !          1472:                {
        !          1473:                        if(rp->constblock.Const.ci == 1)
        !          1474:                                goto retleft;
        !          1475: 
        !          1476:                        if(rp->constblock.Const.ci == -1)
        !          1477:                        {
        !          1478:                                frexpr(rp);
        !          1479:                                return( mkexpr(OPNEG, lp, PNULL) );
        !          1480:                        }
        !          1481:                }
        !          1482: 
        !          1483:                if( ISSTAROP(lp) && ISICON(lp->exprblock.rightp) )
        !          1484:                {
        !          1485:                        if(opcode == OPSTAR)
        !          1486:                                e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
        !          1487:                        else if(ISICON(rp) &&
        !          1488:                            (lp->exprblock.rightp->constblock.Const.ci %
        !          1489:                            rp->constblock.Const.ci) == 0)
        !          1490:                                e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
        !          1491:                        else    break;
        !          1492: 
        !          1493:                        e1 = lp->exprblock.leftp;
        !          1494:                        free( (charptr) lp );
        !          1495:                        return( mkexpr(OPSTAR, e1, e) );
        !          1496:                }
        !          1497:                break;
        !          1498: 
        !          1499: 
        !          1500:        case OPPLUS:
        !          1501:                if( ISCONST(lp) )
        !          1502:                        COMMUTE
        !          1503:                            goto addop;
        !          1504: 
        !          1505:        case OPMINUS:
        !          1506:                if( ICONEQ(lp, 0) )
        !          1507:                {
        !          1508:                        frexpr(lp);
        !          1509:                        return( mkexpr(OPNEG, rp, ENULL) );
        !          1510:                }
        !          1511: 
        !          1512:                if( ISCONST(rp) )
        !          1513:                {
        !          1514:                        opcode = OPPLUS;
        !          1515:                        consnegop(rp);
        !          1516:                }
        !          1517: 
        !          1518: addop:
        !          1519:                if( ISICON(rp) )
        !          1520:                {
        !          1521:                        if(rp->constblock.Const.ci == 0)
        !          1522:                                goto retleft;
        !          1523:                        if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
        !          1524:                        {
        !          1525:                                e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
        !          1526:                                e1 = lp->exprblock.leftp;
        !          1527:                                free( (charptr) lp );
        !          1528:                                return( mkexpr(OPPLUS, e1, e) );
        !          1529:                        }
        !          1530:                }
        !          1531:                break;
        !          1532: 
        !          1533: 
        !          1534:        case OPPOWER:
        !          1535:                break;
        !          1536: 
        !          1537:        case OPNEG:
        !          1538:                if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
        !          1539:                {
        !          1540:                        e = lp->exprblock.leftp;
        !          1541:                        free( (charptr) lp );
        !          1542:                        return(e);
        !          1543:                }
        !          1544:                break;
        !          1545: 
        !          1546:        case OPNOT:
        !          1547:                if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
        !          1548:                {
        !          1549:                        e = lp->exprblock.leftp;
        !          1550:                        free( (charptr) lp );
        !          1551:                        return(e);
        !          1552:                }
        !          1553:                break;
        !          1554: 
        !          1555:        case OPCALL:
        !          1556:        case OPCCALL:
        !          1557:                etype = ltype;
        !          1558:                if(rp!=NULL && rp->listblock.listp==NULL)
        !          1559:                {
        !          1560:                        free( (charptr) rp );
        !          1561:                        rp = NULL;
        !          1562:                }
        !          1563:                break;
        !          1564: 
        !          1565:        case OPAND:
        !          1566:        case OPOR:
        !          1567:                if( ISCONST(lp) )
        !          1568:                        COMMUTE
        !          1569: 
        !          1570:                            if( ISCONST(rp) )
        !          1571:                        {
        !          1572:                                if(rp->constblock.Const.ci == 0)
        !          1573:                                        if(opcode == OPOR)
        !          1574:                                                goto retleft;
        !          1575:                                        else
        !          1576:                                                goto retright;
        !          1577:                                else if(opcode == OPOR)
        !          1578:                                        goto retright;
        !          1579:                                else
        !          1580:                                        goto retleft;
        !          1581:                        }
        !          1582:        case OPEQV:
        !          1583:        case OPNEQV:
        !          1584: 
        !          1585:        case OPBITAND:
        !          1586:        case OPBITOR:
        !          1587:        case OPBITXOR:
        !          1588:        case OPBITNOT:
        !          1589:        case OPLSHIFT:
        !          1590:        case OPRSHIFT:
        !          1591: 
        !          1592:        case OPLT:
        !          1593:        case OPGT:
        !          1594:        case OPLE:
        !          1595:        case OPGE:
        !          1596:        case OPEQ:
        !          1597:        case OPNE:
        !          1598: 
        !          1599:        case OPCONCAT:
        !          1600:                break;
        !          1601:        case OPMIN:
        !          1602:        case OPMAX:
        !          1603: 
        !          1604:        case OPASSIGN:
        !          1605:        case OPPLUSEQ:
        !          1606:        case OPSTAREQ:
        !          1607: 
        !          1608:        case OPCONV:
        !          1609:        case OPADDR:
        !          1610: 
        !          1611:        case OPCOMMA:
        !          1612:        case OPQUEST:
        !          1613:        case OPCOLON:
        !          1614:                break;
        !          1615: 
        !          1616:        default:
        !          1617:                badop("mkexpr", opcode);
        !          1618:        }
        !          1619: 
        !          1620:        e = (expptr) ALLOC(Exprblock);
        !          1621:        e->exprblock.tag = TEXPR;
        !          1622:        e->exprblock.opcode = opcode;
        !          1623:        e->exprblock.vtype = etype;
        !          1624:        e->exprblock.leftp = lp;
        !          1625:        e->exprblock.rightp = rp;
        !          1626:        if(ltag==TCONST && (rp==0 || rtag==TCONST) )
        !          1627:                e = fold(e);
        !          1628:        return(e);
        !          1629: 
        !          1630: retleft:
        !          1631:        frexpr(rp);
        !          1632:        return(lp);
        !          1633: 
        !          1634: retright:
        !          1635:        frexpr(lp);
        !          1636:        return(rp);
        !          1637: 
        !          1638: error:
        !          1639:        frexpr(lp);
        !          1640:        if(rp && opcode!=OPCALL && opcode!=OPCCALL)
        !          1641:                frexpr(rp);
        !          1642:        return( errnode() );
        !          1643: }
        !          1644: 
        !          1645: #define ERR(s)   { errs = s; goto error; }
        !          1646: 
        !          1647: cktype(op, lt, rt)
        !          1648: register int op, lt, rt;
        !          1649: {
        !          1650:        char *errs;
        !          1651: 
        !          1652:        if(lt==TYERROR || rt==TYERROR)
        !          1653:                goto error1;
        !          1654: 
        !          1655:        if(lt==TYUNKNOWN)
        !          1656:                return(TYUNKNOWN);
        !          1657:        if(rt==TYUNKNOWN)
        !          1658:                if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
        !          1659:                        return(TYUNKNOWN);
        !          1660: 
        !          1661:        switch(op)
        !          1662:        {
        !          1663:        case OPPLUS:
        !          1664:        case OPMINUS:
        !          1665:        case OPSTAR:
        !          1666:        case OPSLASH:
        !          1667:        case OPPOWER:
        !          1668:        case OPMOD:
        !          1669:                if( ISNUMERIC(lt) && ISNUMERIC(rt) )
        !          1670:                        return( maxtype(lt, rt) );
        !          1671:                ERR("nonarithmetic operand of arithmetic operator")
        !          1672: 
        !          1673:            case OPNEG:
        !          1674:                if( ISNUMERIC(lt) )
        !          1675:                        return(lt);
        !          1676:                ERR("nonarithmetic operand of negation")
        !          1677: 
        !          1678:            case OPNOT:
        !          1679:                if(lt == TYLOGICAL)
        !          1680:                        return(TYLOGICAL);
        !          1681:                ERR("NOT of nonlogical")
        !          1682: 
        !          1683:            case OPAND:
        !          1684:        case OPOR:
        !          1685:        case OPEQV:
        !          1686:        case OPNEQV:
        !          1687:                if(lt==TYLOGICAL && rt==TYLOGICAL)
        !          1688:                        return(TYLOGICAL);
        !          1689:                ERR("nonlogical operand of logical operator")
        !          1690: 
        !          1691:            case OPLT:
        !          1692:        case OPGT:
        !          1693:        case OPLE:
        !          1694:        case OPGE:
        !          1695:        case OPEQ:
        !          1696:        case OPNE:
        !          1697:                if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
        !          1698:                {
        !          1699:                        if(lt != rt)
        !          1700:                                ERR("illegal comparison")
        !          1701:                }
        !          1702: 
        !          1703:                else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
        !          1704:                {
        !          1705:                        if(op!=OPEQ && op!=OPNE)
        !          1706:                                ERR("order comparison of complex data")
        !          1707:                }
        !          1708: 
        !          1709:                else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
        !          1710:                        ERR("comparison of nonarithmetic data")
        !          1711:                            return(TYLOGICAL);
        !          1712: 
        !          1713:        case OPCONCAT:
        !          1714:                if(lt==TYCHAR && rt==TYCHAR)
        !          1715:                        return(TYCHAR);
        !          1716:                ERR("concatenation of nonchar data")
        !          1717: 
        !          1718:            case OPCALL:
        !          1719:        case OPCCALL:
        !          1720:                return(lt);
        !          1721: 
        !          1722:        case OPADDR:
        !          1723:                return(TYADDR);
        !          1724: 
        !          1725:        case OPCONV:
        !          1726:                if(rt == 0)
        !          1727:                        return(0);
        !          1728:                if(lt==TYCHAR && ISINT(rt) )
        !          1729:                        return(TYCHAR);
        !          1730:        case OPASSIGN:
        !          1731:        case OPPLUSEQ:
        !          1732:        case OPSTAREQ:
        !          1733:                if( ISINT(lt) && rt==TYCHAR)
        !          1734:                        return(lt);
        !          1735:                if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
        !          1736:                        if(op!=OPASSIGN || lt!=rt)
        !          1737:                        {
        !          1738:                                /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
        !          1739:                                /* debug fatal("impossible conversion.  possible compiler bug"); */
        !          1740:                                ERR("impossible conversion")
        !          1741:                        }
        !          1742:                return(lt);
        !          1743: 
        !          1744:        case OPMIN:
        !          1745:        case OPMAX:
        !          1746:        case OPBITOR:
        !          1747:        case OPBITAND:
        !          1748:        case OPBITXOR:
        !          1749:        case OPBITNOT:
        !          1750:        case OPLSHIFT:
        !          1751:        case OPRSHIFT:
        !          1752:                return(lt);
        !          1753: 
        !          1754:        case OPCOMMA:
        !          1755:        case OPQUEST:
        !          1756:        case OPCOLON:
        !          1757:                return(rt);
        !          1758: 
        !          1759:        default:
        !          1760:                badop("cktype", op);
        !          1761:        }
        !          1762: error: 
        !          1763:        err(errs);
        !          1764: error1:        
        !          1765:        return(TYERROR);
        !          1766: }
        !          1767: 
        !          1768: LOCAL expptr fold(e)
        !          1769: register expptr e;
        !          1770: {
        !          1771:        Constp p;
        !          1772:        register expptr lp, rp;
        !          1773:        int etype, mtype, ltype, rtype, opcode;
        !          1774:        int i, ll, lr;
        !          1775:        char *q, *s;
        !          1776:        union Constant lcon, rcon;
        !          1777: 
        !          1778:        opcode = e->exprblock.opcode;
        !          1779:        etype = e->exprblock.vtype;
        !          1780: 
        !          1781:        lp = e->exprblock.leftp;
        !          1782:        ltype = lp->headblock.vtype;
        !          1783:        rp = e->exprblock.rightp;
        !          1784: 
        !          1785:        if(rp == 0)
        !          1786:                switch(opcode)
        !          1787:                {
        !          1788:                case OPNOT:
        !          1789:                        lp->constblock.Const.ci = ! lp->constblock.Const.ci;
        !          1790:                        return(lp);
        !          1791: 
        !          1792:                case OPBITNOT:
        !          1793:                        lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
        !          1794:                        return(lp);
        !          1795: 
        !          1796:                case OPNEG:
        !          1797:                        consnegop(lp);
        !          1798:                        return(lp);
        !          1799: 
        !          1800:                case OPCONV:
        !          1801:                case OPADDR:
        !          1802:                        return(e);
        !          1803: 
        !          1804:                default:
        !          1805:                        badop("fold", opcode);
        !          1806:                }
        !          1807: 
        !          1808:        rtype = rp->headblock.vtype;
        !          1809: 
        !          1810:        p = ALLOC(Constblock);
        !          1811:        p->tag = TCONST;
        !          1812:        p->vtype = etype;
        !          1813:        p->vleng = e->exprblock.vleng;
        !          1814: 
        !          1815:        switch(opcode)
        !          1816:        {
        !          1817:        case OPCOMMA:
        !          1818:        case OPQUEST:
        !          1819:        case OPCOLON:
        !          1820:                return(e);
        !          1821: 
        !          1822:        case OPAND:
        !          1823:                p->Const.ci = lp->constblock.Const.ci &&
        !          1824:                    rp->constblock.Const.ci;
        !          1825:                break;
        !          1826: 
        !          1827:        case OPOR:
        !          1828:                p->Const.ci = lp->constblock.Const.ci ||
        !          1829:                    rp->constblock.Const.ci;
        !          1830:                break;
        !          1831: 
        !          1832:        case OPEQV:
        !          1833:                p->Const.ci = lp->constblock.Const.ci ==
        !          1834:                    rp->constblock.Const.ci;
        !          1835:                break;
        !          1836: 
        !          1837:        case OPNEQV:
        !          1838:                p->Const.ci = lp->constblock.Const.ci !=
        !          1839:                    rp->constblock.Const.ci;
        !          1840:                break;
        !          1841: 
        !          1842:        case OPBITAND:
        !          1843:                p->Const.ci = lp->constblock.Const.ci &
        !          1844:                    rp->constblock.Const.ci;
        !          1845:                break;
        !          1846: 
        !          1847:        case OPBITOR:
        !          1848:                p->Const.ci = lp->constblock.Const.ci |
        !          1849:                    rp->constblock.Const.ci;
        !          1850:                break;
        !          1851: 
        !          1852:        case OPBITXOR:
        !          1853:                p->Const.ci = lp->constblock.Const.ci ^
        !          1854:                    rp->constblock.Const.ci;
        !          1855:                break;
        !          1856: 
        !          1857:        case OPLSHIFT:
        !          1858:                p->Const.ci = lp->constblock.Const.ci <<
        !          1859:                    rp->constblock.Const.ci;
        !          1860:                break;
        !          1861: 
        !          1862:        case OPRSHIFT:
        !          1863:                p->Const.ci = lp->constblock.Const.ci >>
        !          1864:                    rp->constblock.Const.ci;
        !          1865:                break;
        !          1866: 
        !          1867:        case OPCONCAT:
        !          1868:                ll = lp->constblock.vleng->constblock.Const.ci;
        !          1869:                lr = rp->constblock.vleng->constblock.Const.ci;
        !          1870:                p->Const.ccp = q = (char *) ckalloc(ll+lr);
        !          1871:                p->vleng = ICON(ll+lr);
        !          1872:                s = lp->constblock.Const.ccp;
        !          1873:                for(i = 0 ; i < ll ; ++i)
        !          1874:                        *q++ = *s++;
        !          1875:                s = rp->constblock.Const.ccp;
        !          1876:                for(i = 0; i < lr; ++i)
        !          1877:                        *q++ = *s++;
        !          1878:                break;
        !          1879: 
        !          1880: 
        !          1881:        case OPPOWER:
        !          1882:                if( ! ISINT(rtype) )
        !          1883:                        return(e);
        !          1884:                conspower(&(p->Const), lp, rp->constblock.Const.ci);
        !          1885:                break;
        !          1886: 
        !          1887: 
        !          1888:        default:
        !          1889:                if(ltype == TYCHAR)
        !          1890:                {
        !          1891:                        lcon.ci = cmpstr(lp->constblock.Const.ccp,
        !          1892:                            rp->constblock.Const.ccp,
        !          1893:                            lp->constblock.vleng->constblock.Const.ci,
        !          1894:                            rp->constblock.vleng->constblock.Const.ci);
        !          1895:                        rcon.ci = 0;
        !          1896:                        mtype = tyint;
        !          1897:                }
        !          1898:                else    {
        !          1899:                        mtype = maxtype(ltype, rtype);
        !          1900:                        consconv(mtype, &lcon, ltype, &(lp->constblock.Const) );
        !          1901:                        consconv(mtype, &rcon, rtype, &(rp->constblock.Const) );
        !          1902:                }
        !          1903:                consbinop(opcode, mtype, &(p->Const), &lcon, &rcon);
        !          1904:                break;
        !          1905:        }
        !          1906: 
        !          1907:        frexpr(e);
        !          1908:        return( (expptr) p );
        !          1909: }
        !          1910: 
        !          1911: 
        !          1912: 
        !          1913: /* assign constant l = r , doing coercion */
        !          1914: 
        !          1915: consconv(lt, lv, rt, rv)
        !          1916: int lt, rt;
        !          1917: register union Constant *lv, *rv;
        !          1918: {
        !          1919:        switch(lt)
        !          1920:        {
        !          1921:        case TYCHAR:
        !          1922:                *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
        !          1923:                break;
        !          1924: 
        !          1925:        case TYSHORT:
        !          1926:        case TYLONG:
        !          1927:                if(rt == TYCHAR)
        !          1928:                        lv->ci = rv->ccp[0];
        !          1929:                else if( ISINT(rt) )
        !          1930:                        lv->ci = rv->ci;
        !          1931:                else    lv->ci = rv->cd[0];
        !          1932:                break;
        !          1933: 
        !          1934:        case TYCOMPLEX:
        !          1935:        case TYDCOMPLEX:
        !          1936:                switch(rt)
        !          1937:                {
        !          1938:                case TYSHORT:
        !          1939:                case TYLONG:
        !          1940:                        /* fall through and do real assignment of
        !          1941:                                   first element
        !          1942:                                */
        !          1943:                case TYREAL:
        !          1944:                case TYDREAL:
        !          1945:                        lv->cd[1] = 0; 
        !          1946:                        break;
        !          1947:                case TYCOMPLEX:
        !          1948:                case TYDCOMPLEX:
        !          1949:                        lv->cd[1] = rv->cd[1]; 
        !          1950:                        break;
        !          1951:                }
        !          1952: 
        !          1953:        case TYREAL:
        !          1954:        case TYDREAL:
        !          1955:                if( ISINT(rt) )
        !          1956:                        lv->cd[0] = rv->ci;
        !          1957:                else    lv->cd[0] = rv->cd[0];
        !          1958:                break;
        !          1959: 
        !          1960:        case TYLOGICAL:
        !          1961:                lv->ci = rv->ci;
        !          1962:                break;
        !          1963:        }
        !          1964: }
        !          1965: 
        !          1966: 
        !          1967: 
        !          1968: consnegop(p)
        !          1969: register Constp p;
        !          1970: {
        !          1971:        switch(p->vtype)
        !          1972:        {
        !          1973:        case TYSHORT:
        !          1974:        case TYLONG:
        !          1975:                p->Const.ci = - p->Const.ci;
        !          1976:                break;
        !          1977: 
        !          1978:        case TYCOMPLEX:
        !          1979:        case TYDCOMPLEX:
        !          1980:                p->Const.cd[1] = - p->Const.cd[1];
        !          1981:                /* fall through and do the real parts */
        !          1982:        case TYREAL:
        !          1983:        case TYDREAL:
        !          1984:                p->Const.cd[0] = - p->Const.cd[0];
        !          1985:                break;
        !          1986:        default:
        !          1987:                badtype("consnegop", p->vtype);
        !          1988:        }
        !          1989: }
        !          1990: 
        !          1991: 
        !          1992: 
        !          1993: LOCAL conspower(powp, ap, n)
        !          1994: register union Constant *powp;
        !          1995: Constp ap;
        !          1996: ftnint n;
        !          1997: {
        !          1998:        register int type;
        !          1999:        union Constant x;
        !          2000: 
        !          2001:        switch(type = ap->vtype)        /* pow = 1 */ 
        !          2002:        {
        !          2003:        case TYSHORT:
        !          2004:        case TYLONG:
        !          2005:                powp->ci = 1;
        !          2006:                break;
        !          2007:        case TYCOMPLEX:
        !          2008:        case TYDCOMPLEX:
        !          2009:                powp->cd[1] = 0;
        !          2010:        case TYREAL:
        !          2011:        case TYDREAL:
        !          2012:                powp->cd[0] = 1;
        !          2013:                break;
        !          2014:        default:
        !          2015:                badtype("conspower", type);
        !          2016:        }
        !          2017: 
        !          2018:        if(n == 0)
        !          2019:                return;
        !          2020:        if(n < 0)
        !          2021:        {
        !          2022:                if( ISINT(type) )
        !          2023:                {
        !          2024:                        err("integer ** negative power ");
        !          2025:                        return;
        !          2026:                }
        !          2027:                n = - n;
        !          2028:                consbinop(OPSLASH, type, &x, powp, &(ap->Const));
        !          2029:        }
        !          2030:        else
        !          2031:                consbinop(OPSTAR, type, &x, powp, &(ap->Const));
        !          2032: 
        !          2033:        for( ; ; )
        !          2034:        {
        !          2035:                if(n & 01)
        !          2036:                        consbinop(OPSTAR, type, powp, powp, &x);
        !          2037:                if(n >>= 1)
        !          2038:                        consbinop(OPSTAR, type, &x, &x, &x);
        !          2039:                else
        !          2040:                        break;
        !          2041:        }
        !          2042: }
        !          2043: 
        !          2044: 
        !          2045: 
        !          2046: /* do constant operation cp = a op b */
        !          2047: 
        !          2048: 
        !          2049: LOCAL consbinop(opcode, type, cp, ap, bp)
        !          2050: int opcode, type;
        !          2051: register union Constant *ap, *bp, *cp;
        !          2052: {
        !          2053:        int k;
        !          2054:        double temp;
        !          2055: 
        !          2056:        switch(opcode)
        !          2057:        {
        !          2058:        case OPPLUS:
        !          2059:                switch(type)
        !          2060:                {
        !          2061:                case TYSHORT:
        !          2062:                case TYLONG:
        !          2063:                        cp->ci = ap->ci + bp->ci;
        !          2064:                        break;
        !          2065:                case TYCOMPLEX:
        !          2066:                case TYDCOMPLEX:
        !          2067:                        cp->cd[1] = ap->cd[1] + bp->cd[1];
        !          2068:                case TYREAL:
        !          2069:                case TYDREAL:
        !          2070:                        cp->cd[0] = ap->cd[0] + bp->cd[0];
        !          2071:                        break;
        !          2072:                }
        !          2073:                break;
        !          2074: 
        !          2075:        case OPMINUS:
        !          2076:                switch(type)
        !          2077:                {
        !          2078:                case TYSHORT:
        !          2079:                case TYLONG:
        !          2080:                        cp->ci = ap->ci - bp->ci;
        !          2081:                        break;
        !          2082:                case TYCOMPLEX:
        !          2083:                case TYDCOMPLEX:
        !          2084:                        cp->cd[1] = ap->cd[1] - bp->cd[1];
        !          2085:                case TYREAL:
        !          2086:                case TYDREAL:
        !          2087:                        cp->cd[0] = ap->cd[0] - bp->cd[0];
        !          2088:                        break;
        !          2089:                }
        !          2090:                break;
        !          2091: 
        !          2092:        case OPSTAR:
        !          2093:                switch(type)
        !          2094:                {
        !          2095:                case TYSHORT:
        !          2096:                case TYLONG:
        !          2097:                        cp->ci = ap->ci * bp->ci;
        !          2098:                        break;
        !          2099:                case TYREAL:
        !          2100:                case TYDREAL:
        !          2101:                        cp->cd[0] = ap->cd[0] * bp->cd[0];
        !          2102:                        break;
        !          2103:                case TYCOMPLEX:
        !          2104:                case TYDCOMPLEX:
        !          2105:                        temp = ap->cd[0] * bp->cd[0] -
        !          2106:                            ap->cd[1] * bp->cd[1] ;
        !          2107:                        cp->cd[1] = ap->cd[0] * bp->cd[1] +
        !          2108:                            ap->cd[1] * bp->cd[0] ;
        !          2109:                        cp->cd[0] = temp;
        !          2110:                        break;
        !          2111:                }
        !          2112:                break;
        !          2113:        case OPSLASH:
        !          2114:                switch(type)
        !          2115:                {
        !          2116:                case TYSHORT:
        !          2117:                case TYLONG:
        !          2118:                        cp->ci = ap->ci / bp->ci;
        !          2119:                        break;
        !          2120:                case TYREAL:
        !          2121:                case TYDREAL:
        !          2122:                        cp->cd[0] = ap->cd[0] / bp->cd[0];
        !          2123:                        break;
        !          2124:                case TYCOMPLEX:
        !          2125:                case TYDCOMPLEX:
        !          2126:                        zdiv(cp,ap,bp);
        !          2127:                        break;
        !          2128:                }
        !          2129:                break;
        !          2130: 
        !          2131:        case OPMOD:
        !          2132:                if( ISINT(type) )
        !          2133:                {
        !          2134:                        cp->ci = ap->ci % bp->ci;
        !          2135:                        break;
        !          2136:                }
        !          2137:                else
        !          2138:                        fatal("inline mod of noninteger");
        !          2139: 
        !          2140:        default:          /* relational ops */
        !          2141:                switch(type)
        !          2142:                {
        !          2143:                case TYSHORT:
        !          2144:                case TYLONG:
        !          2145:                        if(ap->ci < bp->ci)
        !          2146:                                k = -1;
        !          2147:                        else if(ap->ci == bp->ci)
        !          2148:                                k = 0;
        !          2149:                        else    k = 1;
        !          2150:                        break;
        !          2151:                case TYREAL:
        !          2152:                case TYDREAL:
        !          2153:                        if(ap->cd[0] < bp->cd[0])
        !          2154:                                k = -1;
        !          2155:                        else if(ap->cd[0] == bp->cd[0])
        !          2156:                                k = 0;
        !          2157:                        else    k = 1;
        !          2158:                        break;
        !          2159:                case TYCOMPLEX:
        !          2160:                case TYDCOMPLEX:
        !          2161:                        if(ap->cd[0] == bp->cd[0] &&
        !          2162:                            ap->cd[1] == bp->cd[1] )
        !          2163:                                k = 0;
        !          2164:                        else    k = 1;
        !          2165:                        break;
        !          2166:                }
        !          2167: 
        !          2168:                switch(opcode)
        !          2169:                {
        !          2170:                case OPEQ:
        !          2171:                        cp->ci = (k == 0);
        !          2172:                        break;
        !          2173:                case OPNE:
        !          2174:                        cp->ci = (k != 0);
        !          2175:                        break;
        !          2176:                case OPGT:
        !          2177:                        cp->ci = (k == 1);
        !          2178:                        break;
        !          2179:                case OPLT:
        !          2180:                        cp->ci = (k == -1);
        !          2181:                        break;
        !          2182:                case OPGE:
        !          2183:                        cp->ci = (k >= 0);
        !          2184:                        break;
        !          2185:                case OPLE:
        !          2186:                        cp->ci = (k <= 0);
        !          2187:                        break;
        !          2188:                }
        !          2189:                break;
        !          2190:        }
        !          2191: }
        !          2192: 
        !          2193: 
        !          2194: 
        !          2195: 
        !          2196: conssgn(p)
        !          2197: register expptr p;
        !          2198: {
        !          2199:        if( ! ISCONST(p) )
        !          2200:                fatal( "sgn(nonconstant)" );
        !          2201: 
        !          2202:        switch(p->headblock.vtype)
        !          2203:        {
        !          2204:        case TYSHORT:
        !          2205:        case TYLONG:
        !          2206:                if(p->constblock.Const.ci > 0) return(1);
        !          2207:                if(p->constblock.Const.ci < 0) return(-1);
        !          2208:                return(0);
        !          2209: 
        !          2210:        case TYREAL:
        !          2211:        case TYDREAL:
        !          2212:                if(p->constblock.Const.cd[0] > 0) return(1);
        !          2213:                if(p->constblock.Const.cd[0] < 0) return(-1);
        !          2214:                return(0);
        !          2215: 
        !          2216:        case TYCOMPLEX:
        !          2217:        case TYDCOMPLEX:
        !          2218:                return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
        !          2219: 
        !          2220:        default:
        !          2221:                badtype( "conssgn", p->constblock.vtype);
        !          2222:        }
        !          2223:        /* NOTREACHED */
        !          2224: }
        !          2225: 
        !          2226: char *powint[ ] = { 
        !          2227:        "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
        !          2228: 
        !          2229: 
        !          2230: LOCAL expptr mkpower(p)
        !          2231: register expptr p;
        !          2232: {
        !          2233:        register expptr q, lp, rp;
        !          2234:        int ltype, rtype, mtype;
        !          2235: 
        !          2236:        lp = p->exprblock.leftp;
        !          2237:        rp = p->exprblock.rightp;
        !          2238:        ltype = lp->headblock.vtype;
        !          2239:        rtype = rp->headblock.vtype;
        !          2240: 
        !          2241:        if(ISICON(rp))
        !          2242:        {
        !          2243:                if(rp->constblock.Const.ci == 0)
        !          2244:                {
        !          2245:                        frexpr(p);
        !          2246:                        if( ISINT(ltype) )
        !          2247:                                return( ICON(1) );
        !          2248:                        else
        !          2249:                                return( (expptr) putconst( mkconv(ltype, ICON(1))) );
        !          2250:                }
        !          2251:                if(rp->constblock.Const.ci < 0)
        !          2252:                {
        !          2253:                        if( ISINT(ltype) )
        !          2254:                        {
        !          2255:                                frexpr(p);
        !          2256:                                err("integer**negative");
        !          2257:                                return( errnode() );
        !          2258:                        }
        !          2259:                        rp->constblock.Const.ci = - rp->constblock.Const.ci;
        !          2260:                        p->exprblock.leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
        !          2261:                }
        !          2262:                if(rp->constblock.Const.ci == 1)
        !          2263:                {
        !          2264:                        frexpr(rp);
        !          2265:                        free( (charptr) p );
        !          2266:                        return(lp);
        !          2267:                }
        !          2268: 
        !          2269:                if( ONEOF(ltype, MSKINT|MSKREAL) )
        !          2270:                {
        !          2271:                        p->exprblock.vtype = ltype;
        !          2272:                        return(p);
        !          2273:                }
        !          2274:        }
        !          2275:        if( ISINT(rtype) )
        !          2276:        {
        !          2277:                if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
        !          2278:                        q = call2(TYSHORT, "pow_hh", lp, rp);
        !          2279:                else    {
        !          2280:                        if(ltype == TYSHORT)
        !          2281:                        {
        !          2282:                                ltype = TYLONG;
        !          2283:                                lp = mkconv(TYLONG,lp);
        !          2284:                        }
        !          2285:                        q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
        !          2286:                }
        !          2287:        }
        !          2288:        else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
        !          2289:                q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
        !          2290:        else    {
        !          2291:                q  = call2(TYDCOMPLEX, "pow_zz",
        !          2292:                    mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
        !          2293:                if(mtype == TYCOMPLEX)
        !          2294:                        q = mkconv(TYCOMPLEX, q);
        !          2295:        }
        !          2296:        free( (charptr) p );
        !          2297:        return(q);
        !          2298: }
        !          2299: 
        !          2300: 
        !          2301: 
        !          2302: /* Complex Division.  Same code as in Runtime Library
        !          2303: */
        !          2304: 
        !          2305: struct dcomplex { 
        !          2306:        double dreal, dimag; 
        !          2307: };
        !          2308: 
        !          2309: 
        !          2310: LOCAL zdiv(c, a, b)
        !          2311: register struct dcomplex *a, *b, *c;
        !          2312: {
        !          2313:        double ratio, den;
        !          2314:        double abr, abi;
        !          2315: 
        !          2316:        if( (abr = b->dreal) < 0.)
        !          2317:                abr = - abr;
        !          2318:        if( (abi = b->dimag) < 0.)
        !          2319:                abi = - abi;
        !          2320:        if( abr <= abi )
        !          2321:        {
        !          2322:                if(abi == 0)
        !          2323:                        fatal("complex division by zero");
        !          2324:                ratio = b->dreal / b->dimag ;
        !          2325:                den = b->dimag * (1 + ratio*ratio);
        !          2326:                c->dreal = (a->dreal*ratio + a->dimag) / den;
        !          2327:                c->dimag = (a->dimag*ratio - a->dreal) / den;
        !          2328:        }
        !          2329: 
        !          2330:        else
        !          2331:        {
        !          2332:                ratio = b->dimag / b->dreal ;
        !          2333:                den = b->dreal * (1 + ratio*ratio);
        !          2334:                c->dreal = (a->dreal + a->dimag*ratio) / den;
        !          2335:                c->dimag = (a->dimag - a->dreal*ratio) / den;
        !          2336:        }
        !          2337: 
        !          2338: }

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