Return to put.c CVS log

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

Annotation of researchv10no/cmd/f2c/put.c, revision 1.1

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
        !             3: 
        !             4: Permission to use, copy, modify, and distribute this software
        !             5: and its documentation for any purpose and without fee is hereby
        !             6: granted, provided that the above copyright notice appear in all
        !             7: copies and that both that the copyright notice and this
        !             8: permission notice and warranty disclaimer appear in supporting
        !             9: documentation, and that the names of AT&T Bell Laboratories or
        !            10: Bellcore or any of their entities not be used in advertising or
        !            11: publicity pertaining to distribution of the software without
        !            12: specific, written prior permission.
        !            13: 
        !            14: AT&T and Bellcore disclaim all warranties with regard to this
        !            15: software, including all implied warranties of merchantability
        !            16: and fitness.  In no event shall AT&T or Bellcore be liable for
        !            17: any special, indirect or consequential damages or any damages
        !            18: whatsoever resulting from loss of use, data or profits, whether
        !            19: in an action of contract, negligence or other tortious action,
        !            20: arising out of or in connection with the use or performance of
        !            21: this software.
        !            22: ****************************************************************/
        !            23: 
        !            24: /*
        !            25:  * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
        !            26:  * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
        !            27: */
        !            28: 
        !            29: #include "defs.h"
        !            30: #include "names.h"             /* For LOCAL_CONST_NAME */
        !            31: #include "pccdefs.h"
        !            32: #include "p1defs.h"
        !            33: 
        !            34: /* Definitions for   putconst()   */
        !            35: 
        !            36: #define LIT_CHAR 1
        !            37: #define LIT_FLOAT 2
        !            38: #define LIT_INT 3
        !            39: 
        !            40: 
        !            41: /*
        !            42: char *ops [ ] =
        !            43:        {
        !            44:        "??", "+", "-", "*", "/", "**", "-",
        !            45:        "OR", "AND", "EQV", "NEQV", "NOT",
        !            46:        "CONCAT",
        !            47:        "<", "==", ">", "<=", "!=", ">=",
        !            48:        " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
        !            49:        " , ", " ? ", " : "
        !            50:        " abs ", " min ", " max ", " addr ", " indirect ",
        !            51:        " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
        !            52:        };
        !            53: */
        !            54: 
        !            55: /* Each of these values is defined in   pccdefs   */
        !            56: 
        !            57: int ops2 [ ] =
        !            58: {
        !            59:        P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
        !            60:        P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
        !            61:        P2BAD,
        !            62:        P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
        !            63:        P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
        !            64:        P2COMOP, P2QUEST, P2COLON,
        !            65:        1, P2BAD, P2BAD, P2BAD, P2BAD,
        !            66:        P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
        !            67:        P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
        !            68:        P2BAD, P2BAD, P2BAD, P2BAD,
        !            69:        1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
        !            70:        1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
        !            71: };
        !            72: 
        !            73: 
        !            74: setlog()
        !            75: {
        !            76:        typesize[TYLOGICAL] = typesize[tylogical];
        !            77:        typealign[TYLOGICAL] = typealign[tylogical];
        !            78: }
        !            79: 
        !            80: 
        !            81: putexpr(p)
        !            82: expptr p;
        !            83: {
        !            84: /* Write the expression to the p1 file */
        !            85: 
        !            86:        p = (expptr) putx (fixtype (p));
        !            87:        p1_expr (p);
        !            88: }
        !            89: 
        !            90: 
        !            91: 
        !            92: 
        !            93: 
        !            94: expptr putassign(lp, rp)
        !            95: expptr lp, rp;
        !            96: {
        !            97:        return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
        !            98: }
        !            99: 
        !           100: 
        !           101: 
        !           102: 
        !           103: void puteq(lp, rp)
        !           104: expptr lp, rp;
        !           105: {
        !           106:        putexpr(mkexpr(OPASSIGN, lp, rp) );
        !           107: }
        !           108: 
        !           109: 
        !           110: 
        !           111: 
        !           112: /* put code for  a *= b */
        !           113: 
        !           114: expptr putsteq(a, b)
        !           115: Addrp a, b;
        !           116: {
        !           117:        return putx( fixexpr((Exprp)
        !           118:                mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
        !           119: }
        !           120: 
        !           121: 
        !           122: 
        !           123: 
        !           124: Addrp mkfield(res, f, ty)
        !           125: register Addrp res;
        !           126: char *f;
        !           127: int ty;
        !           128: {
        !           129:     res -> vtype = ty;
        !           130:     res -> Field = f;
        !           131:     return res;
        !           132: } /* mkfield */
        !           133: 
        !           134: 
        !           135: Addrp realpart(p)
        !           136: register Addrp p;
        !           137: {
        !           138:        register Addrp q;
        !           139:        expptr mkrealcon();
        !           140: 
        !           141:        if (p->tag == TADDR
        !           142:         && p->uname_tag == UNAM_CONST
        !           143:         && ISCOMPLEX (p->vtype))
        !           144:                return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
        !           145:                        p->user.kludge.vstg1 ? p->user.Const.cds[0]
        !           146:                                : cds(dtos(p->user.Const.cd[0]),CNULL));
        !           147: 
        !           148:        q = (Addrp) cpexpr((expptr) p);
        !           149:        if( ISCOMPLEX(p->vtype) )
        !           150:                q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
        !           151: 
        !           152:        return(q);
        !           153: }
        !           154: 
        !           155: 
        !           156: 
        !           157: 
        !           158: expptr imagpart(p)
        !           159: register Addrp p;
        !           160: {
        !           161:        register Addrp q;
        !           162:        expptr mkrealcon();
        !           163: 
        !           164:        if( ISCOMPLEX(p->vtype) )
        !           165:        {
        !           166:                if (p->tag == TADDR && p->uname_tag == UNAM_CONST)
        !           167:                        return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
        !           168:                                p->user.kludge.vstg1 ? p->user.Const.cds[1]
        !           169:                                : cds(dtos(p->user.Const.cd[1]),CNULL));
        !           170:                q = (Addrp) cpexpr((expptr) p);
        !           171:                q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
        !           172:                return( (expptr) q );
        !           173:        }
        !           174:        else
        !           175: 
        !           176: /* Cast an integer type onto a Double Real type */
        !           177: 
        !           178:                return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
        !           179: }
        !           180: 
        !           181: 
        !           182: 
        !           183: 
        !           184: 
        !           185: /* ncat -- computes the number of adjacent concatenation operations */
        !           186: 
        !           187: ncat(p)
        !           188: register expptr p;
        !           189: {
        !           190:        if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
        !           191:                return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
        !           192:        else    return(1);
        !           193: }
        !           194: 
        !           195: 
        !           196: 
        !           197: 
        !           198: /* lencat -- returns the length of the concatenated string.  Each
        !           199:    substring must have a static (i.e. compile-time) fixed length */
        !           200: 
        !           201: ftnint lencat(p)
        !           202: register expptr p;
        !           203: {
        !           204:        if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
        !           205:                return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
        !           206:        else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
        !           207:                return(p->headblock.vleng->constblock.Const.ci);
        !           208:        else if(p->tag==TADDR && p->addrblock.varleng!=0)
        !           209:                return(p->addrblock.varleng);
        !           210:        else
        !           211:        {
        !           212:                err("impossible element in concatenation");
        !           213:                return(0);
        !           214:        }
        !           215: }
        !           216: 
        !           217: /* putconst -- Creates a new Addrp value which maps onto the input
        !           218:    constant value.  The Addrp doesn't retain the value of the constant,
        !           219:    instead that value is copied into a table of constants (called
        !           220:    litpool,   for pool of literal values).  The only way to retrieve the
        !           221:    actual value of the constant is to look at the   memno   field of the
        !           222:    Addrp result.  You know that the associated literal is the one referred
        !           223:    to by   q   when   (q -> memno == litp -> litnum).
        !           224: */
        !           225: 
        !           226: Addrp putconst(p)
        !           227: register Constp p;
        !           228: {
        !           229:        register Addrp q;
        !           230:        struct Literal *litp, *lastlit;
        !           231:        int k, len, type;
        !           232:        int litflavor;
        !           233:        double cd[2];
        !           234:        ftnint nblanks;
        !           235:        char *strp;
        !           236:        char cdsbuf0[64], cdsbuf1[64], *ds[2];
        !           237: 
        !           238:        if (p->tag != TCONST)
        !           239:                badtag("putconst", p->tag);
        !           240: 
        !           241:        q = ALLOC(Addrblock);
        !           242:        q->tag = TADDR;
        !           243:        type = p->vtype;
        !           244:        q->vtype = ( type==TYADDR ? tyint : type );
        !           245:        q->vleng = (expptr) cpexpr(p->vleng);
        !           246:        q->vstg = STGCONST;
        !           247: 
        !           248: /* Create the new label for the constant.  This is wasteful of labels
        !           249:    because when the constant value already exists in the literal pool,
        !           250:    this label gets thrown away and is never reclaimed.  It might be
        !           251:    cleaner to move this down past the first   switch()   statement below */
        !           252: 
        !           253:        q->memno = newlabel();
        !           254:        q->memoffset = ICON(0);
        !           255:        q -> uname_tag = UNAM_CONST;
        !           256: 
        !           257: /* Copy the constant info into the Addrblock; do this by copying the
        !           258:    largest storage elts */
        !           259: 
        !           260:        q -> user.Const = p -> Const;
        !           261:        q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */
        !           262: 
        !           263:        /* check for value in literal pool, and update pool if necessary */
        !           264: 
        !           265:        k = 1;
        !           266:        switch(type)
        !           267:        {
        !           268:        case TYCHAR:
        !           269:                if (halign) {
        !           270:                        strp = p->Const.ccp;
        !           271:                        nblanks = p->Const.ccp1.blanks;
        !           272:                        len = p->vleng->constblock.Const.ci;
        !           273:                        litflavor = LIT_CHAR;
        !           274:                        goto loop;
        !           275:                        }
        !           276:                else
        !           277:                        q->memno = BAD_MEMNO;
        !           278:                break;
        !           279:        case TYCOMPLEX:
        !           280:        case TYDCOMPLEX:
        !           281:                k = 2;
        !           282:                if (p->vstg)
        !           283:                        cd[1] = atof(ds[1] = p->Const.cds[1]);
        !           284:                else
        !           285:                        ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
        !           286:        case TYREAL:
        !           287:        case TYDREAL:
        !           288:                litflavor = LIT_FLOAT;
        !           289:                if (p->vstg)
        !           290:                        cd[0] = atof(ds[0] = p->Const.cds[0]);
        !           291:                else
        !           292:                        ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
        !           293:                goto loop;
        !           294: 
        !           295:        case TYLOGICAL1:
        !           296:        case TYLOGICAL2:
        !           297:        case TYLOGICAL:
        !           298:                type = tylogical;
        !           299:                goto lit_int_flavor;
        !           300:        case TYLONG:
        !           301:                type = tyint;
        !           302:        case TYSHORT:
        !           303:        case TYINT1:
        !           304: #ifdef TYQUAD
        !           305:        case TYQUAD:
        !           306: #endif
        !           307:  lit_int_flavor:
        !           308:                litflavor = LIT_INT;
        !           309: 
        !           310: /* Scan the literal pool for this constant value.  If this same constant
        !           311:    has been assigned before, use the same label.  Note that this routine
        !           312:    does NOT consider two differently-typed constants with the same bit
        !           313:    pattern to be the same constant */
        !           314: 
        !           315:  loop:
        !           316:                lastlit = litpool + nliterals;
        !           317:                for(litp = litpool ; litp<lastlit ; ++litp)
        !           318: 
        !           319: /* Remove this type checking to ensure that all bit patterns are reused */
        !           320: 
        !           321:                        if(type == litp->littype) switch(litflavor)
        !           322:                        {
        !           323:                        case LIT_CHAR:
        !           324:                                if (len == (int)litp->litval.litival2[0]
        !           325:                                && nblanks == litp->litval.litival2[1]
        !           326:                                && !memcmp(strp, litp->cds[0], len)) {
        !           327:                                        q->memno = litp->litnum;
        !           328:                                        frexpr((expptr)p);
        !           329:                                        q->user.Const.ccp1.ccp0 = litp->cds[0];
        !           330:                                        return(q);
        !           331:                                        }
        !           332:                                break;
        !           333:                        case LIT_FLOAT:
        !           334:                                if(cd[0] == litp->litval.litdval[0]
        !           335:                                && !strcmp(ds[0], litp->cds[0])
        !           336:                                && (k == 1 ||
        !           337:                                    cd[1] == litp->litval.litdval[1]
        !           338:                                    && !strcmp(ds[1], litp->cds[1]))) {
        !           339: ret:
        !           340:                                        q->memno = litp->litnum;
        !           341:                                        frexpr((expptr)p);
        !           342:                                        return(q);
        !           343:                                        }
        !           344:                                break;
        !           345: 
        !           346:                        case LIT_INT:
        !           347:                                if(p->Const.ci == litp->litval.litival)
        !           348:                                        goto ret;
        !           349:                                break;
        !           350:                        }
        !           351: 
        !           352: /* If there's room in the literal pool, add this new value to the pool */
        !           353: 
        !           354:                if(nliterals < maxliterals)
        !           355:                {
        !           356:                        ++nliterals;
        !           357: 
        !           358:                        /* litp   now points to the next free elt */
        !           359: 
        !           360:                        litp->littype = type;
        !           361:                        litp->litnum = q->memno;
        !           362:                        switch(litflavor)
        !           363:                        {
        !           364:                        case LIT_CHAR:
        !           365:                                litp->litval.litival2[0] = len;
        !           366:                                litp->litval.litival2[1] = nblanks;
        !           367:                                q->user.Const.ccp = litp->cds[0] =
        !           368:                                        memcpy(gmem(len,0), strp, len);
        !           369:                                break;
        !           370: 
        !           371:                        case LIT_FLOAT:
        !           372:                                litp->litval.litdval[0] = cd[0];
        !           373:                                litp->cds[0] = copys(ds[0]);
        !           374:                                if (k == 2) {
        !           375:                                        litp->litval.litdval[1] = cd[1];
        !           376:                                        litp->cds[1] = copys(ds[1]);
        !           377:                                        }
        !           378:                                break;
        !           379: 
        !           380:                        case LIT_INT:
        !           381:                                litp->litval.litival = p->Const.ci;
        !           382:                                break;
        !           383:                        } /* switch (litflavor) */
        !           384:                }
        !           385:                else
        !           386:                        many("literal constants", 'L', maxliterals);
        !           387: 
        !           388:                break;
        !           389:        case TYADDR:
        !           390:            break;
        !           391:        default:
        !           392:                badtype ("putconst", p -> vtype);
        !           393:                break;
        !           394:        } /* switch */
        !           395: 
        !           396:        if (type != TYCHAR || halign)
        !           397:            frexpr((expptr)p);
        !           398:        return( q );
        !           399: }

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