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