Return to equiv.c CVS log

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

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

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 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: #include "defs.h"
        !            25: 
        !            26: LOCAL eqvcommon(), eqveqv(), nsubs();
        !            27: 
        !            28: /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
        !            29: 
        !            30: /* called at end of declarations section to process chains
        !            31:    created by EQUIVALENCE statements
        !            32:  */
        !            33: doequiv()
        !            34: {
        !            35:        register int i;
        !            36:        int inequiv;                    /* True if one namep occurs in
        !            37:                                           several EQUIV declarations */
        !            38:        int comno;              /* Index into Extsym table of the last
        !            39:                                   COMMON block seen (implicitly assuming
        !            40:                                   that only one will be given) */
        !            41:        int ovarno;
        !            42:        ftnint comoffset;       /* Index into the COMMON block */
        !            43:        ftnint offset;          /* Offset from array base */
        !            44:        ftnint leng;
        !            45:        register struct Equivblock *equivdecl;
        !            46:        register struct Eqvchain *q;
        !            47:        struct Primblock *primp;
        !            48:        register Namep np;
        !            49:        int k, k1, ns, pref, t;
        !            50:        chainp cp;
        !            51:        extern int type_pref[];
        !            52:        char *s;
        !            53: 
        !            54:        for(i = 0 ; i < nequiv ; ++i)
        !            55:        {
        !            56: 
        !            57: /* Handle each equivalence declaration */
        !            58: 
        !            59:                equivdecl = &eqvclass[i];
        !            60:                equivdecl->eqvbottom = equivdecl->eqvtop = 0;
        !            61:                comno = -1;
        !            62: 
        !            63: 
        !            64: 
        !            65:                for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
        !            66:                {
        !            67:                        offset = 0;
        !            68:                        primp = q->eqvitem.eqvlhs;
        !            69:                        vardcl(np = primp->namep);
        !            70:                        if(primp->argsp || primp->fcharp)
        !            71:                        {
        !            72:                                expptr offp, suboffset();
        !            73: 
        !            74: /* Pad ones onto the end of an array declaration when needed */
        !            75: 
        !            76:                                if(np->vdim!=NULL && np->vdim->ndim>1 &&
        !            77:                                    nsubs(primp->argsp)==1 )
        !            78:                                {
        !            79:                                        if(! ftn66flag)
        !            80:                                                warni
        !            81:                        ("1-dim subscript in EQUIVALENCE, %d-dim declared",
        !            82:                                                    np -> vdim -> ndim);
        !            83:                                        cp = NULL;
        !            84:                                        ns = np->vdim->ndim;
        !            85:                                        while(--ns > 0)
        !            86:                                                cp = mkchain((char *)ICON(1), cp);
        !            87:                                        primp->argsp->listp->nextp = cp;
        !            88:                                }
        !            89: 
        !            90:                                offp = suboffset(primp);
        !            91:                                if(ISICON(offp))
        !            92:                                        offset = offp->constblock.Const.ci;
        !            93:                                else    {
        !            94:                                        dclerr
        !            95:                        ("nonconstant subscript in equivalence ",
        !            96:                                            np);
        !            97:                                        np = NULL;
        !            98:                                }
        !            99:                                frexpr(offp);
        !           100:                        }
        !           101: 
        !           102: /* Free up the primblock, since we now have a hash table (Namep) entry */
        !           103: 
        !           104:                        frexpr((expptr)primp);
        !           105: 
        !           106:                        if(np && (leng = iarrlen(np))<0)
        !           107:                        {
        !           108:                                dclerr("adjustable in equivalence", np);
        !           109:                                np = NULL;
        !           110:                        }
        !           111: 
        !           112:                        if(np) switch(np->vstg)
        !           113:                        {
        !           114:                        case STGUNKNOWN:
        !           115:                        case STGBSS:
        !           116:                        case STGEQUIV:
        !           117:                                if (in_vector(np->cvarname, st_fields,
        !           118:                                                n_st_fields) >= 0) {
        !           119:                                        k = strlen(np->cvarname);
        !           120:                                        strcpy(s = mem(k+2,0), np->cvarname);
        !           121:                                        s[k] = '_';
        !           122:                                        s[k+1] = 0;
        !           123:                                        np->cvarname = s;
        !           124:                                        }
        !           125:                                break;
        !           126: 
        !           127:                        case STGCOMMON:
        !           128: 
        !           129: /* The code assumes that all COMMON references in a given EQUIVALENCE will
        !           130:    be to the same COMMON block, and will all be consistent */
        !           131: 
        !           132:                                comno = np->vardesc.varno;
        !           133:                                comoffset = np->voffset + offset;
        !           134:                                break;
        !           135: 
        !           136:                        default:
        !           137:                                dclerr("bad storage class in equivalence", np);
        !           138:                                np = NULL;
        !           139:                                break;
        !           140:                        }
        !           141: 
        !           142:                        if(np)
        !           143:                        {
        !           144:                                q->eqvoffset = offset;
        !           145: 
        !           146: /* eqvbottom   gets the largest difference between the array base address
        !           147:    and the address specified in the EQUIV declaration */
        !           148: 
        !           149:                                equivdecl->eqvbottom =
        !           150:                                    lmin(equivdecl->eqvbottom, -offset);
        !           151: 
        !           152: /* eqvtop   gets the largest difference between the end of the array and
        !           153:    the address given in the EQUIVALENCE */
        !           154: 
        !           155:                                equivdecl->eqvtop =
        !           156:                                    lmax(equivdecl->eqvtop, leng-offset);
        !           157:                        }
        !           158:                        q->eqvitem.eqvname = np;
        !           159:                }
        !           160: 
        !           161: /* Now all equivalenced variables are in the hash table with the proper
        !           162:    offset, and   eqvtop and eqvbottom   are set. */
        !           163: 
        !           164:                if(comno >= 0)
        !           165: 
        !           166: /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
        !           167:    */
        !           168: 
        !           169:                        eqvcommon(equivdecl, comno, comoffset);
        !           170:                else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
        !           171:                {
        !           172:                        if(np = q->eqvitem.eqvname)
        !           173:                        {
        !           174:                                inequiv = NO;
        !           175:                                if(np->vstg==STGEQUIV)
        !           176:                                        if( (ovarno = np->vardesc.varno) == i)
        !           177:                                        {
        !           178: 
        !           179: /* Can't EQUIV different elements of the same array */
        !           180: 
        !           181:                                                if(np->voffset + q->eqvoffset != 0)
        !           182:                                                        dclerr
        !           183:                        ("inconsistent equivalence", np);
        !           184:                                        }
        !           185:                                        else    {
        !           186:                                                offset = np->voffset;
        !           187:                                                inequiv = YES;
        !           188:                                        }
        !           189: 
        !           190:                                np->vstg = STGEQUIV;
        !           191:                                np->vardesc.varno = i;
        !           192:                                np->voffset = - q->eqvoffset;
        !           193: 
        !           194:                                if(inequiv)
        !           195: 
        !           196: /* Combine 2 equivalence declarations */
        !           197: 
        !           198:                                        eqveqv(i, ovarno, q->eqvoffset + offset);
        !           199:                        }
        !           200:                }
        !           201:        }
        !           202: 
        !           203: /* Now each equivalence declaration is distinct (all connections have been
        !           204:    merged in eqveqv()), and some may be empty. */
        !           205: 
        !           206:        for(i = 0 ; i < nequiv ; ++i)
        !           207:        {
        !           208:                equivdecl = & eqvclass[i];
        !           209:                if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
        !           210: 
        !           211: /* a live chain */
        !           212: 
        !           213:                        k = TYCHAR;
        !           214:                        pref = 1;
        !           215:                        for(q = equivdecl->equivs ; q; q = q->eqvnextp)
        !           216:                            if (np = q->eqvitem.eqvname){
        !           217:                                np->voffset -= equivdecl->eqvbottom;
        !           218:                                t = typealign[k1 = np->vtype];
        !           219:                                if (pref < type_pref[k1]) {
        !           220:                                        k = k1;
        !           221:                                        pref = type_pref[k1];
        !           222:                                        }
        !           223:                                if(np->voffset % t != 0) {
        !           224:                                        dclerr("bad alignment forced by equivalence", np);
        !           225:                                        --nerr; /* don't give bad return code for this */
        !           226:                                        }
        !           227:                                }
        !           228:                        equivdecl->eqvtype = k;
        !           229:                }
        !           230:                freqchain(equivdecl);
        !           231:        }
        !           232: }
        !           233: 
        !           234: 
        !           235: 
        !           236: 
        !           237: 
        !           238: /* put equivalence chain p at common block comno + comoffset */
        !           239: 
        !           240: LOCAL eqvcommon(p, comno, comoffset)
        !           241: struct Equivblock *p;
        !           242: int comno;
        !           243: ftnint comoffset;
        !           244: {
        !           245:        int ovarno;
        !           246:        ftnint k, offq;
        !           247:        register Namep np;
        !           248:        register struct Eqvchain *q;
        !           249: 
        !           250:        if(comoffset + p->eqvbottom < 0)
        !           251:        {
        !           252:                errstr("attempt to extend common %s backward",
        !           253:                    extsymtab[comno].fextname);
        !           254:                freqchain(p);
        !           255:                return;
        !           256:        }
        !           257: 
        !           258:        if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
        !           259:                extsymtab[comno].extleng = k;
        !           260: 
        !           261: 
        !           262:        for(q = p->equivs ; q ; q = q->eqvnextp)
        !           263:                if(np = q->eqvitem.eqvname)
        !           264:                {
        !           265:                        switch(np->vstg)
        !           266:                        {
        !           267:                        case STGUNKNOWN:
        !           268:                        case STGBSS:
        !           269:                                np->vstg = STGCOMMON;
        !           270:                                np->vcommequiv = 1;
        !           271:                                np->vardesc.varno = comno;
        !           272: 
        !           273: /* np -> voffset   will point to the base of the array */
        !           274: 
        !           275:                                np->voffset = comoffset - q->eqvoffset;
        !           276:                                break;
        !           277: 
        !           278:                        case STGEQUIV:
        !           279:                                ovarno = np->vardesc.varno;
        !           280: 
        !           281: /* offq   will point to the current element, even if it's in an array */
        !           282: 
        !           283:                                offq = comoffset - q->eqvoffset - np->voffset;
        !           284:                                np->vstg = STGCOMMON;
        !           285:                                np->vcommequiv = 1;
        !           286:                                np->vardesc.varno = comno;
        !           287: 
        !           288: /* np -> voffset   will point to the base of the array */
        !           289: 
        !           290:                                np->voffset += offq;
        !           291:                                if(ovarno != (p - eqvclass))
        !           292:                                        eqvcommon(&eqvclass[ovarno], comno, offq);
        !           293:                                break;
        !           294: 
        !           295:                        case STGCOMMON:
        !           296:                                if(comno != np->vardesc.varno ||
        !           297:                                    comoffset != np->voffset+q->eqvoffset)
        !           298:                                        dclerr("inconsistent common usage", np);
        !           299:                                break;
        !           300: 
        !           301: 
        !           302:                        default:
        !           303:                                badstg("eqvcommon", np->vstg);
        !           304:                        }
        !           305:                }
        !           306: 
        !           307:        freqchain(p);
        !           308:        p->eqvbottom = p->eqvtop = 0;
        !           309: }
        !           310: 
        !           311: 
        !           312: /* Move all items on ovarno chain to the front of   nvarno   chain.
        !           313:  * adjust offsets of ovarno elements and top and bottom of nvarno chain
        !           314:  */
        !           315: 
        !           316: LOCAL eqveqv(nvarno, ovarno, delta)
        !           317: int ovarno, nvarno;
        !           318: ftnint delta;
        !           319: {
        !           320:        register struct Equivblock *neweqv, *oldeqv;
        !           321:        register Namep np;
        !           322:        struct Eqvchain *q, *q1;
        !           323: 
        !           324:        neweqv = eqvclass + nvarno;
        !           325:        oldeqv = eqvclass + ovarno;
        !           326:        neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
        !           327:        neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
        !           328:        oldeqv->eqvbottom = oldeqv->eqvtop = 0;
        !           329: 
        !           330:        for(q = oldeqv->equivs ; q ; q = q1)
        !           331:        {
        !           332:                q1 = q->eqvnextp;
        !           333:                if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
        !           334:                {
        !           335:                        q->eqvnextp = neweqv->equivs;
        !           336:                        neweqv->equivs = q;
        !           337:                        q->eqvoffset += delta;
        !           338:                        np->vardesc.varno = nvarno;
        !           339:                        np->voffset -= delta;
        !           340:                }
        !           341:                else    free( (charptr) q);
        !           342:        }
        !           343:        oldeqv->equivs = NULL;
        !           344: }
        !           345: 
        !           346: 
        !           347: 
        !           348: 
        !           349: freqchain(p)
        !           350: register struct Equivblock *p;
        !           351: {
        !           352:        register struct Eqvchain *q, *oq;
        !           353: 
        !           354:        for(q = p->equivs ; q ; q = oq)
        !           355:        {
        !           356:                oq = q->eqvnextp;
        !           357:                free( (charptr) q);
        !           358:        }
        !           359:        p->equivs = NULL;
        !           360: }
        !           361: 
        !           362: 
        !           363: 
        !           364: 
        !           365: 
        !           366: /* nsubs -- number of subscripts in this arglist (just the length of the
        !           367:    list) */
        !           368: 
        !           369: LOCAL nsubs(p)
        !           370: register struct Listblock *p;
        !           371: {
        !           372:        register int n;
        !           373:        register chainp q;
        !           374: 
        !           375:        n = 0;
        !           376:        if(p)
        !           377:                for(q = p->listp ; q ; q = q->nextp)
        !           378:                        ++n;
        !           379: 
        !           380:        return(n);
        !           381: }

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