Return to expr.c CVS log

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

Annotation of 43BSDTahoe/usr.bin/f77/f77.tahoe/f77pass1/expr.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Copyright (c) 1980 Regents of the University of California.
        !             3:  * All rights reserved.  The Berkeley software License Agreement
        !             4:  * specifies the terms and conditions for redistribution.
        !             5:  */
        !             6: 
        !             7: #ifndef lint
        !             8: static char *sccsid[] = "@(#)expr.c    5.3 (Berkeley) 6/23/85";
        !             9: #endif not lint
        !            10: 
        !            11: /*
        !            12:  * expr.c
        !            13:  *
        !            14:  * Routines for handling expressions, f77 compiler pass 1.
        !            15:  *
        !            16:  * University of Utah CS Dept modification history:
        !            17:  *
        !            18:  * $Log:       expr.c,v $
        !            19:  * Revision 1.3  86/02/26  17:13:37  rcs
        !            20:  * Correct COFR 411.
        !            21:  * P. Wong
        !            22:  * 
        !            23:  * Revision 3.16  85/06/21  16:38:09  donn
        !            24:  * The fix to mkprim() didn't handle null substring parameters (sigh).
        !            25:  * 
        !            26:  * Revision 3.15  85/06/04  04:37:03  donn
        !            27:  * Changed mkprim() to force substring parameters to be integral types.
        !            28:  * 
        !            29:  * Revision 3.14  85/06/04  03:41:52  donn
        !            30:  * Change impldcl() to handle functions of type 'undefined'.
        !            31:  * 
        !            32:  * Revision 3.13  85/05/06  23:14:55  donn
        !            33:  * Changed mkconv() so that it calls mkaltemp() instead of mktemp() to get
        !            34:  * a temporary when converting character strings to integers; previously we
        !            35:  * were having problems because mkconv() was called after tempalloc().
        !            36:  * 
        !            37:  * Revision 3.12  85/03/18  08:07:47  donn
        !            38:  * Fixes to help out with short integers -- if integers are by default short,
        !            39:  * then so are constants; and if addresses can't be stored in shorts, complain.
        !            40:  * 
        !            41:  * Revision 3.11  85/03/16  22:31:27  donn
        !            42:  * Added hack to mkconv() to allow character values of length > 1 to be
        !            43:  * converted to numeric types, for Helge Skrivervik.  Note that this does
        !            44:  * not affect use of the intrinsic ichar() conversion.
        !            45:  * 
        !            46:  * Revision 3.10  85/01/15  21:06:47  donn
        !            47:  * Changed mkconv() to comment on implicit conversions; added intrconv() for
        !            48:  * use with explicit conversions by intrinsic functions.
        !            49:  * 
        !            50:  * Revision 3.9  85/01/11  21:05:49  donn
        !            51:  * Added changes to implement SAVE statements.
        !            52:  * 
        !            53:  * Revision 3.8  84/12/17  02:21:06  donn
        !            54:  * Added a test to prevent constant folding from being done on expressions
        !            55:  * whose type is not known at that point in mkexpr().
        !            56:  * 
        !            57:  * Revision 3.7  84/12/11  21:14:17  donn
        !            58:  * Removed obnoxious 'excess precision' warning.
        !            59:  * 
        !            60:  * Revision 3.6  84/11/23  01:00:36  donn
        !            61:  * Added code to trim excess precision from single-precision constants, and
        !            62:  * to warn the user when this occurs.
        !            63:  * 
        !            64:  * Revision 3.5  84/11/23  00:10:39  donn
        !            65:  * Changed stfcall() to remark on argument type clashes in 'calls' to
        !            66:  * statement functions.
        !            67:  * 
        !            68:  * Revision 3.4  84/11/22  21:21:17  donn
        !            69:  * Fixed bug in fix to mkexpr() that caused IMPLICIT to affect intrinsics.
        !            70:  * 
        !            71:  * Revision 3.3  84/11/12  18:26:14  donn
        !            72:  * Shuffled some code around so that the compiler remembers to free some vleng
        !            73:  * structures which used to just sit around.
        !            74:  * 
        !            75:  * Revision 3.2  84/10/16  19:24:15  donn
        !            76:  * Fix for Peter Montgomery's bug with -C and invalid subscripts -- prevent
        !            77:  * core dumps by replacing bad subscripts with good ones.
        !            78:  * 
        !            79:  * Revision 3.1  84/10/13  01:31:32  donn
        !            80:  * Merged Jerry Berkman's version into mine.
        !            81:  * 
        !            82:  * Revision 2.7  84/09/27  15:42:52  donn
        !            83:  * The last fix for multiplying undeclared variables by 0 isn't sufficient,
        !            84:  * since the type of the 0 may not be the (implicit) type of the variable.
        !            85:  * I added a hack to check the implicit type of implicitly declared
        !            86:  * variables...
        !            87:  * 
        !            88:  * Revision 2.6  84/09/14  19:34:03  donn
        !            89:  * Problem noted by Mike Vevea -- mkexpr will sometimes attempt to convert
        !            90:  * 0 to type UNKNOWN, which is illegal.  Fix is to use native type instead.
        !            91:  * Not sure how correct (or important) this is...
        !            92:  * 
        !            93:  * Revision 2.5  84/08/05  23:05:27  donn
        !            94:  * Added fixes to prevent fixexpr() from slicing and dicing complex conversions
        !            95:  * with two operands.
        !            96:  * 
        !            97:  * Revision 2.4  84/08/05  17:34:48  donn
        !            98:  * Added an optimization to mklhs() to detect substrings of the form ch(i:i)
        !            99:  * and assign constant length 1 to them.
        !           100:  * 
        !           101:  * Revision 2.3  84/07/19  19:38:33  donn
        !           102:  * Added a typecast to the last fix.  Somehow I missed it the first time...
        !           103:  * 
        !           104:  * Revision 2.2  84/07/19  17:19:57  donn
        !           105:  * Caused OPPAREN expressions to inherit the length of their operands, so
        !           106:  * that parenthesized character expressions work correctly.
        !           107:  * 
        !           108:  * Revision 2.1  84/07/19  12:03:02  donn
        !           109:  * Changed comment headers for UofU.
        !           110:  * 
        !           111:  * Revision 1.2  84/04/06  20:12:17  donn
        !           112:  * Fixed bug which caused programs with mixed-type multiplications involving
        !           113:  * the constant 0 to choke the compiler.
        !           114:  * 
        !           115:  */
        !           116: 
        !           117: #include "defs.h"
        !           118: 
        !           119: 
        !           120: /* little routines to create constant blocks */
        !           121: 
        !           122: Constp mkconst(t)
        !           123: register int t;
        !           124: {
        !           125: register Constp p;
        !           126: 
        !           127: p = ALLOC(Constblock);
        !           128: p->tag = TCONST;
        !           129: p->vtype = t;
        !           130: return(p);
        !           131: }
        !           132: 
        !           133: 
        !           134: expptr mklogcon(l)
        !           135: register int l;
        !           136: {
        !           137: register Constp  p;
        !           138: 
        !           139: p = mkconst(TYLOGICAL);
        !           140: p->const.ci = l;
        !           141: return( (expptr) p );
        !           142: }
        !           143: 
        !           144: 
        !           145: 
        !           146: expptr mkintcon(l)
        !           147: ftnint l;
        !           148: {
        !           149: register Constp p;
        !           150: int usetype;
        !           151: 
        !           152: if(tyint == TYSHORT)
        !           153:   {
        !           154:     short s = l;
        !           155:     if(l != s)
        !           156:       usetype = TYLONG;
        !           157:     else
        !           158:       usetype = TYSHORT;
        !           159:   }
        !           160: else
        !           161:   usetype = tyint;
        !           162: p = mkconst(usetype);
        !           163: p->const.ci = l;
        !           164: return( (expptr) p );
        !           165: }
        !           166: 
        !           167: 
        !           168: 
        !           169: expptr mkaddcon(l)
        !           170: register int l;
        !           171: {
        !           172: register Constp p;
        !           173: 
        !           174: p = mkconst(TYADDR);
        !           175: p->const.ci = l;
        !           176: return( (expptr) p );
        !           177: }
        !           178: 
        !           179: 
        !           180: 
        !           181: expptr mkrealcon(t, d)
        !           182: register int t;
        !           183: double d;
        !           184: {
        !           185: register Constp p;
        !           186: 
        !           187: p = mkconst(t);
        !           188: p->const.cd[0] = d;
        !           189: return( (expptr) p );
        !           190: }
        !           191: 
        !           192: expptr mkbitcon(shift, leng, s)
        !           193: int shift;
        !           194: register int leng;
        !           195: register char *s;
        !           196: {
        !           197:   Constp p;
        !           198:   register int i, j, k;
        !           199:   register char *bp;
        !           200:   int size;
        !           201: 
        !           202:   size = (shift*leng + BYTESIZE -1)/BYTESIZE;
        !           203:   bp = (char *) ckalloc(size);
        !           204: 
        !           205:   i = 0;
        !           206: 
        !           207: #if (HERE == PDP11 || HERE == VAX)
        !           208:   j = 0;
        !           209: #else
        !           210:   j = size;
        !           211: #endif
        !           212: 
        !           213:   k = 0;
        !           214: 
        !           215:   while (leng > 0)
        !           216:     {
        !           217:       k |= (hextoi(s[--leng]) << i);
        !           218:       i += shift;
        !           219:       if (i >= BYTESIZE)
        !           220:        {
        !           221: #if (HERE == PDP11 || HERE == VAX)
        !           222:          bp[j++] = k & MAXBYTE;
        !           223: #else
        !           224:          bp[--j] = k & MAXBYTE;
        !           225: #endif
        !           226:          k = k >> BYTESIZE;
        !           227:          i -= BYTESIZE;
        !           228:        }
        !           229:     }
        !           230: 
        !           231:   if (k != 0)
        !           232: #if (HERE == PDP11 || HERE == VAX)
        !           233:     bp[j++] = k;
        !           234: #else
        !           235:     bp[--j] = k;
        !           236: #endif
        !           237: 
        !           238:   p = mkconst(TYBITSTR);
        !           239:   p->vleng = ICON(size);
        !           240:   p->const.ccp = bp;
        !           241: 
        !           242:   return ((expptr) p);
        !           243: }
        !           244: 
        !           245: 
        !           246: 
        !           247: expptr mkstrcon(l,v)
        !           248: int l;
        !           249: register char *v;
        !           250: {
        !           251: register Constp p;
        !           252: register char *s;
        !           253: 
        !           254: p = mkconst(TYCHAR);
        !           255: p->vleng = ICON(l);
        !           256: p->const.ccp = s = (char *) ckalloc(l);
        !           257: while(--l >= 0)
        !           258:        *s++ = *v++;
        !           259: return( (expptr) p );
        !           260: }
        !           261: 
        !           262: 
        !           263: expptr mkcxcon(realp,imagp)
        !           264: register expptr realp, imagp;
        !           265: {
        !           266: int rtype, itype;
        !           267: register Constp p;
        !           268: 
        !           269: rtype = realp->headblock.vtype;
        !           270: itype = imagp->headblock.vtype;
        !           271: 
        !           272: if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
        !           273:        {
        !           274:        p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX);
        !           275:        if( ISINT(rtype) )
        !           276:                p->const.cd[0] = realp->constblock.const.ci;
        !           277:        else    p->const.cd[0] = realp->constblock.const.cd[0];
        !           278:        if( ISINT(itype) )
        !           279:                p->const.cd[1] = imagp->constblock.const.ci;
        !           280:        else    p->const.cd[1] = imagp->constblock.const.cd[0];
        !           281:        }
        !           282: else
        !           283:        {
        !           284:        err("invalid complex constant");
        !           285:        p = (Constp) errnode();
        !           286:        }
        !           287: 
        !           288: frexpr(realp);
        !           289: frexpr(imagp);
        !           290: return( (expptr) p );
        !           291: }
        !           292: 
        !           293: 
        !           294: expptr errnode()
        !           295: {
        !           296: struct Errorblock *p;
        !           297: p = ALLOC(Errorblock);
        !           298: p->tag = TERROR;
        !           299: p->vtype = TYERROR;
        !           300: return( (expptr) p );
        !           301: }
        !           302: 
        !           303: 
        !           304: 
        !           305: 
        !           306: 
        !           307: expptr mkconv(t, p)
        !           308: register int t;
        !           309: register expptr p;
        !           310: {
        !           311: register expptr q;
        !           312: Addrp r, s;
        !           313: register int pt;
        !           314: expptr opconv();
        !           315: 
        !           316: if(t==TYUNKNOWN || t==TYERROR)
        !           317:        badtype("mkconv", t);
        !           318: pt = p->headblock.vtype;
        !           319: if(t == pt)
        !           320:        return(p);
        !           321: 
        !           322: if( pt == TYCHAR && ISNUMERIC(t) )
        !           323:        {
        !           324:        warn("implicit conversion of character to numeric type");
        !           325: 
        !           326:        /*
        !           327:         * Ugly kluge to copy character values into numerics.
        !           328:         */
        !           329:        s = mkaltemp(t, ENULL);
        !           330:        r = (Addrp) cpexpr(s);
        !           331:        r->vtype = TYCHAR;
        !           332:        r->varleng = typesize[t];
        !           333:        r->vleng = mkintcon(r->varleng);
        !           334:        q = mkexpr(OPASSIGN, r, p);
        !           335:        q = mkexpr(OPCOMMA, q, s);
        !           336:        return(q);
        !           337:        }
        !           338: 
        !           339: #if SZADDR > SZSHORT
        !           340: if( pt == TYADDR && t == TYSHORT)
        !           341:        {
        !           342:        err("insufficient precision to hold address type");
        !           343:        return( errnode() );
        !           344:        }
        !           345: #endif
        !           346: if( pt == TYADDR && ISNUMERIC(t) )
        !           347:        warn("implicit conversion of address to numeric type");
        !           348: 
        !           349: if( ISCONST(p) && pt!=TYADDR)
        !           350:        {
        !           351:        q = (expptr) mkconst(t);
        !           352:        consconv(t, &(q->constblock.const),
        !           353:                p->constblock.vtype, &(p->constblock.const) );
        !           354:        frexpr(p);
        !           355:        }
        !           356: #if TARGET == PDP11
        !           357: else if(ISINT(t) && pt==TYCHAR)
        !           358:        {
        !           359:        q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
        !           360:        if(t == TYLONG)
        !           361:                q = opconv(q, TYLONG);
        !           362:        }
        !           363: #endif
        !           364: else
        !           365:        q = opconv(p, t);
        !           366: 
        !           367: if(t == TYCHAR)
        !           368:        q->constblock.vleng = ICON(1);
        !           369: return(q);
        !           370: }
        !           371: 
        !           372: 
        !           373: 
        !           374: /* intrinsic conversions */
        !           375: expptr intrconv(t, p)
        !           376: register int t;
        !           377: register expptr p;
        !           378: {
        !           379: register expptr q;
        !           380: register int pt;
        !           381: expptr opconv();
        !           382: 
        !           383: if(t==TYUNKNOWN || t==TYERROR)
        !           384:        badtype("intrconv", t);
        !           385: pt = p->headblock.vtype;
        !           386: if(t == pt)
        !           387:        return(p);
        !           388: 
        !           389: else if( ISCONST(p) && pt!=TYADDR)
        !           390:        {
        !           391:        q = (expptr) mkconst(t);
        !           392:        consconv(t, &(q->constblock.const),
        !           393:                p->constblock.vtype, &(p->constblock.const) );
        !           394:        frexpr(p);
        !           395:        }
        !           396: #if TARGET == PDP11
        !           397: else if(ISINT(t) && pt==TYCHAR)
        !           398:        {
        !           399:        q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
        !           400:        if(t == TYLONG)
        !           401:                q = opconv(q, TYLONG);
        !           402:        }
        !           403: #endif
        !           404: else
        !           405:        q = opconv(p, t);
        !           406: 
        !           407: if(t == TYCHAR)
        !           408:        q->constblock.vleng = ICON(1);
        !           409: return(q);
        !           410: }
        !           411: 
        !           412: 
        !           413: 
        !           414: expptr opconv(p, t)
        !           415: expptr p;
        !           416: int t;
        !           417: {
        !           418: register expptr q;
        !           419: 
        !           420: q = mkexpr(OPCONV, p, PNULL);
        !           421: q->headblock.vtype = t;
        !           422: return(q);
        !           423: }
        !           424: 
        !           425: 
        !           426: 
        !           427: expptr addrof(p)
        !           428: expptr p;
        !           429: {
        !           430: return( mkexpr(OPADDR, p, PNULL) );
        !           431: }
        !           432: 
        !           433: 
        !           434: 
        !           435: tagptr cpexpr(p)
        !           436: register tagptr p;
        !           437: {
        !           438: register tagptr e;
        !           439: int tag;
        !           440: register chainp ep, pp;
        !           441: tagptr cpblock();
        !           442: 
        !           443: static int blksize[ ] =
        !           444:        {       0,
        !           445:                sizeof(struct Nameblock),
        !           446:                sizeof(struct Constblock),
        !           447:                sizeof(struct Exprblock),
        !           448:                sizeof(struct Addrblock),
        !           449:                sizeof(struct Tempblock),
        !           450:                sizeof(struct Primblock),
        !           451:                sizeof(struct Listblock),
        !           452:                sizeof(struct Errorblock)
        !           453:        };
        !           454: 
        !           455: if(p == NULL)
        !           456:        return(NULL);
        !           457: 
        !           458: if( (tag = p->tag) == TNAME)
        !           459:        return(p);
        !           460: 
        !           461: e = cpblock( blksize[p->tag] , p);
        !           462: 
        !           463: switch(tag)
        !           464:        {
        !           465:        case TCONST:
        !           466:                if(e->constblock.vtype == TYCHAR)
        !           467:                        {
        !           468:                        e->constblock.const.ccp =
        !           469:                                copyn(1+strlen(e->constblock.const.ccp),
        !           470:                                        e->constblock.const.ccp);
        !           471:                        e->constblock.vleng =
        !           472:                                (expptr) cpexpr(e->constblock.vleng);
        !           473:                        }
        !           474:        case TERROR:
        !           475:                break;
        !           476: 
        !           477:        case TEXPR:
        !           478:                e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
        !           479:                e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
        !           480:                break;
        !           481: 
        !           482:        case TLIST:
        !           483:                if(pp = p->listblock.listp)
        !           484:                        {
        !           485:                        ep = e->listblock.listp =
        !           486:                                mkchain( cpexpr(pp->datap), CHNULL);
        !           487:                        for(pp = pp->nextp ; pp ; pp = pp->nextp)
        !           488:                                ep = ep->nextp =
        !           489:                                        mkchain( cpexpr(pp->datap), CHNULL);
        !           490:                        }
        !           491:                break;
        !           492: 
        !           493:        case TADDR:
        !           494:                e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
        !           495:                e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
        !           496:                e->addrblock.istemp = NO;
        !           497:                break;
        !           498: 
        !           499:        case TTEMP:
        !           500:                e->tempblock.vleng = (expptr)  cpexpr(e->tempblock.vleng);
        !           501:                e->tempblock.istemp = NO;
        !           502:                break;
        !           503: 
        !           504:        case TPRIM:
        !           505:                e->primblock.argsp = (struct Listblock *)
        !           506:                                        cpexpr(e->primblock.argsp);
        !           507:                e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
        !           508:                e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
        !           509:                break;
        !           510: 
        !           511:        default:
        !           512:                badtag("cpexpr", tag);
        !           513:        }
        !           514: 
        !           515: return(e);
        !           516: }
        !           517: 
        !           518: frexpr(p)
        !           519: register tagptr p;
        !           520: {
        !           521: register chainp q;
        !           522: 
        !           523: if(p == NULL)
        !           524:        return;
        !           525: 
        !           526: switch(p->tag)
        !           527:        {
        !           528:        case TCONST:
        !           529:                switch (p->constblock.vtype)
        !           530:                        {
        !           531:                        case TYBITSTR:
        !           532:                        case TYCHAR:
        !           533:                        case TYHOLLERITH:
        !           534:                                free( (charptr) (p->constblock.const.ccp) );
        !           535:                                frexpr(p->constblock.vleng);
        !           536:                        }
        !           537:                break;
        !           538: 
        !           539:        case TADDR:
        !           540:                if (!optimflag && p->addrblock.istemp)
        !           541:                        {
        !           542:                        frtemp(p);
        !           543:                        return;
        !           544:                        }
        !           545:                frexpr(p->addrblock.vleng);
        !           546:                frexpr(p->addrblock.memoffset);
        !           547:                break;
        !           548: 
        !           549:        case TTEMP:
        !           550:                frexpr(p->tempblock.vleng);
        !           551:                break;
        !           552: 
        !           553:        case TERROR:
        !           554:                break;
        !           555: 
        !           556:        case TNAME:
        !           557:                return;
        !           558: 
        !           559:        case TPRIM:
        !           560:                frexpr(p->primblock.argsp);
        !           561:                frexpr(p->primblock.fcharp);
        !           562:                frexpr(p->primblock.lcharp);
        !           563:                break;
        !           564: 
        !           565:        case TEXPR:
        !           566:                frexpr(p->exprblock.leftp);
        !           567:                if(p->exprblock.rightp)
        !           568:                        frexpr(p->exprblock.rightp);
        !           569:                break;
        !           570: 
        !           571:        case TLIST:
        !           572:                for(q = p->listblock.listp ; q ; q = q->nextp)
        !           573:                        frexpr(q->datap);
        !           574:                frchain( &(p->listblock.listp) );
        !           575:                break;
        !           576: 
        !           577:        default:
        !           578:                badtag("frexpr", p->tag);
        !           579:        }
        !           580: 
        !           581: free( (charptr) p );
        !           582: }
        !           583: 
        !           584: /* fix up types in expression; replace subtrees and convert
        !           585:    names to address blocks */
        !           586: 
        !           587: expptr fixtype(p)
        !           588: register tagptr p;
        !           589: {
        !           590: 
        !           591: if(p == 0)
        !           592:        return(0);
        !           593: 
        !           594: switch(p->tag)
        !           595:        {
        !           596:        case TCONST:
        !           597:                return( (expptr) p );
        !           598: 
        !           599:        case TADDR:
        !           600:                p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
        !           601:                return( (expptr) p);
        !           602: 
        !           603:        case TTEMP:
        !           604:                return( (expptr) p);
        !           605: 
        !           606:        case TERROR:
        !           607:                return( (expptr) p);
        !           608: 
        !           609:        default:
        !           610:                badtag("fixtype", p->tag);
        !           611: 
        !           612:        case TEXPR:
        !           613:                return( fixexpr(p) );
        !           614: 
        !           615:        case TLIST:
        !           616:                return( (expptr) p );
        !           617: 
        !           618:        case TPRIM:
        !           619:                if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
        !           620:                        {
        !           621:                        if(p->primblock.namep->vtype == TYSUBR)
        !           622:                                {
        !           623:                                err("function invocation of subroutine");
        !           624:                                return( errnode() );
        !           625:                                }
        !           626:                        else
        !           627:                                return( mkfunct(p) );
        !           628:                        }
        !           629:                else    return( mklhs(p) );
        !           630:        }
        !           631: }
        !           632: 
        !           633: 
        !           634: 
        !           635: 
        !           636: 
        !           637: /* special case tree transformations and cleanups of expression trees */
        !           638: 
        !           639: expptr fixexpr(p)
        !           640: register Exprp p;
        !           641: {
        !           642: expptr lp;
        !           643: register expptr rp;
        !           644: register expptr q;
        !           645: int opcode, ltype, rtype, ptype, mtype;
        !           646: expptr lconst, rconst;
        !           647: expptr mkpower();
        !           648: 
        !           649: if( ISERROR(p) )
        !           650:        return( (expptr) p );
        !           651: else if(p->tag != TEXPR)
        !           652:        badtag("fixexpr", p->tag);
        !           653: opcode = p->opcode;
        !           654: if (ISCONST(p->leftp))
        !           655:        lconst = (expptr) cpexpr(p->leftp);
        !           656: else
        !           657:        lconst = NULL;
        !           658: if (p->rightp && ISCONST(p->rightp))
        !           659:        rconst = (expptr) cpexpr(p->rightp);
        !           660: else
        !           661:        rconst = NULL;
        !           662: lp = p->leftp = fixtype(p->leftp);
        !           663: ltype = lp->headblock.vtype;
        !           664: if(opcode==OPASSIGN && lp->tag!=TADDR && lp->tag!=TTEMP)
        !           665:        {
        !           666:        err("left side of assignment must be variable");
        !           667:        frexpr(p);
        !           668:        return( errnode() );
        !           669:        }
        !           670: 
        !           671: if(p->rightp)
        !           672:        {
        !           673:        rp = p->rightp = fixtype(p->rightp);
        !           674:        rtype = rp->headblock.vtype;
        !           675:        }
        !           676: else
        !           677:        {
        !           678:        rp = NULL;
        !           679:        rtype = 0;
        !           680:        }
        !           681: 
        !           682: if(ltype==TYERROR || rtype==TYERROR)
        !           683:        {
        !           684:        frexpr(p);
        !           685:        frexpr(lconst);
        !           686:        frexpr(rconst);
        !           687:        return( errnode() );
        !           688:        }
        !           689: 
        !           690: /* force folding if possible */
        !           691: if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
        !           692:        {
        !           693:        q = mkexpr(opcode, lp, rp);
        !           694:        if( ISCONST(q) )
        !           695:                {
        !           696:                frexpr(lconst);
        !           697:                frexpr(rconst);
        !           698:                return(q);
        !           699:                }
        !           700:        free( (charptr) q );    /* constants did not fold */
        !           701:        }
        !           702: 
        !           703: if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
        !           704:        {
        !           705:        frexpr(p);
        !           706:        frexpr(lconst);
        !           707:        frexpr(rconst);
        !           708:        return( errnode() );
        !           709:        }
        !           710: 
        !           711: switch(opcode)
        !           712:        {
        !           713:        case OPCONCAT:
        !           714:                if(p->vleng == NULL)
        !           715:                        p->vleng = mkexpr(OPPLUS,
        !           716:                                cpexpr(lp->headblock.vleng),
        !           717:                                cpexpr(rp->headblock.vleng) );
        !           718:                break;
        !           719: 
        !           720:        case OPASSIGN:
        !           721:        case OPPLUSEQ:
        !           722:        case OPSTAREQ:
        !           723:                if(ltype == rtype)
        !           724:                        break;
        !           725: #if TARGET == VAX
        !           726:                if( ! rconst && ISREAL(ltype) && ISREAL(rtype) )
        !           727:                        break;
        !           728: #endif
        !           729:                if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
        !           730:                        break;
        !           731:                if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
        !           732: #if FAMILY==PCC
        !           733:                    && typesize[ltype]>=typesize[rtype] )
        !           734: #else
        !           735:                    && typesize[ltype]==typesize[rtype] )
        !           736: #endif
        !           737:                        break;
        !           738:                if (rconst)
        !           739:                        {
        !           740:                        p->rightp = fixtype( mkconv(ptype, cpexpr(rconst)) );
        !           741:                        frexpr(rp);
        !           742:                        }
        !           743:                else
        !           744:                        p->rightp = fixtype(mkconv(ptype, rp));
        !           745:                break;
        !           746: 
        !           747:        case OPSLASH:
        !           748:                if( ISCOMPLEX(rtype) )
        !           749:                        {
        !           750:                        p = (Exprp) call2(ptype,
        !           751:                                ptype==TYCOMPLEX? "c_div" : "z_div",
        !           752:                                mkconv(ptype, lp), mkconv(ptype, rp) );
        !           753:                        break;
        !           754:                        }
        !           755:        case OPPLUS:
        !           756:        case OPMINUS:
        !           757:        case OPSTAR:
        !           758:        case OPMOD:
        !           759: #if TARGET == VAX
        !           760:                if(ptype==TYDREAL && ( (ltype==TYREAL && ! lconst ) ||
        !           761:                    (rtype==TYREAL && ! rconst ) ))
        !           762:                        break;
        !           763: #endif
        !           764:                if( ISCOMPLEX(ptype) )
        !           765:                        break;
        !           766:                if(ltype != ptype)
        !           767:                        if (lconst)
        !           768:                                {
        !           769:                                p->leftp = fixtype(mkconv(ptype,
        !           770:                                                cpexpr(lconst)));
        !           771:                                frexpr(lp);
        !           772:                                }
        !           773:                        else
        !           774:                                p->leftp = fixtype(mkconv(ptype,lp));
        !           775:                if(rtype != ptype)
        !           776:                        if (rconst)
        !           777:                                {
        !           778:                                p->rightp = fixtype(mkconv(ptype,
        !           779:                                                cpexpr(rconst)));
        !           780:                                frexpr(rp);
        !           781:                                }
        !           782:                        else
        !           783:                                p->rightp = fixtype(mkconv(ptype,rp));
        !           784:                break;
        !           785: 
        !           786:        case OPPOWER:
        !           787:                return( mkpower(p) );
        !           788: 
        !           789:        case OPLT:
        !           790:        case OPLE:
        !           791:        case OPGT:
        !           792:        case OPGE:
        !           793:        case OPEQ:
        !           794:        case OPNE:
        !           795:                if(ltype == rtype)
        !           796:                        break;
        !           797:                mtype = cktype(OPMINUS, ltype, rtype);
        !           798: #if TARGET == VAX
        !           799:                if(mtype==TYDREAL && ( (ltype==TYREAL && ! lconst) ||
        !           800:                    (rtype==TYREAL && ! rconst) ))
        !           801:                        break;
        !           802: #endif
        !           803:                if( ISCOMPLEX(mtype) )
        !           804:                        break;
        !           805:                if(ltype != mtype)
        !           806:                        if (lconst)
        !           807:                                {
        !           808:                                p->leftp = fixtype(mkconv(mtype,
        !           809:                                                cpexpr(lconst)));
        !           810:                                frexpr(lp);
        !           811:                                }
        !           812:                        else
        !           813:                                p->leftp = fixtype(mkconv(mtype,lp));
        !           814:                if(rtype != mtype)
        !           815:                        if (rconst)
        !           816:                                {
        !           817:                                p->rightp = fixtype(mkconv(mtype,
        !           818:                                                cpexpr(rconst)));
        !           819:                                frexpr(rp);
        !           820:                                }
        !           821:                        else
        !           822:                                p->rightp = fixtype(mkconv(mtype,rp));
        !           823:                break;
        !           824: 
        !           825: 
        !           826:        case OPCONV:
        !           827:                if(ISCOMPLEX(p->vtype))
        !           828:                        {
        !           829:                        ptype = cktype(OPCONV, p->vtype, ltype);
        !           830:                        if(p->rightp)
        !           831:                                ptype = cktype(OPCONV, ptype, rtype);
        !           832:                        break;
        !           833:                        }
        !           834:                ptype = cktype(OPCONV, p->vtype, ltype);
        !           835:                if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
        !           836:                        {
        !           837:                        lp->exprblock.rightp =
        !           838:                                fixtype( mkconv(ptype, lp->exprblock.rightp) );
        !           839:                        free( (charptr) p );
        !           840:                        p = (Exprp) lp;
        !           841:                        }
        !           842:                break;
        !           843: 
        !           844:        case OPADDR:
        !           845:                if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
        !           846:                        fatal("addr of addr");
        !           847:                break;
        !           848: 
        !           849:        case OPCOMMA:
        !           850:        case OPQUEST:
        !           851:        case OPCOLON:
        !           852:                break;
        !           853: 
        !           854:        case OPPAREN:
        !           855:                p->vleng = (expptr) cpexpr( lp->headblock.vleng );
        !           856:                break;
        !           857: 
        !           858:        case OPMIN:
        !           859:        case OPMAX:
        !           860:                ptype = p->vtype;
        !           861:                break;
        !           862: 
        !           863:        default:
        !           864:                break;
        !           865:        }
        !           866: 
        !           867: p->vtype = ptype;
        !           868: frexpr(lconst);
        !           869: frexpr(rconst);
        !           870: return((expptr) p);
        !           871: }
        !           872: 
        !           873: #if SZINT < SZLONG
        !           874: /*
        !           875:    for efficient subscripting, replace long ints by shorts
        !           876:    in easy places
        !           877: */
        !           878: 
        !           879: expptr shorten(p)
        !           880: register expptr p;
        !           881: {
        !           882: register expptr q;
        !           883: 
        !           884: if(p->headblock.vtype != TYLONG)
        !           885:        return(p);
        !           886: 
        !           887: switch(p->tag)
        !           888:        {
        !           889:        case TERROR:
        !           890:        case TLIST:
        !           891:                return(p);
        !           892: 
        !           893:        case TCONST:
        !           894:        case TADDR:
        !           895:                return( mkconv(TYINT,p) );
        !           896: 
        !           897:        case TEXPR:
        !           898:                break;
        !           899: 
        !           900:        default:
        !           901:                badtag("shorten", p->tag);
        !           902:        }
        !           903: 
        !           904: switch(p->exprblock.opcode)
        !           905:        {
        !           906:        case OPPLUS:
        !           907:        case OPMINUS:
        !           908:        case OPSTAR:
        !           909:                q = shorten( cpexpr(p->exprblock.rightp) );
        !           910:                if(q->headblock.vtype == TYINT)
        !           911:                        {
        !           912:                        p->exprblock.leftp = shorten(p->exprblock.leftp);
        !           913:                        if(p->exprblock.leftp->headblock.vtype == TYLONG)
        !           914:                                frexpr(q);
        !           915:                        else
        !           916:                                {
        !           917:                                frexpr(p->exprblock.rightp);
        !           918:                                p->exprblock.rightp = q;
        !           919:                                p->exprblock.vtype = TYINT;
        !           920:                                }
        !           921:                        }
        !           922:                break;
        !           923: 
        !           924:        case OPNEG:
        !           925:        case OPPAREN:
        !           926:                p->exprblock.leftp = shorten(p->exprblock.leftp);
        !           927:                if(p->exprblock.leftp->headblock.vtype == TYINT)
        !           928:                        p->exprblock.vtype = TYINT;
        !           929:                break;
        !           930: 
        !           931:        case OPCALL:
        !           932:        case OPCCALL:
        !           933:                p = mkconv(TYINT,p);
        !           934:                break;
        !           935:        default:
        !           936:                break;
        !           937:        }
        !           938: 
        !           939: return(p);
        !           940: }
        !           941: #endif
        !           942: /* fix an argument list, taking due care for special first level cases */
        !           943: 
        !           944: fixargs(doput, p0)
        !           945: int doput;     /* doput is true if the function is not intrinsic;
        !           946:                   was used to decide whether to do a putconst,
        !           947:                   but this is no longer done here (Feb82)*/
        !           948: struct Listblock *p0;
        !           949: {
        !           950: register chainp p;
        !           951: register tagptr q, t;
        !           952: register int qtag;
        !           953: int nargs;
        !           954: Addrp mkscalar();
        !           955: 
        !           956: nargs = 0;
        !           957: if(p0)
        !           958:     for(p = p0->listp ; p ; p = p->nextp)
        !           959:        {
        !           960:        ++nargs;
        !           961:        q = p->datap;
        !           962:        qtag = q->tag;
        !           963:        if(qtag == TCONST)
        !           964:                {
        !           965: 
        !           966: /*
        !           967:                if(q->constblock.vtype == TYSHORT)
        !           968:                        q = (tagptr) mkconv(tyint, q);
        !           969: */  
        !           970:                p->datap = q ;
        !           971:                }
        !           972:        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           973:                q->primblock.namep->vclass==CLPROC)
        !           974:                        p->datap = (tagptr) mkaddr(q->primblock.namep);
        !           975:        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           976:                q->primblock.namep->vdim!=NULL)
        !           977:                        p->datap = (tagptr) mkscalar(q->primblock.namep);
        !           978:        else if(qtag==TPRIM && q->primblock.argsp==0 &&
        !           979:                q->primblock.namep->vdovar && 
        !           980:                (t = (tagptr) memversion(q->primblock.namep)) )
        !           981:                        p->datap = (tagptr) fixtype(t);
        !           982:        else
        !           983:                p->datap = (tagptr) fixtype(q);
        !           984:        }
        !           985: return(nargs);
        !           986: }
        !           987: 
        !           988: 
        !           989: Addrp mkscalar(np)
        !           990: register Namep np;
        !           991: {
        !           992: register Addrp ap;
        !           993: 
        !           994: vardcl(np);
        !           995: ap = mkaddr(np);
        !           996: 
        !           997: #if TARGET == VAX || TARGET == TAHOE
        !           998:        /* on the VAX, prolog causes array arguments
        !           999:           to point at the (0,...,0) element, except when
        !          1000:           subscript checking is on
        !          1001:        */
        !          1002: #ifdef SDB
        !          1003:        if( !checksubs && !sdbflag && np->vstg==STGARG)
        !          1004: #else
        !          1005:        if( !checksubs && np->vstg==STGARG)
        !          1006: #endif
        !          1007:                {
        !          1008:                register struct Dimblock *dp;
        !          1009:                dp = np->vdim;
        !          1010:                frexpr(ap->memoffset);
        !          1011:                ap->memoffset = mkexpr(OPSTAR,
        !          1012:                                (np->vtype==TYCHAR ?
        !          1013:                                        cpexpr(np->vleng) :
        !          1014:                                        (tagptr)ICON(typesize[np->vtype]) ),
        !          1015:                                cpexpr(dp->baseoffset) );
        !          1016:                }
        !          1017: #endif
        !          1018: return(ap);
        !          1019: }
        !          1020: 
        !          1021: 
        !          1022: 
        !          1023: 
        !          1024: 
        !          1025: expptr mkfunct(p)
        !          1026: register struct Primblock *p;
        !          1027: {
        !          1028: struct Entrypoint *ep;
        !          1029: Addrp ap;
        !          1030: struct Extsym *extp;
        !          1031: register Namep np;
        !          1032: register expptr q;
        !          1033: expptr intrcall(), stfcall();
        !          1034: int k, nargs;
        !          1035: int class;
        !          1036: 
        !          1037: if(p->tag != TPRIM)
        !          1038:        return( errnode() );
        !          1039: 
        !          1040: np = p->namep;
        !          1041: class = np->vclass;
        !          1042: 
        !          1043: if(class == CLUNKNOWN)
        !          1044:        {
        !          1045:        np->vclass = class = CLPROC;
        !          1046:        if(np->vstg == STGUNKNOWN)
        !          1047:                {
        !          1048:                if(np->vtype!=TYSUBR && (k = intrfunct(np->varname)) )
        !          1049:                        {
        !          1050:                        np->vstg = STGINTR;
        !          1051:                        np->vardesc.varno = k;
        !          1052:                        np->vprocclass = PINTRINSIC;
        !          1053:                        }
        !          1054:                else
        !          1055:                        {
        !          1056:                        extp = mkext( varunder(VL,np->varname) );
        !          1057:                        if(extp->extstg == STGCOMMON)
        !          1058:                                warn("conflicting declarations", np->varname);
        !          1059:                        extp->extstg = STGEXT;
        !          1060:                        np->vstg = STGEXT;
        !          1061:                        np->vardesc.varno = extp - extsymtab;
        !          1062:                        np->vprocclass = PEXTERNAL;
        !          1063:                        }
        !          1064:                }
        !          1065:        else if(np->vstg==STGARG)
        !          1066:                {
        !          1067:                if(np->vtype!=TYCHAR && !ftn66flag)
        !          1068:                    warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
        !          1069:                np->vprocclass = PEXTERNAL;
        !          1070:                }
        !          1071:        }
        !          1072: 
        !          1073: if(class != CLPROC)
        !          1074:        fatali("invalid class code %d for function", class);
        !          1075: if(p->fcharp || p->lcharp)
        !          1076:        {
        !          1077:        err("no substring of function call");
        !          1078:        goto error;
        !          1079:        }
        !          1080: impldcl(np);
        !          1081: nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
        !          1082: 
        !          1083: switch(np->vprocclass)
        !          1084:        {
        !          1085:        case PEXTERNAL:
        !          1086:                ap = mkaddr(np);
        !          1087:        call:
        !          1088:                q = mkexpr(OPCALL, ap, p->argsp);
        !          1089:                if( (q->exprblock.vtype = np->vtype) == TYUNKNOWN)
        !          1090:                        {
        !          1091:                        err("attempt to use untyped function");
        !          1092:                        goto error;
        !          1093:                        }
        !          1094:                if(np->vleng)
        !          1095:                        q->exprblock.vleng = (expptr) cpexpr(np->vleng);
        !          1096:                break;
        !          1097: 
        !          1098:        case PINTRINSIC:
        !          1099:                q = intrcall(np, p->argsp, nargs);
        !          1100:                break;
        !          1101: 
        !          1102:        case PSTFUNCT:
        !          1103:                q = stfcall(np, p->argsp);
        !          1104:                break;
        !          1105: 
        !          1106:        case PTHISPROC:
        !          1107:                warn("recursive call");
        !          1108:                for(ep = entries ; ep ; ep = ep->entnextp)
        !          1109:                        if(ep->enamep == np)
        !          1110:                                break;
        !          1111:                if(ep == NULL)
        !          1112:                        fatal("mkfunct: impossible recursion");
        !          1113:                ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
        !          1114:                goto call;
        !          1115: 
        !          1116:        default:
        !          1117:                fatali("mkfunct: impossible vprocclass %d",
        !          1118:                        (int) (np->vprocclass) );
        !          1119:        }
        !          1120: free( (charptr) p );
        !          1121: return(q);
        !          1122: 
        !          1123: error:
        !          1124:        frexpr(p);
        !          1125:        return( errnode() );
        !          1126: }
        !          1127: 
        !          1128: 
        !          1129: 
        !          1130: LOCAL expptr stfcall(np, actlist)
        !          1131: Namep np;
        !          1132: struct Listblock *actlist;
        !          1133: {
        !          1134: register chainp actuals;
        !          1135: int nargs;
        !          1136: chainp oactp, formals;
        !          1137: int type;
        !          1138: expptr q, rhs, ap;
        !          1139: Namep tnp;
        !          1140: register struct Rplblock *rp;
        !          1141: struct Rplblock *tlist;
        !          1142: 
        !          1143: if(actlist)
        !          1144:        {
        !          1145:        actuals = actlist->listp;
        !          1146:        free( (charptr) actlist);
        !          1147:        }
        !          1148: else
        !          1149:        actuals = NULL;
        !          1150: oactp = actuals;
        !          1151: 
        !          1152: nargs = 0;
        !          1153: tlist = NULL;
        !          1154: if( (type = np->vtype) == TYUNKNOWN)
        !          1155:        {
        !          1156:        err("attempt to use untyped statement function");
        !          1157:        q = errnode();
        !          1158:        goto ret;
        !          1159:        }
        !          1160: formals = (chainp) (np->varxptr.vstfdesc->datap);
        !          1161: rhs = (expptr) (np->varxptr.vstfdesc->nextp);
        !          1162: 
        !          1163: /* copy actual arguments into temporaries */
        !          1164: while(actuals!=NULL && formals!=NULL)
        !          1165:        {
        !          1166:        rp = ALLOC(Rplblock);
        !          1167:        rp->rplnp = tnp = (Namep) (formals->datap);
        !          1168:        ap = fixtype(actuals->datap);
        !          1169:        if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
        !          1170:           && (ap->tag==TCONST || ap->tag==TADDR || ap->tag==TTEMP) )
        !          1171:                {
        !          1172:                rp->rplvp = (expptr) ap;
        !          1173:                rp->rplxp = NULL;
        !          1174:                rp->rpltag = ap->tag;
        !          1175:                }
        !          1176:        else    {
        !          1177:                rp->rplvp = (expptr) mktemp(tnp->vtype, tnp->vleng);
        !          1178:                rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
        !          1179:                if( (rp->rpltag = rp->rplxp->tag) == TERROR)
        !          1180:                        err("disagreement of argument types in statement function call");
        !          1181:                else if(tnp->vtype!=ap->headblock.vtype)
        !          1182:                        warn("argument type mismatch in statement function");
        !          1183:                }
        !          1184:        rp->rplnextp = tlist;
        !          1185:        tlist = rp;
        !          1186:        actuals = actuals->nextp;
        !          1187:        formals = formals->nextp;
        !          1188:        ++nargs;
        !          1189:        }
        !          1190: 
        !          1191: if(actuals!=NULL || formals!=NULL)
        !          1192:        err("statement function definition and argument list differ");
        !          1193: 
        !          1194: /*
        !          1195:    now push down names involved in formal argument list, then
        !          1196:    evaluate rhs of statement function definition in this environment
        !          1197: */
        !          1198: 
        !          1199: if(tlist)      /* put tlist in front of the rpllist */
        !          1200:        {
        !          1201:        for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
        !          1202:                ;
        !          1203:        rp->rplnextp = rpllist;
        !          1204:        rpllist = tlist;
        !          1205:        }
        !          1206: 
        !          1207: q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
        !          1208: 
        !          1209: /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
        !          1210: while(--nargs >= 0)
        !          1211:        {
        !          1212:        if(rpllist->rplxp)
        !          1213:                q = mkexpr(OPCOMMA, rpllist->rplxp, q);
        !          1214:        rp = rpllist->rplnextp;
        !          1215:        frexpr(rpllist->rplvp);
        !          1216:        free(rpllist);
        !          1217:        rpllist = rp;
        !          1218:        }
        !          1219: 
        !          1220: ret:
        !          1221:        frchain( &oactp );
        !          1222:        return(q);
        !          1223: }
        !          1224: 
        !          1225: 
        !          1226: 
        !          1227: 
        !          1228: Addrp mkplace(np)
        !          1229: register Namep np;
        !          1230: {
        !          1231: register Addrp s;
        !          1232: register struct Rplblock *rp;
        !          1233: int regn;
        !          1234: 
        !          1235: /* is name on the replace list? */
        !          1236: 
        !          1237: for(rp = rpllist ; rp ; rp = rp->rplnextp)
        !          1238:        {
        !          1239:        if(np == rp->rplnp)
        !          1240:                {
        !          1241:                if(rp->rpltag == TNAME)
        !          1242:                        {
        !          1243:                        np = (Namep) (rp->rplvp);
        !          1244:                        break;
        !          1245:                        }
        !          1246:                else    return( (Addrp) cpexpr(rp->rplvp) );
        !          1247:                }
        !          1248:        }
        !          1249: 
        !          1250: /* is variable a DO index in a register ? */
        !          1251: 
        !          1252: if(np->vdovar && ( (regn = inregister(np)) >= 0) )
        !          1253:        if(np->vtype == TYERROR)
        !          1254:                return( (Addrp) errnode() );
        !          1255:        else
        !          1256:                {
        !          1257:                s = ALLOC(Addrblock);
        !          1258:                s->tag = TADDR;
        !          1259:                s->vstg = STGREG;
        !          1260:                s->vtype = TYIREG;
        !          1261:                s->issaved = np->vsave;
        !          1262:                s->memno = regn;
        !          1263:                s->memoffset = ICON(0);
        !          1264:                return(s);
        !          1265:                }
        !          1266: 
        !          1267: vardcl(np);
        !          1268: return(mkaddr(np));
        !          1269: }
        !          1270: 
        !          1271: 
        !          1272: 
        !          1273: 
        !          1274: expptr mklhs(p)
        !          1275: register struct Primblock *p;
        !          1276: {
        !          1277: expptr suboffset();
        !          1278: register Addrp s;
        !          1279: Namep np;
        !          1280: 
        !          1281: if(p->tag != TPRIM)
        !          1282:        return( (expptr) p );
        !          1283: np = p->namep;
        !          1284: 
        !          1285: s = mkplace(np);
        !          1286: if(s->tag!=TADDR || s->vstg==STGREG)
        !          1287:        {
        !          1288:        free( (charptr) p );
        !          1289:        return( (expptr) s );
        !          1290:        }
        !          1291: 
        !          1292: /* compute the address modified by subscripts */
        !          1293: 
        !          1294: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
        !          1295: frexpr(p->argsp);
        !          1296: p->argsp = NULL;
        !          1297: 
        !          1298: /* now do substring part */
        !          1299: 
        !          1300: if(p->fcharp || p->lcharp)
        !          1301:        {
        !          1302:        if(np->vtype != TYCHAR)
        !          1303:                errstr("substring of noncharacter %s", varstr(VL,np->varname));
        !          1304:        else    {
        !          1305:                if(p->lcharp == NULL)
        !          1306:                        p->lcharp = (expptr) cpexpr(s->vleng);
        !          1307:                frexpr(s->vleng);
        !          1308:                if(p->fcharp)
        !          1309:                        {
        !          1310:                        if(p->fcharp->tag == TPRIM && p->lcharp->tag == TPRIM
        !          1311:                        && p->fcharp->primblock.namep == p->lcharp->primblock.namep)
        !          1312:                                /* A trivial optimization -- upper == lower */
        !          1313:                                s->vleng = ICON(1);
        !          1314:                        else
        !          1315:                                s->vleng = mkexpr(OPMINUS, p->lcharp,
        !          1316:                                        mkexpr(OPMINUS, p->fcharp, ICON(1) ));
        !          1317:                        }
        !          1318:                else
        !          1319:                        s->vleng = p->lcharp;
        !          1320:                }
        !          1321:        }
        !          1322: 
        !          1323: s->vleng = fixtype( s->vleng );
        !          1324: s->memoffset = fixtype( s->memoffset );
        !          1325: free( (charptr) p );
        !          1326: return( (expptr) s );
        !          1327: }
        !          1328: 
        !          1329: 
        !          1330: 
        !          1331: 
        !          1332: 
        !          1333: deregister(np)
        !          1334: Namep np;
        !          1335: {
        !          1336: if(nregvar>0 && regnamep[nregvar-1]==np)
        !          1337:        {
        !          1338:        --nregvar;
        !          1339: #if FAMILY == DMR
        !          1340:        putnreg();
        !          1341: #endif
        !          1342:        }
        !          1343: }
        !          1344: 
        !          1345: 
        !          1346: 
        !          1347: 
        !          1348: Addrp memversion(np)
        !          1349: register Namep np;
        !          1350: {
        !          1351: register Addrp s;
        !          1352: 
        !          1353: if(np->vdovar==NO || (inregister(np)<0) )
        !          1354:        return(NULL);
        !          1355: np->vdovar = NO;
        !          1356: s = mkplace(np);
        !          1357: np->vdovar = YES;
        !          1358: return(s);
        !          1359: }
        !          1360: 
        !          1361: 
        !          1362: 
        !          1363: inregister(np)
        !          1364: register Namep np;
        !          1365: {
        !          1366: register int i;
        !          1367: 
        !          1368: for(i = 0 ; i < nregvar ; ++i)
        !          1369:        if(regnamep[i] == np)
        !          1370:                return( regnum[i] );
        !          1371: return(-1);
        !          1372: }
        !          1373: 
        !          1374: 
        !          1375: 
        !          1376: 
        !          1377: enregister(np)
        !          1378: Namep np;
        !          1379: {
        !          1380: if( inregister(np) >= 0)
        !          1381:        return(YES);
        !          1382: if(nregvar >= maxregvar)
        !          1383:        return(NO);
        !          1384: vardcl(np);
        !          1385: if( ONEOF(np->vtype, MSKIREG) )
        !          1386:        {
        !          1387:        regnamep[nregvar++] = np;
        !          1388:        if(nregvar > highregvar)
        !          1389:                highregvar = nregvar;
        !          1390: #if FAMILY == DMR
        !          1391:        putnreg();
        !          1392: #endif
        !          1393:        return(YES);
        !          1394:        }
        !          1395: else
        !          1396:        return(NO);
        !          1397: }
        !          1398: 
        !          1399: 
        !          1400: 
        !          1401: 
        !          1402: expptr suboffset(p)
        !          1403: register struct Primblock *p;
        !          1404: {
        !          1405: int n;
        !          1406: expptr size;
        !          1407: expptr oftwo();
        !          1408: chainp cp;
        !          1409: expptr offp, prod;
        !          1410: expptr subcheck();
        !          1411: struct Dimblock *dimp;
        !          1412: expptr sub[MAXDIM+1];
        !          1413: register Namep np;
        !          1414: 
        !          1415: np = p->namep;
        !          1416: offp = ICON(0);
        !          1417: n = 0;
        !          1418: if(p->argsp)
        !          1419:        for(cp = p->argsp->listp ; cp ; ++n, cp = cp->nextp)
        !          1420:                {
        !          1421:                sub[n] = fixtype(cpexpr(cp->datap));
        !          1422:                if ( ! ISINT(sub[n]->headblock.vtype)) {
        !          1423:                        errstr("%s: non-integer subscript expression",
        !          1424:                                varstr(VL, np->varname) );
        !          1425:                        /* Provide a substitute -- go on to find more errors */
        !          1426:                        frexpr(sub[n]);
        !          1427:                        sub[n] = ICON(1);
        !          1428:                }
        !          1429:                if(n > maxdim)
        !          1430:                        {
        !          1431:                           char str[28+VL];
        !          1432:                           sprintf(str, "%s: more than %d subscripts",
        !          1433:                                varstr(VL, np->varname), maxdim );
        !          1434:                           err( str );
        !          1435:                        break;
        !          1436:                        }
        !          1437:                }
        !          1438: 
        !          1439: dimp = np->vdim;
        !          1440: if(n>0 && dimp==NULL)
        !          1441:        errstr("%s: subscripts on scalar variable", 
        !          1442:                varstr(VL, np->varname), maxdim );
        !          1443: else if(dimp && dimp->ndim!=n)
        !          1444:        errstr("wrong number of subscripts on %s",
        !          1445:                varstr(VL, np->varname) );
        !          1446: else if(n > 0)
        !          1447:        {
        !          1448:        prod = sub[--n];
        !          1449:        while( --n >= 0)
        !          1450:                prod = mkexpr(OPPLUS, sub[n],
        !          1451:                        mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
        !          1452: #if TARGET == VAX || TARGET == TAHOE
        !          1453: #ifdef SDB
        !          1454:        if(checksubs || np->vstg!=STGARG || sdbflag)
        !          1455: #else
        !          1456:        if(checksubs || np->vstg!=STGARG)
        !          1457: #endif
        !          1458:                prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
        !          1459: #else
        !          1460:        prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
        !          1461: #endif
        !          1462:        if(checksubs)
        !          1463:                prod = subcheck(np, prod);
        !          1464:        size = np->vtype == TYCHAR ?
        !          1465:                (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
        !          1466:        if (!oftwo(size))
        !          1467:                prod = mkexpr(OPSTAR, prod, size);
        !          1468:        else
        !          1469:                prod = mkexpr(OPLSHIFT,prod,oftwo(size));
        !          1470: 
        !          1471:        offp = mkexpr(OPPLUS, offp, prod);
        !          1472:        }
        !          1473: 
        !          1474: if(p->fcharp && np->vtype==TYCHAR)
        !          1475:        offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
        !          1476: 
        !          1477: return(offp);
        !          1478: }
        !          1479: 
        !          1480: 
        !          1481: 
        !          1482: 
        !          1483: expptr subcheck(np, p)
        !          1484: Namep np;
        !          1485: register expptr p;
        !          1486: {
        !          1487: struct Dimblock *dimp;
        !          1488: expptr t, checkvar, checkcond, badcall;
        !          1489: 
        !          1490: dimp = np->vdim;
        !          1491: if(dimp->nelt == NULL)
        !          1492:        return(p);      /* don't check arrays with * bounds */
        !          1493: checkvar = NULL;
        !          1494: checkcond = NULL;
        !          1495: if( ISICON(p) )
        !          1496:        {
        !          1497:        if(p->constblock.const.ci < 0)
        !          1498:                goto badsub;
        !          1499:        if( ISICON(dimp->nelt) )
        !          1500:                if(p->constblock.const.ci < dimp->nelt->constblock.const.ci)
        !          1501:                        return(p);
        !          1502:                else
        !          1503:                        goto badsub;
        !          1504:        }
        !          1505: if(p->tag==TADDR && p->addrblock.vstg==STGREG)
        !          1506:        {
        !          1507:        checkvar = (expptr) cpexpr(p);
        !          1508:        t = p;
        !          1509:        }
        !          1510: else   {
        !          1511:        checkvar = (expptr) mktemp(p->headblock.vtype, ENULL);
        !          1512:        t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
        !          1513:        }
        !          1514: checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
        !          1515: if( ! ISICON(p) )
        !          1516:        checkcond = mkexpr(OPAND, checkcond,
        !          1517:                        mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
        !          1518: 
        !          1519: badcall = call4(p->headblock.vtype, "s_rnge",
        !          1520:                mkstrcon(VL, np->varname),
        !          1521:                mkconv(TYLONG,  cpexpr(checkvar)),
        !          1522:                mkstrcon(XL, procname),
        !          1523:                ICON(lineno) );
        !          1524: badcall->exprblock.opcode = OPCCALL;
        !          1525: p = mkexpr(OPQUEST, checkcond,
        !          1526:        mkexpr(OPCOLON, checkvar, badcall));
        !          1527: 
        !          1528: return(p);
        !          1529: 
        !          1530: badsub:
        !          1531:        frexpr(p);
        !          1532:        errstr("subscript on variable %s out of range", varstr(VL,np->varname));
        !          1533:        return ( ICON(0) );
        !          1534: }
        !          1535: 
        !          1536: 
        !          1537: 
        !          1538: 
        !          1539: Addrp mkaddr(p)
        !          1540: register Namep p;
        !          1541: {
        !          1542: struct Extsym *extp;
        !          1543: register Addrp t;
        !          1544: Addrp intraddr();
        !          1545: 
        !          1546: switch( p->vstg)
        !          1547:        {
        !          1548:        case STGUNKNOWN:
        !          1549:                if(p->vclass != CLPROC)
        !          1550:                        break;
        !          1551:                extp = mkext( varunder(VL, p->varname) );
        !          1552:                extp->extstg = STGEXT;
        !          1553:                p->vstg = STGEXT;
        !          1554:                p->vardesc.varno = extp - extsymtab;
        !          1555:                p->vprocclass = PEXTERNAL;
        !          1556: 
        !          1557:        case STGCOMMON:
        !          1558:        case STGEXT:
        !          1559:        case STGBSS:
        !          1560:        case STGINIT:
        !          1561:        case STGEQUIV:
        !          1562:        case STGARG:
        !          1563:        case STGLENG:
        !          1564:        case STGAUTO:
        !          1565:                t = ALLOC(Addrblock);
        !          1566:                t->tag = TADDR;
        !          1567:                if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
        !          1568:                        t->vclass = CLVAR;
        !          1569:                else
        !          1570:                        t->vclass = p->vclass;
        !          1571:                t->vtype = p->vtype;
        !          1572:                t->vstg = p->vstg;
        !          1573:                t->memno = p->vardesc.varno;
        !          1574:                t->issaved = p->vsave;
        !          1575:                 if(p->vdim) t->isarray = YES;
        !          1576:                t->memoffset = ICON(p->voffset);
        !          1577:                if(p->vleng)
        !          1578:                        {
        !          1579:                        t->vleng = (expptr) cpexpr(p->vleng);
        !          1580:                        if( ISICON(t->vleng) )
        !          1581:                                t->varleng = t->vleng->constblock.const.ci;
        !          1582:                        }
        !          1583:                if (p->vstg == STGBSS)
        !          1584:                        t->varsize = p->varsize;
        !          1585:                else if (p->vstg == STGEQUIV)
        !          1586:                        t->varsize = eqvclass[t->memno].eqvleng;
        !          1587:                return(t);
        !          1588: 
        !          1589:        case STGINTR:
        !          1590:                return( intraddr(p) );
        !          1591: 
        !          1592:        }
        !          1593: /*debug*/fprintf(diagfile,"mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
        !          1594: badstg("mkaddr", p->vstg);
        !          1595: /* NOTREACHED */
        !          1596: }
        !          1597: 
        !          1598: 
        !          1599: 
        !          1600: 
        !          1601: Addrp mkarg(type, argno)
        !          1602: int type, argno;
        !          1603: {
        !          1604: register Addrp p;
        !          1605: 
        !          1606: p = ALLOC(Addrblock);
        !          1607: p->tag = TADDR;
        !          1608: p->vtype = type;
        !          1609: p->vclass = CLVAR;
        !          1610: p->vstg = (type==TYLENG ? STGLENG : STGARG);
        !          1611: p->memno = argno;
        !          1612: return(p);
        !          1613: }
        !          1614: 
        !          1615: 
        !          1616: 
        !          1617: 
        !          1618: expptr mkprim(v, args, substr)
        !          1619: register union
        !          1620:        {
        !          1621:        struct Paramblock paramblock;
        !          1622:        struct Nameblock nameblock;
        !          1623:        struct Headblock headblock;
        !          1624:        } *v;
        !          1625: struct Listblock *args;
        !          1626: chainp substr;
        !          1627: {
        !          1628: register struct Primblock *p;
        !          1629: 
        !          1630: if(v->headblock.vclass == CLPARAM)
        !          1631:        {
        !          1632:        if(args || substr)
        !          1633:                {
        !          1634:                errstr("no qualifiers on parameter name %s",
        !          1635:                        varstr(VL,v->paramblock.varname));
        !          1636:                frexpr(args);
        !          1637:                if(substr)
        !          1638:                        {
        !          1639:                        frexpr(substr->datap);
        !          1640:                        frexpr(substr->nextp->datap);
        !          1641:                        frchain(&substr);
        !          1642:                        }
        !          1643:                frexpr(v);
        !          1644:                return( errnode() );
        !          1645:                }
        !          1646:        return( (expptr) cpexpr(v->paramblock.paramval) );
        !          1647:        }
        !          1648: 
        !          1649: p = ALLOC(Primblock);
        !          1650: p->tag = TPRIM;
        !          1651: p->vtype = v->nameblock.vtype;
        !          1652: p->namep = (Namep) v;
        !          1653: p->argsp = args;
        !          1654: if(substr)
        !          1655:        {
        !          1656:        p->fcharp = (expptr) substr->datap;
        !          1657:        if (p->fcharp != ENULL && ! ISINT(p->fcharp.headblock->vtype))
        !          1658:                p->fcharp = mkconv(TYINT, p->fcharp);
        !          1659:        p->lcharp = (expptr) substr->nextp->datap;
        !          1660:        if (p->lcharp != ENULL && ! ISINT(p->lcharp.headblock->vtype))
        !          1661:                p->lcharp = mkconv(TYINT, p->lcharp);
        !          1662:        frchain(&substr);
        !          1663:        }
        !          1664: return( (expptr) p);
        !          1665: }
        !          1666: 
        !          1667: 
        !          1668: 
        !          1669: vardcl(v)
        !          1670: register Namep v;
        !          1671: {
        !          1672: int nelt;
        !          1673: struct Dimblock *t;
        !          1674: Addrp p;
        !          1675: expptr neltp;
        !          1676: int eltsize;
        !          1677: int varsize;
        !          1678: int tsize;
        !          1679: int align;
        !          1680: 
        !          1681: if(v->vdcldone)
        !          1682:        return;
        !          1683: if(v->vclass == CLNAMELIST)
        !          1684:        return;
        !          1685: 
        !          1686: if(v->vtype == TYUNKNOWN)
        !          1687:        impldcl(v);
        !          1688: if(v->vclass == CLUNKNOWN)
        !          1689:        v->vclass = CLVAR;
        !          1690: else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
        !          1691:        {
        !          1692:        dclerr("used both as variable and non-variable", v);
        !          1693:        return;
        !          1694:        }
        !          1695: if(v->vstg==STGUNKNOWN)
        !          1696:        v->vstg = implstg[ letter(v->varname[0]) ];
        !          1697: 
        !          1698: switch(v->vstg)
        !          1699:        {
        !          1700:        case STGBSS:
        !          1701:                v->vardesc.varno = ++lastvarno;
        !          1702:                if (v->vclass != CLVAR)
        !          1703:                        break;
        !          1704:                nelt = 1;
        !          1705:                t = v->vdim;
        !          1706:                if (t)
        !          1707:                        {
        !          1708:                        neltp = t->nelt;
        !          1709:                        if (neltp && ISICON(neltp))
        !          1710:                                nelt = neltp->constblock.const.ci;
        !          1711:                        else
        !          1712:                                dclerr("improperly dimensioned array", v);
        !          1713:                        }
        !          1714: 
        !          1715:                if (v->vtype == TYCHAR)
        !          1716:                        {
        !          1717:                        v->vleng = fixtype(v->vleng);
        !          1718:                        if (v->vleng == NULL)
        !          1719:                                eltsize = typesize[TYCHAR];
        !          1720:                        else if (ISICON(v->vleng))
        !          1721:                                eltsize = typesize[TYCHAR] *
        !          1722:                                        v->vleng->constblock.const.ci;
        !          1723:                        else if (v->vleng->tag != TERROR)
        !          1724:                                {
        !          1725:                                errstr("nonconstant string length on %s",
        !          1726:                                        varstr(VL, v->varname));
        !          1727:                                eltsize = 0;
        !          1728:                                }
        !          1729:                        }
        !          1730:                else
        !          1731:                        eltsize = typesize[v->vtype];
        !          1732: 
        !          1733:                v->varsize = nelt * eltsize;
        !          1734:                break;
        !          1735:        case STGAUTO:
        !          1736:                if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
        !          1737:                        break;
        !          1738:                nelt = 1;
        !          1739:                if(t = v->vdim)
        !          1740:                        if( (neltp = t->nelt) && ISCONST(neltp) )
        !          1741:                                nelt = neltp->constblock.const.ci;
        !          1742:                        else
        !          1743:                                dclerr("adjustable automatic array", v);
        !          1744:                p = autovar(nelt, v->vtype, v->vleng);
        !          1745:                v->vardesc.varno = p->memno;
        !          1746:                v->voffset = p->memoffset->constblock.const.ci;
        !          1747:                frexpr(p);
        !          1748:                break;
        !          1749: 
        !          1750:        default:
        !          1751:                break;
        !          1752:        }
        !          1753: v->vdcldone = YES;
        !          1754: }
        !          1755: 
        !          1756: 
        !          1757: 
        !          1758: 
        !          1759: impldcl(p)
        !          1760: register Namep p;
        !          1761: {
        !          1762: register int k;
        !          1763: int type, leng;
        !          1764: 
        !          1765: if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
        !          1766:        return;
        !          1767: if(p->vtype == TYUNKNOWN)
        !          1768:        {
        !          1769:        k = letter(p->varname[0]);
        !          1770:        type = impltype[ k ];
        !          1771:        leng = implleng[ k ];
        !          1772:        if(type == TYUNKNOWN)
        !          1773:                {
        !          1774:                if(p->vclass == CLPROC)
        !          1775:                        dclerr("attempt to use function of undefined type", p);
        !          1776:                else
        !          1777:                        dclerr("attempt to use undefined variable", p);
        !          1778:                type = TYERROR;
        !          1779:                leng = 1;
        !          1780:                }
        !          1781:        settype(p, type, leng);
        !          1782:        }
        !          1783: }
        !          1784: 
        !          1785: 
        !          1786: 
        !          1787: 
        !          1788: LOCAL letter(c)
        !          1789: register int c;
        !          1790: {
        !          1791: if( isupper(c) )
        !          1792:        c = tolower(c);
        !          1793: return(c - 'a');
        !          1794: }
        !          1795: 
        !          1796: #define ICONEQ(z, c)  (ISICON(z) && z->constblock.const.ci==c)
        !          1797: #define COMMUTE        { e = lp;  lp = rp;  rp = e; }
        !          1798: 
        !          1799: 
        !          1800: expptr mkexpr(opcode, lp, rp)
        !          1801: int opcode;
        !          1802: register expptr lp, rp;
        !          1803: {
        !          1804: register expptr e, e1;
        !          1805: int etype;
        !          1806: int ltype, rtype;
        !          1807: int ltag, rtag;
        !          1808: expptr q, q1;
        !          1809: expptr fold();
        !          1810: int k;
        !          1811: 
        !          1812: ltype = lp->headblock.vtype;
        !          1813: ltag = lp->tag;
        !          1814: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
        !          1815:        {
        !          1816:        rtype = rp->headblock.vtype;
        !          1817:        rtag = rp->tag;
        !          1818:        }
        !          1819: else   {
        !          1820:        rtype = 0;
        !          1821:        rtag = 0;
        !          1822:        }
        !          1823: 
        !          1824: /*
        !          1825:  * Yuck.  Why can't we fold constants AFTER
        !          1826:  * variables are implicitly declared???
        !          1827:  */
        !          1828: if(ltype == TYUNKNOWN && ltag == TPRIM && lp->primblock.argsp == NULL)
        !          1829:        {
        !          1830:        k = letter(lp->primblock.namep->varname[0]);
        !          1831:        ltype = impltype[ k ];
        !          1832:        }
        !          1833: if(rtype == TYUNKNOWN && rtag == TPRIM && rp->primblock.argsp == NULL)
        !          1834:        {
        !          1835:        k = letter(rp->primblock.namep->varname[0]);
        !          1836:        rtype = impltype[ k ];
        !          1837:        }
        !          1838: 
        !          1839: etype = cktype(opcode, ltype, rtype);
        !          1840: if(etype == TYERROR)
        !          1841:        goto error;
        !          1842: 
        !          1843: if(etype != TYUNKNOWN)
        !          1844: switch(opcode)
        !          1845:        {
        !          1846:        /* check for multiplication by 0 and 1 and addition to 0 */
        !          1847: 
        !          1848:        case OPSTAR:
        !          1849:                if( ISCONST(lp) )
        !          1850:                        COMMUTE
        !          1851: 
        !          1852:                if( ISICON(rp) )
        !          1853:                        {
        !          1854:                        if(rp->constblock.const.ci == 0)
        !          1855:                                {
        !          1856:                                if(etype == TYUNKNOWN)
        !          1857:                                        break;
        !          1858:                                rp = mkconv(etype, rp);
        !          1859:                                goto retright;
        !          1860:                                }
        !          1861:                        if ((lp->tag == TEXPR) &&
        !          1862:                            ((lp->exprblock.opcode == OPPLUS) ||
        !          1863:                             (lp->exprblock.opcode == OPMINUS)) &&
        !          1864:                            ISCONST(lp->exprblock.rightp) &&
        !          1865:                            ISINT(lp->exprblock.rightp->constblock.vtype))
        !          1866:                                {
        !          1867:                                q1 = mkexpr(OPSTAR, lp->exprblock.rightp,
        !          1868:                                           cpexpr(rp));
        !          1869:                                q = mkexpr(OPSTAR, lp->exprblock.leftp, rp);
        !          1870:                                q = mkexpr(lp->exprblock.opcode, q, q1);
        !          1871:                                free ((char *) lp);
        !          1872:                                return q;
        !          1873:                                }
        !          1874:                        else
        !          1875:                                goto mulop;
        !          1876:                        }
        !          1877:                break;
        !          1878: 
        !          1879:        case OPSLASH:
        !          1880:        case OPMOD:
        !          1881:                if( ICONEQ(rp, 0) )
        !          1882:                        {
        !          1883:                        err("attempted division by zero");
        !          1884:                        rp = ICON(1);
        !          1885:                        break;
        !          1886:                        }
        !          1887:                if(opcode == OPMOD)
        !          1888:                        break;
        !          1889: 
        !          1890: 
        !          1891:        mulop:
        !          1892:                if( ISICON(rp) )
        !          1893:                        {
        !          1894:                        if(rp->constblock.const.ci == 1)
        !          1895:                                goto retleft;
        !          1896: 
        !          1897:                        if(rp->constblock.const.ci == -1)
        !          1898:                                {
        !          1899:                                frexpr(rp);
        !          1900:                                return( mkexpr(OPNEG, lp, PNULL) );
        !          1901:                                }
        !          1902:                        }
        !          1903: 
        !          1904:                if( ISSTAROP(lp) && ISICON(lp->exprblock.rightp) )
        !          1905:                        {
        !          1906:                        if(opcode == OPSTAR)
        !          1907:                                e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
        !          1908:                        else  if(ISICON(rp) &&
        !          1909:                                (lp->exprblock.rightp->constblock.const.ci %
        !          1910:                                        rp->constblock.const.ci) == 0)
        !          1911:                                e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
        !          1912:                        else    break;
        !          1913: 
        !          1914:                        e1 = lp->exprblock.leftp;
        !          1915:                        free( (charptr) lp );
        !          1916:                        return( mkexpr(OPSTAR, e1, e) );
        !          1917:                        }
        !          1918:                break;
        !          1919: 
        !          1920: 
        !          1921:        case OPPLUS:
        !          1922:                if( ISCONST(lp) )
        !          1923:                        COMMUTE
        !          1924:                goto addop;
        !          1925: 
        !          1926:        case OPMINUS:
        !          1927:                if( ICONEQ(lp, 0) )
        !          1928:                        {
        !          1929:                        frexpr(lp);
        !          1930:                        return( mkexpr(OPNEG, rp, ENULL) );
        !          1931:                        }
        !          1932: 
        !          1933:                if( ISCONST(rp) )
        !          1934:                        {
        !          1935:                        opcode = OPPLUS;
        !          1936:                        consnegop(rp);
        !          1937:                        }
        !          1938: 
        !          1939:        addop:
        !          1940:                if( ISICON(rp) )
        !          1941:                        {
        !          1942:                        if(rp->constblock.const.ci == 0)
        !          1943:                                goto retleft;
        !          1944:                        if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
        !          1945:                                {
        !          1946:                                e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
        !          1947:                                e1 = lp->exprblock.leftp;
        !          1948:                                free( (charptr) lp );
        !          1949:                                return( mkexpr(OPPLUS, e1, e) );
        !          1950:                                }
        !          1951:                        }
        !          1952:                break;
        !          1953: 
        !          1954: 
        !          1955:        case OPPOWER:
        !          1956:                break;
        !          1957: 
        !          1958:        case OPNEG:
        !          1959:                if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
        !          1960:                        {
        !          1961:                        e = lp->exprblock.leftp;
        !          1962:                        free( (charptr) lp );
        !          1963:                        return(e);
        !          1964:                        }
        !          1965:                break;
        !          1966: 
        !          1967:        case OPNOT:
        !          1968:                if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
        !          1969:                        {
        !          1970:                        e = lp->exprblock.leftp;
        !          1971:                        free( (charptr) lp );
        !          1972:                        return(e);
        !          1973:                        }
        !          1974:                break;
        !          1975: 
        !          1976:        case OPCALL:
        !          1977:        case OPCCALL:
        !          1978:                etype = ltype;
        !          1979:                if(rp!=NULL && rp->listblock.listp==NULL)
        !          1980:                        {
        !          1981:                        free( (charptr) rp );
        !          1982:                        rp = NULL;
        !          1983:                        }
        !          1984:                break;
        !          1985: 
        !          1986:        case OPAND:
        !          1987:        case OPOR:
        !          1988:                if( ISCONST(lp) )
        !          1989:                        COMMUTE
        !          1990: 
        !          1991:                if( ISCONST(rp) )
        !          1992:                        {
        !          1993:                        if(rp->constblock.const.ci == 0)
        !          1994:                                if(opcode == OPOR)
        !          1995:                                        goto retleft;
        !          1996:                                else
        !          1997:                                        goto retright;
        !          1998:                        else if(opcode == OPOR)
        !          1999:                                goto retright;
        !          2000:                        else
        !          2001:                                goto retleft;
        !          2002:                        }
        !          2003:        case OPLSHIFT:
        !          2004:                if (ISICON(rp))
        !          2005:                        {
        !          2006:                        if (rp->constblock.const.ci == 0)
        !          2007:                                goto retleft;
        !          2008:                        if ((lp->tag == TEXPR) &&
        !          2009:                            ((lp->exprblock.opcode == OPPLUS) ||
        !          2010:                             (lp->exprblock.opcode == OPMINUS)) &&
        !          2011:                            ISICON(lp->exprblock.rightp))
        !          2012:                                {
        !          2013:                                q1 = mkexpr(OPLSHIFT, lp->exprblock.rightp,
        !          2014:                                        cpexpr(rp));
        !          2015:                                q = mkexpr(OPLSHIFT, lp->exprblock.leftp, rp);
        !          2016:                                q = mkexpr(lp->exprblock.opcode, q, q1);
        !          2017:                                free((char *) lp);
        !          2018:                                return q;
        !          2019:                                }
        !          2020:                        }
        !          2021: 
        !          2022:        case OPEQV:
        !          2023:        case OPNEQV:
        !          2024: 
        !          2025:        case OPBITAND:
        !          2026:        case OPBITOR:
        !          2027:        case OPBITXOR:
        !          2028:        case OPBITNOT:
        !          2029:        case OPRSHIFT:
        !          2030: 
        !          2031:        case OPLT:
        !          2032:        case OPGT:
        !          2033:        case OPLE:
        !          2034:        case OPGE:
        !          2035:        case OPEQ:
        !          2036:        case OPNE:
        !          2037: 
        !          2038:        case OPCONCAT:
        !          2039:                break;
        !          2040:        case OPMIN:
        !          2041:        case OPMAX:
        !          2042: 
        !          2043:        case OPASSIGN:
        !          2044:        case OPPLUSEQ:
        !          2045:        case OPSTAREQ:
        !          2046: 
        !          2047:        case OPCONV:
        !          2048:        case OPADDR:
        !          2049: 
        !          2050:        case OPCOMMA:
        !          2051:        case OPQUEST:
        !          2052:        case OPCOLON:
        !          2053: 
        !          2054:        case OPPAREN:
        !          2055:                break;
        !          2056: 
        !          2057:        default:
        !          2058:                badop("mkexpr", opcode);
        !          2059:        }
        !          2060: 
        !          2061: e = (expptr) ALLOC(Exprblock);
        !          2062: e->exprblock.tag = TEXPR;
        !          2063: e->exprblock.opcode = opcode;
        !          2064: e->exprblock.vtype = etype;
        !          2065: e->exprblock.leftp = lp;
        !          2066: e->exprblock.rightp = rp;
        !          2067: if(ltag==TCONST && (rp==0 || rtag==TCONST) )
        !          2068:        e = fold(e);
        !          2069: return(e);
        !          2070: 
        !          2071: retleft:
        !          2072:        frexpr(rp);
        !          2073:        return(lp);
        !          2074: 
        !          2075: retright:
        !          2076:        frexpr(lp);
        !          2077:        return(rp);
        !          2078: 
        !          2079: error:
        !          2080:        frexpr(lp);
        !          2081:        if(rp && opcode!=OPCALL && opcode!=OPCCALL)
        !          2082:                frexpr(rp);
        !          2083:        return( errnode() );
        !          2084: }
        !          2085: 
        !          2086: #define ERR(s)   { errs = s; goto error; }
        !          2087: 
        !          2088: cktype(op, lt, rt)
        !          2089: register int op, lt, rt;
        !          2090: {
        !          2091: char *errs;
        !          2092: 
        !          2093: if(lt==TYERROR || rt==TYERROR)
        !          2094:        goto error1;
        !          2095: 
        !          2096: if(lt==TYUNKNOWN)
        !          2097:        return(TYUNKNOWN);
        !          2098: if(rt==TYUNKNOWN)
        !          2099:        if (op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL &&
        !          2100:            op!=OPCCALL && op!=OPADDR && op!=OPPAREN)
        !          2101:                return(TYUNKNOWN);
        !          2102: 
        !          2103: switch(op)
        !          2104:        {
        !          2105:        case OPPLUS:
        !          2106:        case OPMINUS:
        !          2107:        case OPSTAR:
        !          2108:        case OPSLASH:
        !          2109:        case OPPOWER:
        !          2110:        case OPMOD:
        !          2111:                if( ISNUMERIC(lt) && ISNUMERIC(rt) )
        !          2112:                        return( maxtype(lt, rt) );
        !          2113:                ERR("nonarithmetic operand of arithmetic operator")
        !          2114: 
        !          2115:        case OPNEG:
        !          2116:                if( ISNUMERIC(lt) )
        !          2117:                        return(lt);
        !          2118:                ERR("nonarithmetic operand of negation")
        !          2119: 
        !          2120:        case OPNOT:
        !          2121:                if(lt == TYLOGICAL)
        !          2122:                        return(TYLOGICAL);
        !          2123:                ERR("NOT of nonlogical")
        !          2124: 
        !          2125:        case OPAND:
        !          2126:        case OPOR:
        !          2127:        case OPEQV:
        !          2128:        case OPNEQV:
        !          2129:                if(lt==TYLOGICAL && rt==TYLOGICAL)
        !          2130:                        return(TYLOGICAL);
        !          2131:                ERR("nonlogical operand of logical operator")
        !          2132: 
        !          2133:        case OPLT:
        !          2134:        case OPGT:
        !          2135:        case OPLE:
        !          2136:        case OPGE:
        !          2137:        case OPEQ:
        !          2138:        case OPNE:
        !          2139:                if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
        !          2140:                        {
        !          2141:                        if(lt != rt)
        !          2142:                                ERR("illegal comparison")
        !          2143:                        }
        !          2144: 
        !          2145:                else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
        !          2146:                        {
        !          2147:                        if(op!=OPEQ && op!=OPNE)
        !          2148:                                ERR("order comparison of complex data")
        !          2149:                        }
        !          2150: 
        !          2151:                else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
        !          2152:                        ERR("comparison of nonarithmetic data")
        !          2153:                return(TYLOGICAL);
        !          2154: 
        !          2155:        case OPCONCAT:
        !          2156:                if(lt==TYCHAR && rt==TYCHAR)
        !          2157:                        return(TYCHAR);
        !          2158:                ERR("concatenation of nonchar data")
        !          2159: 
        !          2160:        case OPCALL:
        !          2161:        case OPCCALL:
        !          2162:                return(lt);
        !          2163: 
        !          2164:        case OPADDR:
        !          2165:                return(TYADDR);
        !          2166: 
        !          2167:        case OPCONV:
        !          2168:                if(ISCOMPLEX(lt))
        !          2169:                        {
        !          2170:                        if(ISNUMERIC(rt))
        !          2171:                                return(lt);
        !          2172:                        ERR("impossible conversion")
        !          2173:                        }
        !          2174:                if(rt == 0)
        !          2175:                        return(0);
        !          2176:                if(lt==TYCHAR && ISINT(rt) )
        !          2177:                        return(TYCHAR);
        !          2178:        case OPASSIGN:
        !          2179:        case OPPLUSEQ:
        !          2180:        case OPSTAREQ:
        !          2181:                if( ISINT(lt) && rt==TYCHAR)
        !          2182:                        return(lt);
        !          2183:                if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
        !          2184:                        if(op!=OPASSIGN || lt!=rt)
        !          2185:                                {
        !          2186: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
        !          2187: /* debug fatal("impossible conversion.  possible compiler bug"); */
        !          2188:                                ERR("impossible conversion")
        !          2189:                                }
        !          2190:                return(lt);
        !          2191: 
        !          2192:        case OPMIN:
        !          2193:        case OPMAX:
        !          2194:        case OPBITOR:
        !          2195:        case OPBITAND:
        !          2196:        case OPBITXOR:
        !          2197:        case OPBITNOT:
        !          2198:        case OPLSHIFT:
        !          2199:        case OPRSHIFT:
        !          2200:        case OPPAREN:
        !          2201:                return(lt);
        !          2202: 
        !          2203:        case OPCOMMA:
        !          2204:        case OPQUEST:
        !          2205:        case OPCOLON:
        !          2206:                return(rt);
        !          2207: 
        !          2208:        default:
        !          2209:                badop("cktype", op);
        !          2210:        }
        !          2211: error: err(errs);
        !          2212: error1:        return(TYERROR);
        !          2213: }
        !          2214: 
        !          2215: LOCAL expptr fold(e)
        !          2216: register expptr e;
        !          2217: {
        !          2218: Constp p;
        !          2219: register expptr lp, rp;
        !          2220: int etype, mtype, ltype, rtype, opcode;
        !          2221: int i, ll, lr;
        !          2222: char *q, *s;
        !          2223: union Constant lcon, rcon;
        !          2224: 
        !          2225: opcode = e->exprblock.opcode;
        !          2226: etype = e->exprblock.vtype;
        !          2227: 
        !          2228: lp = e->exprblock.leftp;
        !          2229: ltype = lp->headblock.vtype;
        !          2230: rp = e->exprblock.rightp;
        !          2231: 
        !          2232: if(rp == 0)
        !          2233:        switch(opcode)
        !          2234:                {
        !          2235:                case OPNOT:
        !          2236:                        lp->constblock.const.ci = ! lp->constblock.const.ci;
        !          2237:                        return(lp);
        !          2238: 
        !          2239:                case OPBITNOT:
        !          2240:                        lp->constblock.const.ci = ~ lp->constblock.const.ci;
        !          2241:                        return(lp);
        !          2242: 
        !          2243:                case OPNEG:
        !          2244:                        consnegop(lp);
        !          2245:                        return(lp);
        !          2246: 
        !          2247:                case OPCONV:
        !          2248:                case OPADDR:
        !          2249:                case OPPAREN:
        !          2250:                        return(e);
        !          2251: 
        !          2252:                default:
        !          2253:                        badop("fold", opcode);
        !          2254:                }
        !          2255: 
        !          2256: rtype = rp->headblock.vtype;
        !          2257: 
        !          2258: p = ALLOC(Constblock);
        !          2259: p->tag = TCONST;
        !          2260: p->vtype = etype;
        !          2261: p->vleng = e->exprblock.vleng;
        !          2262: 
        !          2263: switch(opcode)
        !          2264:        {
        !          2265:        case OPCOMMA:
        !          2266:        case OPQUEST:
        !          2267:        case OPCOLON:
        !          2268:                return(e);
        !          2269: 
        !          2270:        case OPAND:
        !          2271:                p->const.ci = lp->constblock.const.ci &&
        !          2272:                                rp->constblock.const.ci;
        !          2273:                break;
        !          2274: 
        !          2275:        case OPOR:
        !          2276:                p->const.ci = lp->constblock.const.ci ||
        !          2277:                                rp->constblock.const.ci;
        !          2278:                break;
        !          2279: 
        !          2280:        case OPEQV:
        !          2281:                p->const.ci = lp->constblock.const.ci ==
        !          2282:                                rp->constblock.const.ci;
        !          2283:                break;
        !          2284: 
        !          2285:        case OPNEQV:
        !          2286:                p->const.ci = lp->constblock.const.ci !=
        !          2287:                                rp->constblock.const.ci;
        !          2288:                break;
        !          2289: 
        !          2290:        case OPBITAND:
        !          2291:                p->const.ci = lp->constblock.const.ci &
        !          2292:                                rp->constblock.const.ci;
        !          2293:                break;
        !          2294: 
        !          2295:        case OPBITOR:
        !          2296:                p->const.ci = lp->constblock.const.ci |
        !          2297:                                rp->constblock.const.ci;
        !          2298:                break;
        !          2299: 
        !          2300:        case OPBITXOR:
        !          2301:                p->const.ci = lp->constblock.const.ci ^
        !          2302:                                rp->constblock.const.ci;
        !          2303:                break;
        !          2304: 
        !          2305:        case OPLSHIFT:
        !          2306:                p->const.ci = lp->constblock.const.ci <<
        !          2307:                                rp->constblock.const.ci;
        !          2308:                break;
        !          2309: 
        !          2310:        case OPRSHIFT:
        !          2311:                p->const.ci = lp->constblock.const.ci >>
        !          2312:                                rp->constblock.const.ci;
        !          2313:                break;
        !          2314: 
        !          2315:        case OPCONCAT:
        !          2316:                ll = lp->constblock.vleng->constblock.const.ci;
        !          2317:                lr = rp->constblock.vleng->constblock.const.ci;
        !          2318:                p->const.ccp = q = (char *) ckalloc(ll+lr);
        !          2319:                p->vleng = ICON(ll+lr);
        !          2320:                s = lp->constblock.const.ccp;
        !          2321:                for(i = 0 ; i < ll ; ++i)
        !          2322:                        *q++ = *s++;
        !          2323:                s = rp->constblock.const.ccp;
        !          2324:                for(i = 0; i < lr; ++i)
        !          2325:                        *q++ = *s++;
        !          2326:                break;
        !          2327: 
        !          2328: 
        !          2329:        case OPPOWER:
        !          2330:                if( ! ISINT(rtype) )
        !          2331:                        return(e);
        !          2332:                conspower(&(p->const), lp, rp->constblock.const.ci);
        !          2333:                break;
        !          2334: 
        !          2335: 
        !          2336:        default:
        !          2337:                if(ltype == TYCHAR)
        !          2338:                        {
        !          2339:                        lcon.ci = cmpstr(lp->constblock.const.ccp,
        !          2340:                                        rp->constblock.const.ccp,
        !          2341:                                        lp->constblock.vleng->constblock.const.ci,
        !          2342:                                        rp->constblock.vleng->constblock.const.ci);
        !          2343:                        rcon.ci = 0;
        !          2344:                        mtype = tyint;
        !          2345:                        }
        !          2346:                else    {
        !          2347:                        mtype = maxtype(ltype, rtype);
        !          2348:                        consconv(mtype, &lcon, ltype, &(lp->constblock.const) );
        !          2349:                        consconv(mtype, &rcon, rtype, &(rp->constblock.const) );
        !          2350:                        }
        !          2351:                consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
        !          2352:                break;
        !          2353:        }
        !          2354: 
        !          2355: frexpr(e);
        !          2356: return( (expptr) p );
        !          2357: }
        !          2358: 
        !          2359: 
        !          2360: 
        !          2361: /* assign constant l = r , doing coercion */
        !          2362: 
        !          2363: consconv(lt, lv, rt, rv)
        !          2364: int lt, rt;
        !          2365: register union Constant *lv, *rv;
        !          2366: {
        !          2367: switch(lt)
        !          2368:        {
        !          2369:        case TYCHAR:
        !          2370:                *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
        !          2371:                break;
        !          2372: 
        !          2373:        case TYSHORT:
        !          2374:        case TYLONG:
        !          2375:                if(rt == TYCHAR)
        !          2376:                        lv->ci = rv->ccp[0];
        !          2377:                else if( ISINT(rt) )
        !          2378:                        lv->ci = rv->ci;
        !          2379:                else    lv->ci = rv->cd[0];
        !          2380:                break;
        !          2381: 
        !          2382:        case TYCOMPLEX:
        !          2383:        case TYDCOMPLEX:
        !          2384:                switch(rt)
        !          2385:                        {
        !          2386:                        case TYSHORT:
        !          2387:                        case TYLONG:
        !          2388:                                /* fall through and do real assignment of
        !          2389:                                   first element
        !          2390:                                */
        !          2391:                        case TYREAL:
        !          2392:                        case TYDREAL:
        !          2393:                                lv->cd[1] = 0; break;
        !          2394:                        case TYCOMPLEX:
        !          2395:                        case TYDCOMPLEX:
        !          2396:                                lv->cd[1] = rv->cd[1]; break;
        !          2397:                        }
        !          2398: 
        !          2399:        case TYREAL:
        !          2400:        case TYDREAL:
        !          2401:                if( ISINT(rt) )
        !          2402:                        lv->cd[0] = rv->ci;
        !          2403:                else    lv->cd[0] = rv->cd[0];
        !          2404:                if( lt == TYREAL)
        !          2405:                        {
        !          2406:                        float f = lv->cd[0];
        !          2407:                        lv->cd[0] = f;
        !          2408:                        }
        !          2409:                break;
        !          2410: 
        !          2411:        case TYLOGICAL:
        !          2412:                lv->ci = rv->ci;
        !          2413:                break;
        !          2414:        }
        !          2415: }
        !          2416: 
        !          2417: 
        !          2418: 
        !          2419: consnegop(p)
        !          2420: register Constp p;
        !          2421: {
        !          2422: switch(p->vtype)
        !          2423:        {
        !          2424:        case TYSHORT:
        !          2425:        case TYLONG:
        !          2426:                p->const.ci = - p->const.ci;
        !          2427:                break;
        !          2428: 
        !          2429:        case TYCOMPLEX:
        !          2430:        case TYDCOMPLEX:
        !          2431:                p->const.cd[1] = - p->const.cd[1];
        !          2432:                /* fall through and do the real parts */
        !          2433:        case TYREAL:
        !          2434:        case TYDREAL:
        !          2435:                p->const.cd[0] = - p->const.cd[0];
        !          2436:                break;
        !          2437:        default:
        !          2438:                badtype("consnegop", p->vtype);
        !          2439:        }
        !          2440: }
        !          2441: 
        !          2442: 
        !          2443: 
        !          2444: LOCAL conspower(powp, ap, n)
        !          2445: register union Constant *powp;
        !          2446: Constp ap;
        !          2447: ftnint n;
        !          2448: {
        !          2449: register int type;
        !          2450: union Constant x;
        !          2451: 
        !          2452: switch(type = ap->vtype)       /* pow = 1 */ 
        !          2453:        {
        !          2454:        case TYSHORT:
        !          2455:        case TYLONG:
        !          2456:                powp->ci = 1;
        !          2457:                break;
        !          2458:        case TYCOMPLEX:
        !          2459:        case TYDCOMPLEX:
        !          2460:                powp->cd[1] = 0;
        !          2461:        case TYREAL:
        !          2462:        case TYDREAL:
        !          2463:                powp->cd[0] = 1;
        !          2464:                break;
        !          2465:        default:
        !          2466:                badtype("conspower", type);
        !          2467:        }
        !          2468: 
        !          2469: if(n == 0)
        !          2470:        return;
        !          2471: if(n < 0)
        !          2472:        {
        !          2473:        if( ISINT(type) )
        !          2474:                {
        !          2475:                if (ap->const.ci == 0)
        !          2476:                        err("zero raised to a negative power");
        !          2477:                else if (ap->const.ci == 1)
        !          2478:                        return;
        !          2479:                else if (ap->const.ci == -1)
        !          2480:                        {
        !          2481:                        if (n < -2)
        !          2482:                                n = n + 2;
        !          2483:                        n = -n;
        !          2484:                        if (n % 2 == 1)
        !          2485:                                powp->ci = -1;
        !          2486:                        }
        !          2487:                else
        !          2488:                        powp->ci = 0;
        !          2489:                return;
        !          2490:                }
        !          2491:        n = - n;
        !          2492:        consbinop(OPSLASH, type, &x, powp, &(ap->const));
        !          2493:        }
        !          2494: else
        !          2495:        consbinop(OPSTAR, type, &x, powp, &(ap->const));
        !          2496: 
        !          2497: for( ; ; )
        !          2498:        {
        !          2499:        if(n & 01)
        !          2500:                consbinop(OPSTAR, type, powp, powp, &x);
        !          2501:        if(n >>= 1)
        !          2502:                consbinop(OPSTAR, type, &x, &x, &x);
        !          2503:        else
        !          2504:                break;
        !          2505:        }
        !          2506: }
        !          2507: 
        !          2508: 
        !          2509: 
        !          2510: /* do constant operation cp = a op b */
        !          2511: 
        !          2512: 
        !          2513: LOCAL consbinop(opcode, type, cp, ap, bp)
        !          2514: int opcode, type;
        !          2515: register union Constant *ap, *bp, *cp;
        !          2516: {
        !          2517: int k;
        !          2518: double temp;
        !          2519: 
        !          2520: switch(opcode)
        !          2521:        {
        !          2522:        case OPPLUS:
        !          2523:                switch(type)
        !          2524:                        {
        !          2525:                        case TYSHORT:
        !          2526:                        case TYLONG:
        !          2527:                                cp->ci = ap->ci + bp->ci;
        !          2528:                                break;
        !          2529:                        case TYCOMPLEX:
        !          2530:                        case TYDCOMPLEX:
        !          2531:                                cp->cd[1] = ap->cd[1] + bp->cd[1];
        !          2532:                        case TYREAL:
        !          2533:                        case TYDREAL:
        !          2534:                                cp->cd[0] = ap->cd[0] + bp->cd[0];
        !          2535:                                break;
        !          2536:                        }
        !          2537:                break;
        !          2538: 
        !          2539:        case OPMINUS:
        !          2540:                switch(type)
        !          2541:                        {
        !          2542:                        case TYSHORT:
        !          2543:                        case TYLONG:
        !          2544:                                cp->ci = ap->ci - bp->ci;
        !          2545:                                break;
        !          2546:                        case TYCOMPLEX:
        !          2547:                        case TYDCOMPLEX:
        !          2548:                                cp->cd[1] = ap->cd[1] - bp->cd[1];
        !          2549:                        case TYREAL:
        !          2550:                        case TYDREAL:
        !          2551:                                cp->cd[0] = ap->cd[0] - bp->cd[0];
        !          2552:                                break;
        !          2553:                        }
        !          2554:                break;
        !          2555: 
        !          2556:        case OPSTAR:
        !          2557:                switch(type)
        !          2558:                        {
        !          2559:                        case TYSHORT:
        !          2560:                        case TYLONG:
        !          2561:                                cp->ci = ap->ci * bp->ci;
        !          2562:                                break;
        !          2563:                        case TYREAL:
        !          2564:                        case TYDREAL:
        !          2565:                                cp->cd[0] = ap->cd[0] * bp->cd[0];
        !          2566:                                break;
        !          2567:                        case TYCOMPLEX:
        !          2568:                        case TYDCOMPLEX:
        !          2569:                                temp = ap->cd[0] * bp->cd[0] -
        !          2570:                                            ap->cd[1] * bp->cd[1] ;
        !          2571:                                cp->cd[1] = ap->cd[0] * bp->cd[1] +
        !          2572:                                            ap->cd[1] * bp->cd[0] ;
        !          2573:                                cp->cd[0] = temp;
        !          2574:                                break;
        !          2575:                        }
        !          2576:                break;
        !          2577:        case OPSLASH:
        !          2578:                switch(type)
        !          2579:                        {
        !          2580:                        case TYSHORT:
        !          2581:                        case TYLONG:
        !          2582:                                cp->ci = ap->ci / bp->ci;
        !          2583:                                break;
        !          2584:                        case TYREAL:
        !          2585:                        case TYDREAL:
        !          2586:                                cp->cd[0] = ap->cd[0] / bp->cd[0];
        !          2587:                                break;
        !          2588:                        case TYCOMPLEX:
        !          2589:                        case TYDCOMPLEX:
        !          2590:                                zdiv(cp,ap,bp);
        !          2591:                                break;
        !          2592:                        }
        !          2593:                break;
        !          2594: 
        !          2595:        case OPMOD:
        !          2596:                if( ISINT(type) )
        !          2597:                        {
        !          2598:                        cp->ci = ap->ci % bp->ci;
        !          2599:                        break;
        !          2600:                        }
        !          2601:                else
        !          2602:                        fatal("inline mod of noninteger");
        !          2603: 
        !          2604:        default:          /* relational ops */
        !          2605:                switch(type)
        !          2606:                        {
        !          2607:                        case TYSHORT:
        !          2608:                        case TYLONG:
        !          2609:                                if(ap->ci < bp->ci)
        !          2610:                                        k = -1;
        !          2611:                                else if(ap->ci == bp->ci)
        !          2612:                                        k = 0;
        !          2613:                                else    k = 1;
        !          2614:                                break;
        !          2615:                        case TYREAL:
        !          2616:                        case TYDREAL:
        !          2617:                                if(ap->cd[0] < bp->cd[0])
        !          2618:                                        k = -1;
        !          2619:                                else if(ap->cd[0] == bp->cd[0])
        !          2620:                                        k = 0;
        !          2621:                                else    k = 1;
        !          2622:                                break;
        !          2623:                        case TYCOMPLEX:
        !          2624:                        case TYDCOMPLEX:
        !          2625:                                if(ap->cd[0] == bp->cd[0] &&
        !          2626:                                   ap->cd[1] == bp->cd[1] )
        !          2627:                                        k = 0;
        !          2628:                                else    k = 1;
        !          2629:                                break;
        !          2630:                        }
        !          2631: 
        !          2632:                switch(opcode)
        !          2633:                        {
        !          2634:                        case OPEQ:
        !          2635:                                cp->ci = (k == 0);
        !          2636:                                break;
        !          2637:                        case OPNE:
        !          2638:                                cp->ci = (k != 0);
        !          2639:                                break;
        !          2640:                        case OPGT:
        !          2641:                                cp->ci = (k == 1);
        !          2642:                                break;
        !          2643:                        case OPLT:
        !          2644:                                cp->ci = (k == -1);
        !          2645:                                break;
        !          2646:                        case OPGE:
        !          2647:                                cp->ci = (k >= 0);
        !          2648:                                break;
        !          2649:                        case OPLE:
        !          2650:                                cp->ci = (k <= 0);
        !          2651:                                break;
        !          2652:                        default:
        !          2653:                                badop ("consbinop", opcode);
        !          2654:                        }
        !          2655:                break;
        !          2656:        }
        !          2657: }
        !          2658: 
        !          2659: 
        !          2660: 
        !          2661: 
        !          2662: conssgn(p)
        !          2663: register expptr p;
        !          2664: {
        !          2665: if( ! ISCONST(p) )
        !          2666:        fatal( "sgn(nonconstant)" );
        !          2667: 
        !          2668: switch(p->headblock.vtype)
        !          2669:        {
        !          2670:        case TYSHORT:
        !          2671:        case TYLONG:
        !          2672:                if(p->constblock.const.ci > 0) return(1);
        !          2673:                if(p->constblock.const.ci < 0) return(-1);
        !          2674:                return(0);
        !          2675: 
        !          2676:        case TYREAL:
        !          2677:        case TYDREAL:
        !          2678:                if(p->constblock.const.cd[0] > 0) return(1);
        !          2679:                if(p->constblock.const.cd[0] < 0) return(-1);
        !          2680:                return(0);
        !          2681: 
        !          2682:        case TYCOMPLEX:
        !          2683:        case TYDCOMPLEX:
        !          2684:                return(p->constblock.const.cd[0]!=0 || p->constblock.const.cd[1]!=0);
        !          2685: 
        !          2686:        default:
        !          2687:                badtype( "conssgn", p->constblock.vtype);
        !          2688:        }
        !          2689: /* NOTREACHED */
        !          2690: }
        !          2691: 
        !          2692: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
        !          2693: 
        !          2694: 
        !          2695: LOCAL expptr mkpower(p)
        !          2696: register expptr p;
        !          2697: {
        !          2698: register expptr q, lp, rp;
        !          2699: int ltype, rtype, mtype;
        !          2700: 
        !          2701: lp = p->exprblock.leftp;
        !          2702: rp = p->exprblock.rightp;
        !          2703: ltype = lp->headblock.vtype;
        !          2704: rtype = rp->headblock.vtype;
        !          2705: 
        !          2706: if(ISICON(rp))
        !          2707:        {
        !          2708:        if(rp->constblock.const.ci == 0)
        !          2709:                {
        !          2710:                frexpr(p);
        !          2711:                if( ISINT(ltype) )
        !          2712:                        return( ICON(1) );
        !          2713:                else
        !          2714:                        {
        !          2715:                        expptr pp;
        !          2716:                        pp = mkconv(ltype, ICON(1));
        !          2717:                        return( pp );
        !          2718:                        }
        !          2719:                }
        !          2720:        if(rp->constblock.const.ci < 0)
        !          2721:                {
        !          2722:                if( ISINT(ltype) )
        !          2723:                        {
        !          2724:                        frexpr(p);
        !          2725:                        err("integer**negative");
        !          2726:                        return( errnode() );
        !          2727:                        }
        !          2728:                rp->constblock.const.ci = - rp->constblock.const.ci;
        !          2729:                p->exprblock.leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
        !          2730:                }
        !          2731:        if(rp->constblock.const.ci == 1)
        !          2732:                {
        !          2733:                frexpr(rp);
        !          2734:                free( (charptr) p );
        !          2735:                return(lp);
        !          2736:                }
        !          2737: 
        !          2738:        if( ONEOF(ltype, MSKINT|MSKREAL) )
        !          2739:                {
        !          2740:                p->exprblock.vtype = ltype;
        !          2741:                return(p);
        !          2742:                }
        !          2743:        }
        !          2744: if( ISINT(rtype) )
        !          2745:        {
        !          2746:        if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
        !          2747:                q = call2(TYSHORT, "pow_hh", lp, rp);
        !          2748:        else    {
        !          2749:                if(ltype == TYSHORT)
        !          2750:                        {
        !          2751:                        ltype = TYLONG;
        !          2752:                        lp = mkconv(TYLONG,lp);
        !          2753:                        }
        !          2754:                q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
        !          2755:                }
        !          2756:        }
        !          2757: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
        !          2758:        q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
        !          2759: else   {
        !          2760:        q  = call2(TYDCOMPLEX, "pow_zz",
        !          2761:                mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
        !          2762:        if(mtype == TYCOMPLEX)
        !          2763:                q = mkconv(TYCOMPLEX, q);
        !          2764:        }
        !          2765: free( (charptr) p );
        !          2766: return(q);
        !          2767: }
        !          2768: 
        !          2769: 
        !          2770: 
        !          2771: /* Complex Division.  Same code as in Runtime Library
        !          2772: */
        !          2773: 
        !          2774: struct dcomplex { double dreal, dimag; };
        !          2775: 
        !          2776: 
        !          2777: LOCAL zdiv(c, a, b)
        !          2778: register struct dcomplex *a, *b, *c;
        !          2779: {
        !          2780: double ratio, den;
        !          2781: double abr, abi;
        !          2782: 
        !          2783: if( (abr = b->dreal) < 0.)
        !          2784:        abr = - abr;
        !          2785: if( (abi = b->dimag) < 0.)
        !          2786:        abi = - abi;
        !          2787: if( abr <= abi )
        !          2788:        {
        !          2789:        if(abi == 0)
        !          2790:                fatal("complex division by zero");
        !          2791:        ratio = b->dreal / b->dimag ;
        !          2792:        den = b->dimag * (1 + ratio*ratio);
        !          2793:        c->dreal = (a->dreal*ratio + a->dimag) / den;
        !          2794:        c->dimag = (a->dimag*ratio - a->dreal) / den;
        !          2795:        }
        !          2796: 
        !          2797: else
        !          2798:        {
        !          2799:        ratio = b->dimag / b->dreal ;
        !          2800:        den = b->dreal * (1 + ratio*ratio);
        !          2801:        c->dreal = (a->dreal + a->dimag*ratio) / den;
        !          2802:        c->dimag = (a->dimag - a->dreal*ratio) / den;
        !          2803:        }
        !          2804: 
        !          2805: }
        !          2806: 
        !          2807: expptr oftwo(e)
        !          2808: expptr e;
        !          2809: {
        !          2810:        int val,res;
        !          2811: 
        !          2812:        if (! ISCONST (e))
        !          2813:                return (0);
        !          2814: 
        !          2815:        val = e->constblock.const.ci;
        !          2816:        switch (val)
        !          2817:                {
        !          2818:                case 2:         res = 1; break;
        !          2819:                case 4:         res = 2; break;
        !          2820:                case 8:         res = 3; break;
        !          2821:                case 16:        res = 4; break;
        !          2822:                case 32:        res = 5; break;
        !          2823:                case 64:        res = 6; break;
        !          2824:                case 128:       res = 7; break;
        !          2825:                case 256:       res = 8; break;
        !          2826:                default:        return (0);
        !          2827:                }
        !          2828:        return (ICON (res));
        !          2829: }

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