Doxygen Source Code Documentation
Main Page Alphabetical List Data Structures File List Data Fields Globals Search
equiv.c
Go to the documentation of this file.00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
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
00031
00032
00033
00034
00035 void
00036 doequiv(Void)
00037 {
00038 register int i;
00039 int inequiv;
00040
00041 int comno;
00042
00043
00044 int ovarno;
00045 ftnint comoffset;
00046 ftnint offset;
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
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
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
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
00126
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
00143
00144
00145 equivdecl->eqvbottom =
00146 lmin(equivdecl->eqvbottom, -offset);
00147
00148
00149
00150
00151 equivdecl->eqvtop =
00152 lmax(equivdecl->eqvtop, leng-offset);
00153 }
00154 q->eqvitem.eqvname = np;
00155 }
00156
00157
00158
00159
00160 if(comno >= 0)
00161
00162
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
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
00193
00194 eqveqv(i, ovarno, q->eqvoffset + offset);
00195 }
00196 }
00197 }
00198
00199
00200
00201
00202 for(i = 0 ; i < nequiv ; ++i)
00203 {
00204 equivdecl = & eqvclass[i];
00205 if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
00206
00207
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;
00224 }
00225 }
00226 equivdecl->eqvtype = k;
00227 }
00228 freqchain(equivdecl);
00229 }
00230 }
00231
00232
00233
00234
00235
00236
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
00277
00278 np->voffset = comoffset - q->eqvoffset;
00279 break;
00280
00281 case STGEQUIV:
00282 ovarno = np->vardesc.varno;
00283
00284
00285
00286 offq = comoffset - q->eqvoffset - np->voffset;
00287 np->vstg = STGCOMMON;
00288 np->vcommequiv = 1;
00289 np->vardesc.varno = comno;
00290
00291
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
00316
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
00380
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 }