namelist(Namep np)
#endif
{
register chainp q;
register Namep v;
int y;
if (!np->visused)
return;
y = 0;
for(q = np->varxptr.namelist ; q ; q = q->nextp)
{
vardcl( v = (Namep) (q->datap) );
if( !ONEOF(v->vstg, MSKSTATIC) )
dclerr("may not appear in namelist", v);
else {
v->vnamelist = 1;
v->visused = 1;
v->vsave = 1;
y = 1;
}
np->visused = y;
}
}
/* called at end of declarations section to process chains
created by EQUIVALENCE statements
*/
void
doequiv(Void)
{
register int i;
int inequiv; /* True if one namep occurs in
several EQUIV declarations */
int comno; /* Index into Extsym table of the last
COMMON block seen (implicitly assuming
that only one will be given) */
int ovarno;
ftnint comoffset; /* Index into the COMMON block */
ftnint offset; /* Offset from array base */
ftnint leng;
register struct Equivblock *equivdecl;
register struct Eqvchain *q;
struct Primblock *primp;
register Namep np;
int k, k1, ns, pref, t;
chainp cp;
extern int type_pref[];
char *s;
for(i = 0 ; i < nequiv ; ++i)
{
/* Handle each equivalence declaration */
equivdecl = &eqvclass[i];
equivdecl->eqvbottom = equivdecl->eqvtop = 0;
comno = -1;
for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
{
offset = 0;
if (!(primp = q->eqvitem.eqvlhs))
continue;
vardcl(np = primp->namep);
if(primp->argsp || primp->fcharp)
{
expptr offp;
/* Pad ones onto the end of an array declaration when needed */
if(np->vdim!=NULL && np->vdim->ndim>1 &&
nsubs(primp->argsp)==1 )
{
if(! ftn66flag)
warni
("1-dim subscript in EQUIVALENCE, %d-dim declared",
np -> vdim -> ndim);
cp = NULL;
ns = np->vdim->ndim;
while(--ns > 0)
cp = mkchain((char *)ICON(1), cp);
primp->argsp->listp->nextp = cp;
}
offp = suboffset(primp);
if(ISICON(offp))
offset = offp->constblock.Const.ci;
else {
dclerr
("nonconstant subscript in equivalence ",
np);
np = NULL;
}
frexpr(offp);
}
/* Free up the primblock, since we now have a hash table (Namep) entry */
frexpr((expptr)primp);
if(np && (leng = iarrlen(np))<0)
{
dclerr("adjustable in equivalence", np);
np = NULL;
}
if(np) switch(np->vstg)
{
case STGUNKNOWN:
case STGBSS:
case STGEQUIV:
break;
case STGCOMMON:
/* The code assumes that all COMMON references in a given EQUIVALENCE will
be to the same COMMON block, and will all be consistent */
comno = np->vardesc.varno;
comoffset = np->voffset + offset;
break;
default:
dclerr("bad storage class in equivalence", np);
np = NULL;
break;
}
if(np)
{
q->eqvoffset = offset;
/* eqvbottom gets the largest difference between the array base address
and the address specified in the EQUIV declaration */
equivdecl->eqvbottom =
lmin(equivdecl->eqvbottom, -offset);
/* eqvtop gets the largest difference between the end of the array and
the address given in the EQUIVALENCE */
equivdecl->eqvtop =
lmax(equivdecl->eqvtop, leng-offset);
}
q->eqvitem.eqvname = np;
}
/* Now all equivalenced variables are in the hash table with the proper
offset, and eqvtop and eqvbottom are set. */
if(comno >= 0)
/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
*/
eqvcommon(equivdecl, comno, comoffset);
else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
{
if(np = q->eqvitem.eqvname)
{
inequiv = NO;
if(np->vstg==STGEQUIV)
if( (ovarno = np->vardesc.varno) == i)
{
/* Can't EQUIV different elements of the same array */
if(np->voffset + q->eqvoffset != 0)
dclerr
("inconsistent equivalence", np);
}
else {
offset = np->voffset;
inequiv = YES;
}
np->vstg = STGEQUIV;
np->vardesc.varno = i;
np->voffset = - q->eqvoffset;
if(inequiv)
/* Combine 2 equivalence declarations */
eqveqv(i, ovarno, q->eqvoffset + offset);
}
}
}
/* Now each equivalence declaration is distinct (all connections have been
merged in eqveqv()), and some may be empty. */
for(i = 0 ; i < nequiv ; ++i)
{
equivdecl = & eqvclass[i];
if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
/* a live chain */
k = TYCHAR;
pref = 1;
for(q = equivdecl->equivs ; q; q = q->eqvnextp)
if ((np = q->eqvitem.eqvname)
&& !np->veqvadjust) {
np->veqvadjust = 1;
np->voffset -= equivdecl->eqvbottom;
t = typealign[k1 = np->vtype];
if (pref < type_pref[k1]) {
k = k1;
pref = type_pref[k1];
}
if(np->voffset % t != 0) {
dclerr("bad alignment forced by equivalence", np);
--nerr; /* don't give bad return code for this */
}
}
equivdecl->eqvtype = k;
}
freqchain(equivdecl);
}
}
LOCAL void
docommon(Void)
{
register Extsym *extptr;
register chainp q, q1;
struct Dimblock *t;
expptr neltp;
register Namep comvar;
ftnint size;
int i, k, pref, type;
extern int type_pref[];
for(extptr = extsymtab ; extptr<nextext ; ++extptr)
if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
/* If a common declaration also had a list of variables ... */
q = extptr->extp = revchain(q);
pref = 1;
for(k = TYCHAR; q ; q = q->nextp)
{
comvar = (Namep) (q->datap);
if(comvar->vdcldone == NO)
vardcl(comvar);
type = comvar->vtype;
if (pref < type_pref[type])
pref = type_pref[k = type];
if(extptr->extleng % typealign[type] != 0) {
dclerr("common alignment", comvar);
--nerr; /* don't give bad return code for this */
#if 0
extptr->extleng = roundup(extptr->extleng, typealign[type]);
#endif
} /* if extptr -> extleng % */
/* Set the offset into the common block */
comvar->voffset = extptr->extleng;
comvar->vardesc.varno = extptr - extsymtab;
if(type == TYCHAR)
if (comvar->vleng)
size = comvar->vleng->constblock.Const.ci;
else {
dclerr("character*(*) in common", comvar);
size = 1;
}
else
size = typesize[type];
if(t = comvar->vdim)
if( (neltp = t->nelt) && ISCONST(neltp) )
size *= neltp->constblock.Const.ci;
else
dclerr("adjustable array in common", comvar);
/* Adjust the length of the common block so far */
extptr->extleng += size;
} /* for */
extptr->extype = k;
/* Determine curno and, if new, save this identifier chain */
q1 = extptr->extp;
for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
if (struct_eq((chainp)q->datap, q1))
break;
if (q)
extptr->curno = extptr->maxno - i;
else {
extptr->curno = ++extptr->maxno;
extptr->allextp = mkchain((char *)extptr->extp,
extptr->allextp);
}
} /* if extptr -> extstg == STGCOMMON */
/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
varno. And the common block itself has its full size in extleng. */
} /* docommon */
