00001 /****************************************************************
00002 Copyright 1990, 1993-6 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 
00026 static void eqvcommon Argdcl((struct Equivblock*, int, long int));
00027 static void eqveqv Argdcl((int, int, long int));
00028 static int nsubs Argdcl((struct Listblock*));
00029 
00030 /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
00031 
00032 /* called at end of declarations section to process chains
00033    created by EQUIVALENCE statements
00034  */
00035  void
00036 doequiv(Void)
00037 {
00038         register int i;
00039         int inequiv;                    /* True if one namep occurs in
00040                                            several EQUIV declarations */
00041         int comno;              /* Index into Extsym table of the last
00042                                    COMMON block seen (implicitly assuming
00043                                    that only one will be given) */
00044         int ovarno;
00045         ftnint comoffset;       /* Index into the COMMON block */
00046         ftnint offset;          /* Offset from array base */
00047         ftnint leng;
00048         register struct Equivblock *equivdecl;
00049         register struct Eqvchain *q;
00050         struct Primblock *primp;
00051         register Namep np;
00052         int k, k1, ns, pref, t;
00053         chainp cp;
00054         extern int type_pref[];
00055         char *s;
00056 
00057         for(i = 0 ; i < nequiv ; ++i)
00058         {
00059 
00060 /* Handle each equivalence declaration */
00061 
00062                 equivdecl = &eqvclass[i];
00063                 equivdecl->eqvbottom = equivdecl->eqvtop = 0;
00064                 comno = -1;
00065 
00066 
00067 
00068                 for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
00069                 {
00070                         offset = 0;
00071                         if (!(primp = q->eqvitem.eqvlhs))
00072                                 continue;
00073                         vardcl(np = primp->namep);
00074                         if(primp->argsp || primp->fcharp)
00075                         {
00076                                 expptr offp;
00077 
00078 /* Pad ones onto the end of an array declaration when needed */
00079 
00080                                 if(np->vdim!=NULL && np->vdim->ndim>1 &&
00081                                     nsubs(primp->argsp)==1 )
00082                                 {
00083                                         if(! ftn66flag)
00084                                                 warni
00085                         ("1-dim subscript in EQUIVALENCE, %d-dim declared",
00086                                                     np -> vdim -> ndim);
00087                                         cp = NULL;
00088                                         ns = np->vdim->ndim;
00089                                         while(--ns > 0)
00090                                                 cp = mkchain((char *)ICON(1), cp);
00091                                         primp->argsp->listp->nextp = cp;
00092                                 }
00093 
00094                                 offp = suboffset(primp);
00095                                 if(ISICON(offp))
00096                                         offset = offp->constblock.Const.ci;
00097                                 else    {
00098                                         dclerr
00099                         ("nonconstant subscript in equivalence ",
00100                                             np);
00101                                         np = NULL;
00102                                 }
00103                                 frexpr(offp);
00104                         }
00105 
00106 /* Free up the primblock, since we now have a hash table (Namep) entry */
00107 
00108                         frexpr((expptr)primp);
00109 
00110                         if(np && (leng = iarrlen(np))<0)
00111                         {
00112                                 dclerr("adjustable in equivalence", np);
00113                                 np = NULL;
00114                         }
00115 
00116                         if(np) switch(np->vstg)
00117                         {
00118                         case STGUNKNOWN:
00119                         case STGBSS:
00120                         case STGEQUIV:
00121                                 break;
00122 
00123                         case STGCOMMON:
00124 
00125 /* The code assumes that all COMMON references in a given EQUIVALENCE will
00126    be to the same COMMON block, and will all be consistent */
00127 
00128                                 comno = np->vardesc.varno;
00129                                 comoffset = np->voffset + offset;
00130                                 break;
00131 
00132                         default:
00133                                 dclerr("bad storage class in equivalence", np);
00134                                 np = NULL;
00135                                 break;
00136                         }
00137 
00138                         if(np)
00139                         {
00140                                 q->eqvoffset = offset;
00141 
00142 /* eqvbottom   gets the largest difference between the array base address
00143    and the address specified in the EQUIV declaration */
00144 
00145                                 equivdecl->eqvbottom =
00146                                     lmin(equivdecl->eqvbottom, -offset);
00147 
00148 /* eqvtop   gets the largest difference between the end of the array and
00149    the address given in the EQUIVALENCE */
00150 
00151                                 equivdecl->eqvtop =
00152                                     lmax(equivdecl->eqvtop, leng-offset);
00153                         }
00154                         q->eqvitem.eqvname = np;
00155                 }
00156 
00157 /* Now all equivalenced variables are in the hash table with the proper
00158    offset, and   eqvtop and eqvbottom   are set. */
00159 
00160                 if(comno >= 0)
00161 
00162 /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
00163    */
00164 
00165                         eqvcommon(equivdecl, comno, comoffset);
00166                 else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
00167                 {
00168                         if(np = q->eqvitem.eqvname)
00169                         {
00170                                 inequiv = NO;
00171                                 if(np->vstg==STGEQUIV)
00172                                         if( (ovarno = np->vardesc.varno) == i)
00173                                         {
00174 
00175 /* Can't EQUIV different elements of the same array */
00176 
00177                                                 if(np->voffset + q->eqvoffset != 0)
00178                                                         dclerr
00179                         ("inconsistent equivalence", np);
00180                                         }
00181                                         else    {
00182                                                 offset = np->voffset;
00183                                                 inequiv = YES;
00184                                         }
00185 
00186                                 np->vstg = STGEQUIV;
00187                                 np->vardesc.varno = i;
00188                                 np->voffset = - q->eqvoffset;
00189 
00190                                 if(inequiv)
00191 
00192 /* Combine 2 equivalence declarations */
00193 
00194                                         eqveqv(i, ovarno, q->eqvoffset + offset);
00195                         }
00196                 }
00197         }
00198 
00199 /* Now each equivalence declaration is distinct (all connections have been
00200    merged in eqveqv()), and some may be empty. */
00201 
00202         for(i = 0 ; i < nequiv ; ++i)
00203         {
00204                 equivdecl = & eqvclass[i];
00205                 if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
00206 
00207 /* a live chain */
00208 
00209                         k = TYCHAR;
00210                         pref = 1;
00211                         for(q = equivdecl->equivs ; q; q = q->eqvnextp)
00212                             if ((np = q->eqvitem.eqvname)
00213                                         && !np->veqvadjust) {
00214                                 np->veqvadjust = 1;
00215                                 np->voffset -= equivdecl->eqvbottom;
00216                                 t = typealign[k1 = np->vtype];
00217                                 if (pref < type_pref[k1]) {
00218                                         k = k1;
00219                                         pref = type_pref[k1];
00220                                         }
00221                                 if(np->voffset % t != 0) {
00222                                         dclerr("bad alignment forced by equivalence", np);
00223                                         --nerr; /* don't give bad return code for this */
00224                                         }
00225                                 }
00226                         equivdecl->eqvtype = k;
00227                 }
00228                 freqchain(equivdecl);
00229         }
00230 }
00231 
00232 
00233 
00234 
00235 
00236 /* put equivalence chain p at common block comno + comoffset */
00237 
00238  LOCAL void
00239 #ifdef KR_headers
00240 eqvcommon(p, comno, comoffset)
00241         struct Equivblock *p;
00242         int comno;
00243         ftnint comoffset;
00244 #else
00245 eqvcommon(struct Equivblock *p, int comno, ftnint comoffset)
00246 #endif
00247 {
00248         int ovarno;
00249         ftnint k, offq;
00250         register Namep np;
00251         register struct Eqvchain *q;
00252 
00253         if(comoffset + p->eqvbottom < 0)
00254         {
00255                 errstr("attempt to extend common %s backward",
00256                     extsymtab[comno].fextname);
00257                 freqchain(p);
00258                 return;
00259         }
00260 
00261         if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
00262                 extsymtab[comno].extleng = k;
00263 
00264 
00265         for(q = p->equivs ; q ; q = q->eqvnextp)
00266                 if(np = q->eqvitem.eqvname)
00267                 {
00268                         switch(np->vstg)
00269                         {
00270                         case STGUNKNOWN:
00271                         case STGBSS:
00272                                 np->vstg = STGCOMMON;
00273                                 np->vcommequiv = 1;
00274                                 np->vardesc.varno = comno;
00275 
00276 /* np -> voffset   will point to the base of the array */
00277 
00278                                 np->voffset = comoffset - q->eqvoffset;
00279                                 break;
00280 
00281                         case STGEQUIV:
00282                                 ovarno = np->vardesc.varno;
00283 
00284 /* offq   will point to the current element, even if it's in an array */
00285 
00286                                 offq = comoffset - q->eqvoffset - np->voffset;
00287                                 np->vstg = STGCOMMON;
00288                                 np->vcommequiv = 1;
00289                                 np->vardesc.varno = comno;
00290 
00291 /* np -> voffset   will point to the base of the array */
00292 
00293                                 np->voffset += offq;
00294                                 if(ovarno != (p - eqvclass))
00295                                         eqvcommon(&eqvclass[ovarno], comno, offq);
00296                                 break;
00297 
00298                         case STGCOMMON:
00299                                 if(comno != np->vardesc.varno ||
00300                                     comoffset != np->voffset+q->eqvoffset)
00301                                         dclerr("inconsistent common usage", np);
00302                                 break;
00303 
00304 
00305                         default:
00306                                 badstg("eqvcommon", np->vstg);
00307                         }
00308                 }
00309 
00310         freqchain(p);
00311         p->eqvbottom = p->eqvtop = 0;
00312 }
00313 
00314 
00315 /* Move all items on ovarno chain to the front of   nvarno   chain.
00316  * adjust offsets of ovarno elements and top and bottom of nvarno chain
00317  */
00318 
00319  LOCAL void
00320 #ifdef KR_headers
00321 eqveqv(nvarno, ovarno, delta)
00322         int nvarno;
00323         int ovarno;
00324         ftnint delta;
00325 #else
00326 eqveqv(int nvarno, int ovarno, ftnint delta)
00327 #endif
00328 {
00329         register struct Equivblock *neweqv, *oldeqv;
00330         register Namep np;
00331         struct Eqvchain *q, *q1;
00332 
00333         neweqv = eqvclass + nvarno;
00334         oldeqv = eqvclass + ovarno;
00335         neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
00336         neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
00337         oldeqv->eqvbottom = oldeqv->eqvtop = 0;
00338 
00339         for(q = oldeqv->equivs ; q ; q = q1)
00340         {
00341                 q1 = q->eqvnextp;
00342                 if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
00343                 {
00344                         q->eqvnextp = neweqv->equivs;
00345                         neweqv->equivs = q;
00346                         q->eqvoffset += delta;
00347                         np->vardesc.varno = nvarno;
00348                         np->voffset -= delta;
00349                 }
00350                 else    free( (charptr) q);
00351         }
00352         oldeqv->equivs = NULL;
00353 }
00354 
00355 
00356 
00357  void
00358 #ifdef KR_headers
00359 freqchain(p)
00360         register struct Equivblock *p;
00361 #else
00362 freqchain(register struct Equivblock *p)
00363 #endif
00364 {
00365         register struct Eqvchain *q, *oq;
00366 
00367         for(q = p->equivs ; q ; q = oq)
00368         {
00369                 oq = q->eqvnextp;
00370                 free( (charptr) q);
00371         }
00372         p->equivs = NULL;
00373 }
00374 
00375 
00376 
00377 
00378 
00379 /* nsubs -- number of subscripts in this arglist (just the length of the
00380    list) */
00381 
00382  LOCAL int
00383 #ifdef KR_headers
00384 nsubs(p)
00385         register struct Listblock *p;
00386 #else
00387 nsubs(register struct Listblock *p)
00388 #endif
00389 {
00390         register int n;
00391         register chainp q;
00392 
00393         n = 0;
00394         if(p)
00395                 for(q = p->listp ; q ; q = q->nextp)
00396                         ++n;
00397 
00398         return(n);
00399 }
00400 
00401  struct Primblock *
00402 #ifdef KR_headers
00403 primchk(e) expptr e;
00404 #else
00405 primchk(expptr e)
00406 #endif
00407 {
00408         if (e->headblock.tag != TPRIM) {
00409                 err("Invalid name in EQUIVALENCE.");
00410                 return 0;
00411                 }
00412         return &e->primblock;
00413         }