1 /*- 2 * Copyright (c) 1980 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * %sccs.include.proprietary.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)equiv.c 5.3 (Berkeley) 04/12/91"; 10 #endif /* not lint */ 11 12 /* 13 * equiv.c 14 * 15 * Routines related to equivalence class processing, f77 compiler, 4.2 BSD. 16 * 17 * University of Utah CS Dept modification history: 18 * 19 * Revision 3.2 85/01/14 00:14:12 donn 20 * Fixed bug in eqvcommon that was causing the calculations of multilevel 21 * equivalences to be screwed up. 22 * 23 * Revision 3.1 84/10/13 01:16:08 donn 24 * Installed Jerry Berkman's version; added UofU comment header. 25 * 26 */ 27 28 29 #include "defs.h" 30 31 #ifdef SDB 32 # include <a.out.h> 33 # ifndef N_SO 34 # include <stab.h> 35 # endif 36 #endif 37 38 /* called at end of declarations section to process chains 39 created by EQUIVALENCE statements 40 */ 41 42 doequiv() 43 { 44 register int i; 45 int inequiv, comno, ovarno; 46 ftnint comoffset, offset, leng; 47 register struct Equivblock *p; 48 register struct Eqvchain *q; 49 struct Primblock *itemp; 50 register Namep np; 51 expptr offp, suboffset(); 52 int ns, nsubs(); 53 chainp cp; 54 char *memname(); 55 int doeqverr = 0; 56 57 for(i = 0 ; i < nequiv ; ++i) 58 { 59 p = &eqvclass[i]; 60 p->eqvbottom = p->eqvtop = 0; 61 comno = -1; 62 63 for(q = p->equivs ; q ; q = q->eqvnextp) 64 { 65 offset = 0; 66 itemp = q->eqvitem.eqvlhs; 67 if( itemp == NULL ) fatal("error processing equivalence"); 68 equivdcl = YES; 69 vardcl(np = itemp->namep); 70 equivdcl = NO; 71 if(itemp->argsp || itemp->fcharp) 72 { 73 if(np->vdim!=NULL && np->vdim->ndim>1 && 74 nsubs(itemp->argsp)==1 ) 75 { 76 if(! ftn66flag) 77 warn("1-dim subscript in EQUIVALENCE"); 78 cp = NULL; 79 ns = np->vdim->ndim; 80 while(--ns > 0) 81 cp = mkchain( ICON(1), cp); 82 itemp->argsp->listp->nextp = cp; 83 } 84 85 offp = suboffset(itemp); 86 if(ISICON(offp)) 87 offset = offp->constblock.constant.ci; 88 else { 89 dclerr("illegal subscript in equivalence ", 90 np); 91 np = NULL; 92 doeqverr = 1; 93 } 94 frexpr(offp); 95 } 96 frexpr(itemp); 97 98 if(np && (leng = iarrlen(np))<0) 99 { 100 dclerr("argument in equivalence", np); 101 np = NULL; 102 doeqverr =1; 103 } 104 105 if(np) switch(np->vstg) 106 { 107 case STGUNKNOWN: 108 case STGBSS: 109 case STGEQUIV: 110 break; 111 112 case STGCOMMON: 113 comno = np->vardesc.varno; 114 comoffset = np->voffset + offset; 115 break; 116 117 default: 118 dclerr("bad storage class in equivalence", np); 119 np = NULL; 120 doeqverr = 1; 121 break; 122 } 123 124 if(np) 125 { 126 q->eqvoffset = offset; 127 p->eqvbottom = lmin(p->eqvbottom, -offset); 128 p->eqvtop = lmax(p->eqvtop, leng-offset); 129 } 130 q->eqvitem.eqvname = np; 131 } 132 133 if(comno >= 0) 134 eqvcommon(p, comno, comoffset); 135 else for(q = p->equivs ; q ; q = q->eqvnextp) 136 { 137 if(np = q->eqvitem.eqvname) 138 { 139 inequiv = NO; 140 if(np->vstg==STGEQUIV) 141 if( (ovarno = np->vardesc.varno) == i) 142 { 143 if(np->voffset + q->eqvoffset != 0) 144 dclerr("inconsistent equivalence", np); 145 doeqverr = 1; 146 } 147 else { 148 offset = np->voffset; 149 inequiv = YES; 150 } 151 152 np->vstg = STGEQUIV; 153 np->vardesc.varno = i; 154 np->voffset = - q->eqvoffset; 155 156 if(inequiv) 157 eqveqv(i, ovarno, q->eqvoffset + offset); 158 } 159 } 160 } 161 162 if( !doeqverr ) 163 for(i = 0 ; i < nequiv ; ++i) 164 { 165 p = & eqvclass[i]; 166 if(p->eqvbottom!=0 || p->eqvtop!=0) /* a live chain */ 167 { 168 for(q = p->equivs ; q; q = q->eqvnextp) 169 { 170 np = q->eqvitem.eqvname; 171 np->voffset -= p->eqvbottom; 172 if(np->voffset % typealign[np->vtype] != 0) 173 dclerr("bad alignment forced by equivalence", np); 174 } 175 p->eqvtop -= p->eqvbottom; 176 p->eqvbottom = 0; 177 } 178 freqchain(p); 179 } 180 } 181 182 183 184 185 186 /* put equivalence chain p at common block comno + comoffset */ 187 188 LOCAL eqvcommon(p, comno, comoffset) 189 struct Equivblock *p; 190 int comno; 191 ftnint comoffset; 192 { 193 int ovarno; 194 ftnint k, offq; 195 register Namep np; 196 register struct Eqvchain *q; 197 198 if(comoffset + p->eqvbottom < 0) 199 { 200 errstr("attempt to extend common %s backward", 201 nounder(XL, extsymtab[comno].extname) ); 202 freqchain(p); 203 return; 204 } 205 206 if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) 207 extsymtab[comno].extleng = k; 208 209 #ifdef SDB 210 if(sdbflag) 211 prstab( varstr(XL,extsymtab[comno].extname), N_BCOMM,0,0); 212 #endif 213 214 for(q = p->equivs ; q ; q = q->eqvnextp) 215 if(np = q->eqvitem.eqvname) 216 { 217 switch(np->vstg) 218 { 219 case STGUNKNOWN: 220 case STGBSS: 221 np->vstg = STGCOMMON; 222 np->vardesc.varno = comno; 223 np->voffset = comoffset - q->eqvoffset; 224 #ifdef SDB 225 if(sdbflag) 226 { 227 namestab(np); 228 } 229 #endif 230 break; 231 232 case STGEQUIV: 233 ovarno = np->vardesc.varno; 234 offq = comoffset - q->eqvoffset - np->voffset; 235 np->vstg = STGCOMMON; 236 np->vardesc.varno = comno; 237 np->voffset = comoffset + q->eqvoffset; 238 if(ovarno != (p - eqvclass)) 239 eqvcommon(&eqvclass[ovarno], comno, offq); 240 #ifdef SDB 241 if(sdbflag) 242 { 243 namestab(np); 244 } 245 #endif 246 break; 247 248 case STGCOMMON: 249 if(comno != np->vardesc.varno || 250 comoffset != np->voffset+q->eqvoffset) 251 dclerr("inconsistent common usage", np); 252 break; 253 254 255 default: 256 badstg("eqvcommon", np->vstg); 257 } 258 } 259 260 #ifdef SDB 261 if(sdbflag) 262 prstab( varstr(XL,extsymtab[comno].extname), N_ECOMM,0,0); 263 #endif 264 265 freqchain(p); 266 p->eqvbottom = p->eqvtop = 0; 267 } 268 269 270 /* put all items on ovarno chain on front of nvarno chain 271 * adjust offsets of ovarno elements and top and bottom of nvarno chain 272 */ 273 274 LOCAL eqveqv(nvarno, ovarno, delta) 275 int ovarno, nvarno; 276 ftnint delta; 277 { 278 register struct Equivblock *p0, *p; 279 register Namep np; 280 struct Eqvchain *q, *q1; 281 282 p0 = eqvclass + nvarno; 283 p = eqvclass + ovarno; 284 p0->eqvbottom = lmin(p0->eqvbottom, p->eqvbottom - delta); 285 p0->eqvtop = lmax(p0->eqvtop, p->eqvtop - delta); 286 p->eqvbottom = p->eqvtop = 0; 287 288 for(q = p->equivs ; q ; q = q1) 289 { 290 q1 = q->eqvnextp; 291 if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) 292 { 293 q->eqvnextp = p0->equivs; 294 p0->equivs = q; 295 q->eqvoffset -= delta; 296 np->vardesc.varno = nvarno; 297 np->voffset -= delta; 298 } 299 else free( (charptr) q); 300 } 301 p->equivs = NULL; 302 } 303 304 305 306 307 LOCAL freqchain(p) 308 register struct Equivblock *p; 309 { 310 register struct Eqvchain *q, *oq; 311 312 for(q = p->equivs ; q ; q = oq) 313 { 314 oq = q->eqvnextp; 315 free( (charptr) q); 316 } 317 p->equivs = NULL; 318 } 319 320 321 322 323 324 LOCAL nsubs(p) 325 register struct Listblock *p; 326 { 327 register int n; 328 register chainp q; 329 330 n = 0; 331 if(p) 332 for(q = p->listp ; q ; q = q->nextp) 333 ++n; 334 335 return(n); 336 } 337