/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
/* called at end of declarations section to process chains
created by EQUIVALENCE statements
int inequiv
, comno
, ovarno
;
ftnint comoffset
, offset
, leng
;
register struct Equivblock
*p
;
register struct Eqvchain
*q
;
expptr offp
, suboffset();
for(i
= 0 ; i
< nequiv
; ++i
)
p
->eqvbottom
= p
->eqvtop
= 0;
for(q
= p
->equivs
; q
; q
= q
->eqvnextp
)
itemp
= q
->eqvitem
.eqvlhs
;
vardcl(np
= itemp
->namep
);
if(itemp
->argsp
|| itemp
->fcharp
)
if(np
->vdim
!=NULL
&& np
->vdim
->ndim
>1 &&
warn("1-dim subscript in EQUIVALENCE");
cp
= mkchain( ICON(1), cp
);
itemp
->argsp
->listp
->nextp
= cp
;
offset
= offp
->constblock
.const.ci
;
dclerr("nonconstant subscript in equivalence ",
if(np
&& (leng
= iarrlen(np
))<0)
dclerr("adjustable in equivalence", np
);
comno
= np
->vardesc
.varno
;
comoffset
= np
->voffset
+ offset
;
dclerr("bad storage class in equivalence", np
);
p
->eqvbottom
= lmin(p
->eqvbottom
, -offset
);
p
->eqvtop
= lmax(p
->eqvtop
, leng
-offset
);
eqvcommon(p
, comno
, comoffset
);
else for(q
= p
->equivs
; q
; q
= q
->eqvnextp
)
if(np
= q
->eqvitem
.eqvname
)
if( (ovarno
= np
->vardesc
.varno
) == i
)
if(np
->voffset
+ q
->eqvoffset
!= 0)
dclerr("inconsistent equivalence", np
);
np
->voffset
= - q
->eqvoffset
;
eqveqv(i
, ovarno
, q
->eqvoffset
+ offset
);
for(i
= 0 ; i
< nequiv
; ++i
)
if(p
->eqvbottom
!=0 || p
->eqvtop
!=0) /* a live chain */
prstab(CNULL
, N_BCOMM
, 0, 0);
for(q
= p
->equivs
; q
; q
= q
->eqvnextp
)
np
->voffset
-= p
->eqvbottom
;
if(np
->voffset
% typealign
[np
->vtype
] != 0)
dclerr("bad alignment forced by equivalence", np
);
prstleng(np
, iarrlen(np
));
p
->eqvtop
-= p
->eqvbottom
;
prstab(CNULL
, N_ECOML
, 0, memname(STGEQUIV
,i
) );
/* put equivalence chain p at common block comno + comoffset */
LOCAL
eqvcommon(p
, comno
, comoffset
)
register struct Eqvchain
*q
;
if(comoffset
+ p
->eqvbottom
< 0)
errstr("attempt to extend common %s backward",
nounder(XL
, extsymtab
[comno
].extname
) );
if( (k
= comoffset
+ p
->eqvtop
) > extsymtab
[comno
].extleng
)
extsymtab
[comno
].extleng
= k
;
prstab( varstr(XL
,extsymtab
[comno
].extname
), N_BCOMM
,0,0);
for(q
= p
->equivs
; q
; q
= q
->eqvnextp
)
if(np
= q
->eqvitem
.eqvname
)
np
->vardesc
.varno
= comno
;
np
->voffset
= comoffset
- q
->eqvoffset
;
prstleng(np
, iarrlen(np
));
ovarno
= np
->vardesc
.varno
;
offq
= comoffset
- q
->eqvoffset
- np
->voffset
;
np
->vardesc
.varno
= comno
;
np
->voffset
= comoffset
- q
->eqvoffset
;
if(ovarno
!= (p
- eqvclass
))
eqvcommon(&eqvclass
[ovarno
], comno
, offq
);
if(comno
!= np
->vardesc
.varno
||
comoffset
!= np
->voffset
+q
->eqvoffset
)
dclerr("inconsistent common usage", np
);
badstg("eqvcommon", np
->vstg
);
prstab( varstr(XL
,extsymtab
[comno
].extname
), N_ECOMM
,0,0);
p
->eqvbottom
= p
->eqvtop
= 0;
/* put all items on ovarno chain on front of nvarno chain
* adjust offsets of ovarno elements and top and bottom of nvarno chain
LOCAL
eqveqv(nvarno
, ovarno
, delta
)
register struct Equivblock
*p0
, *p
;
p0
->eqvbottom
= lmin(p0
->eqvbottom
, p
->eqvbottom
- delta
);
p0
->eqvtop
= lmax(p0
->eqvtop
, p
->eqvtop
- delta
);
p
->eqvbottom
= p
->eqvtop
= 0;
for(q
= p
->equivs
; q
; q
= q1
)
if( (np
= q
->eqvitem
.eqvname
) && np
->vardesc
.varno
==ovarno
)
q
->eqvnextp
= p0
->equivs
;
np
->vardesc
.varno
= nvarno
;
register struct Equivblock
*p
;
register struct Eqvchain
*q
, *oq
;
for(q
= p
->equivs
; q
; q
= oq
)
register struct Listblock
*p
;
for(q
= p
->listp
; q
; q
= q
->nextp
)