newentry(register Namep v, int substmsg)
#endif
{
register Extsym *p;
char buf[128], badname[64];
static int nbad = 0;
static char already[] = "external name already used";
p = mkext(v->fvarname, addunder(v->cvarname));
if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
{
sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
if (substmsg) {
sprintf(buf,"%s\n\tsubstituting \"%s\"",
already, badname);
dclerr(buf, v);
}
else
dclerr(already, v);
p = mkext(v->fvarname, badname);
}
v->vstg = STGAUTO;
v->vprocclass = PTHISPROC;
v->vclass = CLPROC;
if (p->extstg == STGEXT)
prev_proc = 1;
else
p->extstg = STGEXT;
p->extinit = YES;
v->vardesc.varno = p - extsymtab;
return(p);
}
setintr(register Namep v)
#endif
{
int k;
if(k = intrfunct(v->fvarname)) {
if ((*(struct Intrpacked *)&k).f4)
if (noextflag)
goto unknown;
else
dcomplex_seen++;
v->vardesc.varno = k;
}
else {
unknown:
dclerr("unknown intrinsic function", v);
return;
}
if(v->vstg == STGUNKNOWN)
v->vstg = STGINTR;
else if(v->vstg!=STGINTR)
dclerr("incompatible use of intrinsic function", v);
if(v->vclass==CLUNKNOWN)
v->vclass = CLPROC;
if(v->vprocclass == PUNKNOWN)
v->vprocclass = PINTRINSIC;
else if(v->vprocclass != PINTRINSIC)
dclerr("invalid intrinsic declaration", v);
}
setext(register Namep v)
#endif
{
if(v->vclass == CLUNKNOWN)
v->vclass = CLPROC;
else if(v->vclass != CLPROC)
dclerr("invalid external declaration", v);
if(v->vprocclass == PUNKNOWN)
v->vprocclass = PEXTERNAL;
else if(v->vprocclass != PEXTERNAL)
dclerr("invalid external declaration", v);
} /* setext */
dim_check(Namep q)
#endif
{
register struct Dimblock *vdim = q->vdim;
register expptr nelt;
if(!(nelt = vdim->nelt) || !ISCONST(nelt))
dclerr("adjustable dimension on non-argument", q);
else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
bad_dimtype(q);
else if (ISINT(nelt->headblock.vtype)
? nelt->constblock.Const.ci <= 0
: nelt->constblock.Const.cd[0] <= 0.)
dclerr("nonpositive dimension", q);
}
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;
}
}
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);
}
}
eqvcommon(struct Equivblock *p, int comno, ftnint comoffset)
#endif
{
int ovarno;
ftnint k, offq;
register Namep np;
register struct Eqvchain *q;
if(comoffset + p->eqvbottom < 0)
{
errstr("attempt to extend common %s backward",
extsymtab[comno].fextname);
freqchain(p);
return;
}
if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
extsymtab[comno].extleng = k;
for(q = p->equivs ; q ; q = q->eqvnextp)
if(np = q->eqvitem.eqvname)
{
switch(np->vstg)
{
case STGUNKNOWN:
case STGBSS:
np->vstg = STGCOMMON;
np->vcommequiv = 1;
np->vardesc.varno = comno;
/* np -> voffset will point to the base of the array */
np->voffset = comoffset - q->eqvoffset;
break;
case STGEQUIV:
ovarno = np->vardesc.varno;
/* offq will point to the current element, even if it's in an array */
offq = comoffset - q->eqvoffset - np->voffset;
np->vstg = STGCOMMON;
np->vcommequiv = 1;
np->vardesc.varno = comno;
/* np -> voffset will point to the base of the array */
np->voffset += offq;
if(ovarno != (p - eqvclass))
eqvcommon(&eqvclass[ovarno], comno, offq);
break;
case STGCOMMON:
if(comno != np->vardesc.varno ||
comoffset != np->voffset+q->eqvoffset)
dclerr("inconsistent common usage", np);
break;
default:
badstg("eqvcommon", np->vstg);
}
}
freqchain(p);
p->eqvbottom = p->eqvtop = 0;
}
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;
}
setbound(Namep v, int nd, struct Dims *dims)
#endif
{
expptr q, q0, t;
struct Dimblock *p;
int i;
extern chainp new_vars;
char buf[256];
if(v->vclass == CLUNKNOWN)
v->vclass = CLVAR;
else if(v->vclass != CLVAR)
{
dclerr("only variables may be arrays", v);
return;
}
v->vdim = p = (struct Dimblock *)
ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
p->ndim = nd--;
p->nelt = ICON(1);
doin_setbound = 1;
if (noextflag)
for(i = 0; i <= nd; i++)
if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
|| ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
sprintf(buf, "dimension %d of %s is not an integer.",
i+1, v->fvarname);
errext(buf);
break;
}
for(i = 0; i <= nd; i++) {
if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
dims[i].lb = mkconv(TYINT, q);
if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
dims[i].ub = mkconv(TYINT, q);
}
for(i = 0; i <= nd; ++i)
{
if( (q = dims[i].ub) == NULL)
{
if(i == nd)
{
frexpr(p->nelt);
p->nelt = NULL;
}
else
err("only last bound may be asterisk");
p->dims[i].dimsize = ICON(1);
p->dims[i].dimexpr = NULL;
}
else
{
if(dims[i].lb)
{
q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
q = mkexpr(OPPLUS, q, ICON(1) );
}
if( ISCONST(q) )
{
p->dims[i].dimsize = q;
p->dims[i].dimexpr = (expptr) PNULL;
}
else {
sprintf(buf, " %s_dim%d", v->fvarname, i+1);
p->dims[i].dimsize = (expptr)
autovar(1, tyint, EXNULL, buf);
p->dims[i].dimexpr = q;
if (i == nd)
v->vlastdim = new_vars;
v->vdimfinish = 1;
}
if(p->nelt)
p->nelt = mkexpr(OPSTAR, p->nelt,
cpexpr(p->dims[i].dimsize) );
}
}
q = dims[nd].lb;
q0 = 0;
if(q == NULL)
q = q0 = ICON(1);
for(i = nd-1 ; i>=0 ; --i)
{
t = dims[i].lb;
if(t == NULL)
t = ICON(1);
if(p->dims[i].dimsize) {
if (q == q0) {
q0 = 0;
frexpr(q);
q = cpexpr(p->dims[i].dimsize);
}
else
q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q);
q = mkexpr(OPPLUS, t, q);
}
}
if( ISCONST(q) )
{
p->baseoffset = q;
p->basexpr = NULL;
}
else
{
sprintf(buf, " %s_offset", v->fvarname);
p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
p->basexpr = q;
v->vdimfinish = 1;
}
doin_setbound = 0;
}
settype(register Namep v, register int type, register ftnint length)
#endif
{
int type1;
if(type == TYUNKNOWN)
return;
if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
{
v->vtype = TYSUBR;
frexpr(v->vleng);
v->vleng = 0;
v->vimpltype = 0;
}
else if(type < 0) /* storage class set */
{
if(v->vstg == STGUNKNOWN)
v->vstg = - type;
else if(v->vstg != -type)
dclerr("incompatible storage declarations", v);
}
else if(v->vtype == TYUNKNOWN
|| v->vtype != type
&& (v->vimpltype || v->vinftype || v->vinfproc))
{
if( (v->vtype = lengtype(type, length))==TYCHAR )
if (length>=0)
v->vleng = ICON(length);
else if (parstate >= INDATA)
v->vleng = ICON(1); /* avoid a memory fault */
v->vimpltype = 0;
v->vinftype = 0; /* 19960709 */
v->vinfproc = 0; /* 19960709 */
if (v->vclass == CLPROC) {
if (v->vstg == STGEXT
&& (type1 = extsymtab[v->vardesc.varno].extype)
&& type1 != v->vtype)
changedtype(v);
else if (v->vprocclass == PTHISPROC
&& (parstate >= INDATA
|| procclass == CLMAIN)
&& !xretslot[type]) {
xretslot[type] = autovar(ONEOF(type,
MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
v->vleng, " ret_val");
if (procclass == CLMAIN)
errstr(
"illegal use of %.60s (main program name)",
v->fvarname);
/* not completely right, but enough to */
/* avoid memory faults; we won't */
/* emit any C as we have illegal Fortran */
}
}
}
else if(v->vtype != type && v->vtype != lengtype(type, length)) {
incompat:
dclerr("incompatible type declarations", v);
}
else if (type==TYCHAR)
if (v->vleng && v->vleng->constblock.Const.ci != length)
goto incompat;
else if (parstate >= INDATA)
v->vleng = ICON(1); /* avoid a memory fault */
}
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 */
