示例#1
0
文件: put.c 项目: barak/f2c-1
putconst(register Constp p)
#endif
{
    register Addrp q;
    struct Literal *litp, *lastlit;
    int k, len, type;
    int litflavor;
    double cd[2];
    ftnint nblanks;
    char *strp;
    char cdsbuf0[64], cdsbuf1[64], *ds[2];

    if (p->tag != TCONST)
        badtag("putconst", p->tag);

    q = ALLOC(Addrblock);
    q->tag = TADDR;
    type = p->vtype;
    q->vtype = ( type==TYADDR ? tyint : type );
    q->vleng = (expptr) cpexpr(p->vleng);
    q->vstg = STGCONST;

    /* Create the new label for the constant.  This is wasteful of labels
       because when the constant value already exists in the literal pool,
       this label gets thrown away and is never reclaimed.  It might be
       cleaner to move this down past the first   switch()   statement below */

    q->memno = newlabel();
    q->memoffset = ICON(0);
    q -> uname_tag = UNAM_CONST;

    /* Copy the constant info into the Addrblock; do this by copying the
       largest storage elts */

    q -> user.Const = p -> Const;
    q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */

    /* check for value in literal pool, and update pool if necessary */

    k = 1;
    switch(type)
    {
    case TYCHAR:
        if (halign) {
            strp = p->Const.ccp;
            nblanks = p->Const.ccp1.blanks;
            len = (int)p->vleng->constblock.Const.ci;
            litflavor = LIT_CHAR;
            goto loop;
        }
        else
            q->memno = BAD_MEMNO;
        break;
    case TYCOMPLEX:
    case TYDCOMPLEX:
        k = 2;
        if (p->vstg)
            cd[1] = atof(ds[1] = p->Const.cds[1]);
        else
            ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
    case TYREAL:
    case TYDREAL:
        litflavor = LIT_FLOAT;
        if (p->vstg)
            cd[0] = atof(ds[0] = p->Const.cds[0]);
        else
            ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
        goto loop;

#ifndef NO_LONG_LONG
    case TYQUAD:
        litflavor = LIT_INTQ;
        goto loop;
#endif

    case TYLOGICAL1:
    case TYLOGICAL2:
    case TYLOGICAL:
    case TYLONG:
    case TYSHORT:
    case TYINT1:
#ifdef TYQUAD0
    case TYQUAD:
#endif
        litflavor = LIT_INT;

        /* Scan the literal pool for this constant value.  If this same constant
           has been assigned before, use the same label.  Note that this routine
           does NOT consider two differently-typed constants with the same bit
           pattern to be the same constant */

loop:
        lastlit = litpool + nliterals;
        for(litp = litpool ; litp<lastlit ; ++litp)

            /* Remove this type checking to ensure that all bit patterns are reused */

            if(type == litp->littype) switch(litflavor)
                {
                case LIT_CHAR:
                    if (len == (int)litp->litval.litival2[0]
                            && nblanks == litp->litval.litival2[1]
                            && !memcmp(strp, litp->cds[0], len)) {
                        q->memno = litp->litnum;
                        frexpr((expptr)p);
                        q->user.Const.ccp1.ccp0 = litp->cds[0];
                        return(q);
                    }
                    break;
                case LIT_FLOAT:
                    if(cd[0] == litp->litval.litdval[0]
                            && !strcmp(ds[0], litp->cds[0])
                            && (k == 1 ||
                                cd[1] == litp->litval.litdval[1]
                                && !strcmp(ds[1], litp->cds[1]))) {
ret:
                        q->memno = litp->litnum;
                        frexpr((expptr)p);
                        return(q);
                    }
                    break;

                case LIT_INT:
                    if(p->Const.ci == litp->litval.litival)
                        goto ret;
                    break;
#ifndef NO_LONG_LONG
                case LIT_INTQ:
                    if(p->Const.cq == litp->litval.litqval)
                        goto ret;
                    break;
#endif
                }

        /* If there's room in the literal pool, add this new value to the pool */

        if(nliterals < maxliterals)
        {
            ++nliterals;

            /* litp   now points to the next free elt */

            litp->littype = type;
            litp->litnum = q->memno;
            switch(litflavor)
            {
            case LIT_CHAR:
                litp->litval.litival2[0] = len;
                litp->litval.litival2[1] = nblanks;
                q->user.Const.ccp = litp->cds[0] = (char*)
                                                   memcpy(gmem(len,0), strp, len);
                break;

            case LIT_FLOAT:
                litp->litval.litdval[0] = cd[0];
                litp->cds[0] = copys(ds[0]);
                if (k == 2) {
                    litp->litval.litdval[1] = cd[1];
                    litp->cds[1] = copys(ds[1]);
                }
                break;

            case LIT_INT:
                litp->litval.litival = p->Const.ci;
                break;
#ifndef NO_LONG_LONG
            case LIT_INTQ:
                litp->litval.litqval = p->Const.cq;
                break;
#endif
            } /* switch (litflavor) */
        }
        else
            many("literal constants", 'L', maxliterals);

        break;
    case TYADDR:
        break;
    default:
        badtype ("putconst", p -> vtype);
        break;
    } /* switch */

    if (type != TYCHAR || halign)
        frexpr((expptr)p);
    return( q );
}
示例#2
0
cbool parseWS(parse *p){
	return parseWhiteChar(p) && many(parseWhiteChar(p));
}