add_extern_to_list(Addrp addr, chainp *list_store)
#endif
{
chainp last = CHNULL;
chainp list;
int memno;
if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
return;
list = *list_store;
memno = addr -> memno;
for (;list; last = list, list = list -> nextp) {
Addrp This = (Addrp) (list -> datap);
if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN &&
This -> memno == memno)
return;
} /* for */
if (*list_store == CHNULL)
*list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
else
last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
} /* add_extern_to_list */
pad_common(Extsym *c)
#endif
{
register chainp cvl;
register Namep v;
long L = c->maxleng;
int type;
struct Dimblock *t;
int szshort = typesize[TYSHORT];
for(cvl = c->allextp; cvl; cvl = cvl->nextp)
if (commlen((chainp)cvl->datap) >= L)
return;
v = ALLOC(Nameblock);
v->vtype = type = L % szshort ? TYCHAR
: type_choice[L/szshort % 4];
v->vstg = STGCOMMON;
v->vclass = CLVAR;
v->tag = TNAME;
v->vdim = t = ALLOC(Dimblock);
t->ndim = 1;
t->dims[0].dimsize = ICON(L / typesize[type]);
v->fvarname = v->cvarname = "eqv_pad";
if (type == TYCHAR)
v->vleng = ICON(1);
c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
}
call2(int type, char *name, expptr arg1, expptr arg2)
#endif
{
struct Listblock *args;
args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
return( callk(type,name, (chainp)args) );
}
declare_new_addr(struct Addrblock *addrp)
#endif
{
extern chainp new_vars;
new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
} /* declare_new_addr */
p1_label(long lab)
#endif
{
if (parstate < INDATA)
earlylabs = mkchain((char *)lab, earlylabs);
else
p1putd (P1_LABEL, lab);
}
incomm(Extsym *c, Namep v)
#endif
{
if (!c)
return;
if(v->vstg != STGUNKNOWN && !v->vimplstg)
dclerr(v->vstg == STGARG
? "dummy arguments cannot be in common"
: "incompatible common declaration", v);
else
{
v->vstg = STGCOMMON;
c->extp = mkchain((char *)v, c->extp);
}
}
/* 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);
}
}
call1(int type, char *name, expptr arg)
#endif
{
return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
}
dclgen()
{
register ptr p, q;
ptr q1;
chainp *y, z;
register struct stentry *s;
struct stentry **hp;
int first;
int i, j;
extern char *types[];
char *sp;
/* print procedure statement and argument list */
for(p = prevcomments ; p ; p = p->nextp)
{
sp = p->datap;
fprintf(codefile, "%s\n", sp+1);
cfree(sp);
}
frchain(&prevcomments);
if(tailor.procheader)
fprintf(codefile, "%s\n", tailor.procheader);
if(procname)
{
p2str(" ");
if(procname->vtype==TYSUBR || procname->vtype==TYUNDEFINED)
p2key(FSUBROUTINE);
else {
p2str(types[procname->vtype]);
p2key(FFUNCTION);
}
p2str(procname->sthead->namep);
}
else if(procclass == PRBLOCK)
{
p2stmt(0);
p2key(FBLOCKDATA);
}
else {
p2str("c main program");
if(tailor.ftnsys == CRAY)
{
p2stmt(0);
p2key(FPROGRAM);
}
}
if(thisargs)
{
p2str( "(" );
first = 1;
for(p = thisargs ; p ; p = p->nextp)
if( (q=p->datap)->vextbase)
{
if(first) first = 0;
else p2str(", ");
p2str(ftnames[q->vextbase]);
}
else for(i=0 ; i<NFTNTYPES ; ++i)
if(j = q->vbase[i])
{
if(first) first = 0;
else p2str( ", " );
p2str(ftnames[j]);
}
p2str( ")" );
}
/* first put out declarations of variables that are used as
adjustable dimensions
*/
y = 0;
z = & y;
for(hp = hashtab ; hp<hashend; ++hp)
if( *hp && (q = (*hp)->varp) )
if(q->tag==TNAME && q->vadjdim && q!=procname)
z = z->nextp = mkchain(q,CHNULL);
dclchain(y, NOCOMMON);
frchain(&y);
/* then declare the rest of the arguments */
z = & y;
for(p = thisargs ; p ; p = p->nextp)
if(p->datap->vadjdim == 0)
z = z->nextp = mkchain(p->datap,CHNULL);
dclchain(y, NOCOMMON);
frchain(&y);
frchain(&thisargs);
/* now put out declarations for common blocks */
for(p = commonlist ; p ; p = p->nextp)
prcomm(p->datap);
TEST fprintf(diagfile, "\nend of common declarations");
z = &y;
/* next the other variables that are in the symbol table */
for(hp = hashtab ; hp<hashend ; ++hp)
if( *hp && (q = (*hp)->varp) )
if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
q->vclass!=CLARG && q!=procname &&
(tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
z = z->nextp = mkchain(q,CHNULL);
dclchain(y, NOCOMMON);
frchain(&y);
TEST fprintf(diagfile, "\nend of symbol table, start of gonelist");
/* now declare variables that are no longer in the symbol table */
dclchain(gonelist, NOCOMMON);
TEST fprintf(diagfile, "\nbeginning of hidlist");
dclchain(hidlist, NOCOMMON);
dclchain(tempvarlist, NOCOMMON);
/* finally put out equivalence statements that are generated
because of structure and character variables
*/
for(p = genequivs; p ; p = p->nextp)
{
q = p->datap;
p2stmt(0);
first = 1;
p2key(FEQUIVALENCE);
p2str( "(" );
for(i=0; i<NFTNTYPES; ++i)
if(q->vbase[i])
{
if(first) first = 0;
else p2str( ", " );
p2str(ftnames[ q->vbase[i] ]);
p2str( "(1" );
if(q1 = q->vdim)
for(q1 = q1->datap; q1 ; q1 = q1->nextp)
p2str( ",1" );
p2str( ")" );
}
p2str( ")" );
}
frchain(&genequivs);
}
argsort(chainp p0)
#endif
{
Namep *args, q, *stack;
int i, nargs, nout, nst;
chainp *d, *da, p, rv, *rvp;
struct Dimblock *dp;
if (!p0)
return p0;
for(nargs = 0, p = p0; p; p = p->nextp)
nargs++;
args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
+ 2*sizeof(int)));
memset((char *)args, 0, i);
stack = args + nargs;
d = (chainp *)(stack + nargs);
refs = (int *)(d + nargs);
used = refs + nargs;
for(p = p0; p; p = p->nextp) {
q = (Namep) p->datap;
args[q->argno] = q;
}
for(p = p0; p; p = p->nextp) {
q = (Namep) p->datap;
if (!(dp = q->vdim))
continue;
i = dp->ndim;
while(--i >= 0)
awalk(dp->dims[i].dimexpr);
awalk(dp->basexpr);
while(nu > 0) {
refs[i = used[--nu]] = 0;
d[i] = mkchain((char *)q, d[i]);
}
}
for(i = nst = 0; i < nargs; i++)
for(p = d[i]; p; p = p->nextp)
refs[((Namep)p->datap)->argno]++;
while(--i >= 0)
if (!refs[i])
stack[nst++] = args[i];
if (nst == nargs) {
rv = p0;
goto done;
}
nout = 0;
rv = 0;
rvp = &rv;
while(nst > 0) {
nout++;
q = stack[--nst];
*rvp = p = mkchain((char *)q, CHNULL);
rvp = &p->nextp;
da = d + q->argno;
for(p = *da; p; p = p->nextp)
if (!--refs[(q = (Namep)p->datap)->argno])
stack[nst++] = q;
frchain(da);
}
if (nout < nargs)
for(i = 0; i < nargs; i++)
if (refs[i]) {
q = args[i];
errstr("Can't adjust %.38s correctly\n\
due to dependencies among arguments.",
q->fvarname);
*rvp = p = mkchain((char *)q, CHNULL);
rvp = &p->nextp;
frchain(d+i);
}
done:
free((char *)args);
return rv;
}
doentry(struct Entrypoint *ep)
#endif
{
register int type;
register Namep np;
chainp p, p1;
register Namep q;
Addrp rs;
int it, k;
extern char dflttype[26];
Extsym *entryname = ep->entryname;
if (++nentry > 1)
p1_label((long)(extsymtab - entryname - 1));
/* The main program isn't allowed to have parameters, so any given
parameters are ignored */
if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK)
return;
/* Entry points in MAIN are an error, but we process them here */
/* to prevent faults elsewhere. */
/* So now we're working with something other than CLMAIN or CLBLOCK.
Determine the type of its return value. */
impldcl( np = mkname(entryname->fextname) );
type = np->vtype;
proc_argchanges = prev_proc && type != entryname->extype;
entryname->extseen = 1;
if(proctype == TYUNKNOWN)
if( (proctype = type) == TYCHAR)
procleng = np->vleng ? np->vleng->constblock.Const.ci
: (ftnint) (-1);
if(proctype == TYCHAR)
{
if(type != TYCHAR)
err("noncharacter entry of character function");
/* Functions returning type char can only have multiple entries if all
entries return the same length */
else if( (np->vleng ? np->vleng->constblock.Const.ci :
(ftnint) (-1)) != procleng)
err("mismatched character entry lengths");
}
else if(type == TYCHAR)
err("character entry of noncharacter function");
else if(type != proctype)
multitype = YES;
if(rtvlabel[type] == 0)
rtvlabel[type] = (int)newlabel();
ep->typelabel = rtvlabel[type];
if(type == TYCHAR)
{
if(chslot < 0)
{
chslot = nextarg(TYADDR);
chlgslot = nextarg(TYLENG);
}
np->vstg = STGARG;
/* Put a new argument in the function, one which will hold the result of
a character function. This will have to be named sometime, probably in
mkarg(). */
if(procleng < 0) {
np->vleng = (expptr) mkarg(TYLENG, chlgslot);
np->vleng->addrblock.uname_tag = UNAM_IDENT;
strcpy (np -> vleng -> addrblock.user.ident,
new_func_length());
}
if (!xretslot[TYCHAR]) {
xretslot[TYCHAR] = rs =
autovar(0, type, ISCONST(np->vleng)
? np->vleng : ICON(0), "");
strcpy(rs->user.ident, "ret_val");
}
}
/* Handle a complex return type -- declare a new parameter (pointer to
a complex value) */
else if( ISCOMPLEX(type) ) {
if (!xretslot[type])
xretslot[type] =
autovar(0, type, EXNULL, " ret_val");
/* the blank is for use in out_addr */
np->vstg = STGARG;
if(cxslot < 0)
cxslot = nextarg(TYADDR);
}
else if (type != TYSUBR) {
if (type == TYUNKNOWN) {
dclerr("untyped function", np);
proctype = type = np->vtype =
dflttype[letter(np->fvarname[0])];
}
if (!xretslot[type])
xretslot[type] = retslot =
autovar(1, type, EXNULL, " ret_val");
/* the blank is for use in out_addr */
np->vstg = STGAUTO;
}
for(p = ep->arglist ; p ; p = p->nextp)
if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
q->vknownarg = 1;
q->vardesc.varno = nextarg(TYADDR);
allargs = mkchain((char *)q, allargs);
q->argno = nallargs++;
}
else if (nentry == 1)
duparg(q);
else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
if ((Namep)p1->datap == q)
duparg(q);
k = 0;
for(p = ep->arglist ; p ; p = p->nextp) {
if(! (( q = (Namep) (p->datap) )->vdcldone) )
{
impldcl(q);
q->vdcldone = YES;
if(q->vtype == TYCHAR)
{
/* If we don't know the length of a char*(*) (i.e. a string), we must add
in this additional length argument. */
++nallchargs;
if (q->vclass == CLPROC)
nallchargs--;
else if (q->vleng == NULL) {
/* character*(*) */
q->vleng = (expptr)
mkarg(TYLENG, nextarg(TYLENG) );
unamstring((Addrp)q->vleng,
new_arg_length(q));
}
}
}
if (q->vdimfinish)
dim_finish(q);
if (q->vtype == TYCHAR && q->vclass != CLPROC)
k++;
}
if (entryname->extype != type)
changedtype(np);
/* save information for checking consistency of arg lists */
it = infertypes;
if (entryname->exproto)
infertypes = 1;
save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
0, np->fvarname, STGEXT, k, np->vtype, 2);
infertypes = it;
}
frtemp(Addrp p)
#endif
{
/* put block on chain of temps to be reclaimed */
holdtemps = mkchain((char *)p, holdtemps);
}
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 */