Return to expr.c CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / f77

Annotation of 3BSD/cmd/f77/expr.c, revision 1.1

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

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