void
hashclear(Void) /* clear hash table */
{
register struct Hashentry *hp;
register Namep p;
register struct Dimblock *q;
register int i;
for(hp = hashtab ; hp < lasthash ; ++hp)
if(p = hp->varp)
{
frexpr(p->vleng);
if(q = p->vdim)
{
for(i = 0 ; i < q->ndim ; ++i)
{
frexpr(q->dims[i].dimsize);
frexpr(q->dims[i].dimexpr);
}
frexpr(q->nelt);
frexpr(q->baseoffset);
frexpr(q->basexpr);
free( (charptr) q);
}
if(p->vclass == CLNAMELIST)
frchain( &(p->varxptr.namelist) );
free( (charptr) p);
hp->varp = NULL;
}
}
p1_expr(expptr expr)
#endif
{
/* An opcode of 0 means a null entry */
if (expr == ENULL) {
p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */
return;
} /* if (expr == ENULL) */
switch (expr -> tag) {
case TNAME:
p1_name ((Namep) expr);
return;
case TCONST:
p1_const(&expr->constblock);
return;
case TEXPR:
/* Fall through the switch */
break;
case TADDR:
p1_addr (&(expr -> addrblock));
goto freeup;
case TPRIM:
warn ("p1_expr: got TPRIM");
return;
case TLIST:
p1_list (&(expr->listblock));
frchain( &(expr->listblock.listp) );
return;
case TERROR:
return;
default:
erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
return;
}
/* Now we know that the tag is TEXPR */
if (is_unary_op (expr -> exprblock.opcode))
p1_unary (&(expr -> exprblock));
else if (is_binary_op (expr -> exprblock.opcode))
p1_binary (&(expr -> exprblock));
else
erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode);
freeup:
free((char *)expr);
} /* p1_expr */
static void
zap_changes(Void)
{
register chainp cp;
register Argtypes *at;
/* arrange to get correct count of prototypes that would
change by running f2c again */
if (prev_proc && proc_argchanges)
proc_protochanges++;
prev_proc = proc_argchanges = 0;
for(cp = new_procs; cp; cp = cp->nextp)
if (at = ((Namep)cp->datap)->arginfo)
at->changes &= ~1;
frchain(&new_procs);
}
void
enddcl(Void)
{
register struct Entrypoint *ep;
struct Entrypoint *ep0;
chainp cp;
extern char *err_proc;
static char comblks[] = "common blocks";
err_proc = comblks;
docommon();
/* Now the hash table entries for fields of common blocks have STGCOMMON,
vdcldone, voffset, and varno. And the common blocks themselves have
their full sizes in extleng. */
err_proc = "equivalences";
doequiv();
err_proc = comblks;
docomleng();
/* This implies that entry points in the declarations are buffered in
entries but not written out */
err_proc = "entries";
if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
/* entries could be 0 in case of an error */
do doentry(ep);
while(ep = ep->entnextp);
entries = (struct Entrypoint *)revchain((chainp)ep0);
}
err_proc = 0;
parstate = INEXEC;
p1put(P1_PROCODE);
freetemps();
if (earlylabs) {
for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
p1_label((long)cp->datap);
frchain(&earlylabs);
}
p1_line_number(lineno); /* for files that start with a MAIN program */
/* that starts with an executable statement */
}
frdata(chainp p0)
#endif
{
register struct Chain *p;
register tagptr q;
for(p = p0 ; p ; p = p->nextp)
{
q = (tagptr)p->datap;
if(q->tag == TIMPLDO)
{
if(q->impldoblock.isbusy)
return; /* circular chain completed */
q->impldoblock.isbusy = YES;
frdata(q->impldoblock.datalist);
free( (charptr) q);
}
else
frexpr(q);
}
frchain( &p0);
}
void
procinit(Void)
{
register struct Labelblock *lp;
struct Chain *cp;
int i;
struct memblock;
extern struct memblock *curmemblock, *firstmemblock;
extern char *mem_first, *mem_next, *mem_last, *mem0_last;
curmemblock = firstmemblock;
mem_next = mem_first;
mem_last = mem0_last;
ei_next = ei_first = ei_last = 0;
wh_next = wh_first = wh_last = 0;
iob_list = 0;
for(i = 0; i < 9; i++)
io_structs[i] = 0;
parstate = OUTSIDE;
headerdone = NO;
blklevel = 1;
saveall = NO;
substars = NO;
nwarn = 0;
thislabel = NULL;
needkwd = 0;
proctype = TYUNKNOWN;
procname = "MAIN_";
procclass = CLUNKNOWN;
nentry = 0;
nallargs = nallchargs = 0;
multitype = NO;
retslot = NULL;
for(i = 0; i < NTYPES0; i++) {
frexpr((expptr)xretslot[i]);
xretslot[i] = 0;
}
cxslot = -1;
chslot = -1;
chlgslot = -1;
procleng = 0;
blklevel = 1;
lastargslot = 0;
for(lp = labeltab ; lp < labtabend ; ++lp)
lp->stateno = 0;
hashclear();
/* Clear the list of newly generated identifiers from the previous
function */
frexchain(&new_vars);
frexchain(&used_builtins);
frchain(&assigned_fmts);
frchain(&allargs);
frchain(&earlylabs);
nintnames = 0;
highlabtab = labeltab;
ctlstack = ctls - 1;
for(i = TYADDR; i < TYVOID; i++) {
for(cp = templist[i]; cp ; cp = cp->nextp)
free( (charptr) (cp->datap) );
frchain(templist + i);
autonum[i] = 0;
}
holdtemps = NULL;
dorange = 0;
nregvar = 0;
highregvar = 0;
entries = NULL;
rpllist = NULL;
inioctl = NO;
eqvstart += nequiv;
nequiv = 0;
dcomplex_seen = 0;
for(i = 0 ; i<NTYPES0 ; ++i)
rtvlabel[i] = 0;
if(undeftype)
setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
else
{
setimpl(tyreal, (ftnint) 0, 'a', 'z');
setimpl(tyint, (ftnint) 0, 'i', 'n');
}
setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
}
intrcall(Namep np, struct Listblock *argsp, int nargs)
#endif
{
int i, rettype;
Addrp ap;
register struct Specblock *sp;
register struct Chain *cp;
expptr q, ep;
int mtype;
int op;
int f1field, f2field, f3field;
packed.ijunk = np->vardesc.varno;
f1field = packed.bits.f1;
f2field = packed.bits.f2;
f3field = packed.bits.f3;
if(nargs == 0)
goto badnargs;
mtype = 0;
for(cp = argsp->listp ; cp ; cp = cp->nextp)
{
ep = (expptr)cp->datap;
if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
cp->datap = (char *) mkconv(tyint, ep);
mtype = maxtype(mtype, ep->headblock.vtype);
}
switch(f1field)
{
case INTRBOOL:
op = f3field;
if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
goto badtype;
if(op == OPBITNOT)
{
if(nargs != 1)
goto badnargs;
q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
}
else
{
if(nargs != 2)
goto badnargs;
q = mkexpr(op, (expptr)argsp->listp->datap,
(expptr)argsp->listp->nextp->datap);
}
frchain( &(argsp->listp) );
free( (charptr) argsp);
return(q);
case INTRCONV:
rettype = f2field;
switch(rettype) {
case TYLONG:
rettype = tyint;
break;
case TYLOGICAL:
rettype = tylog;
}
if( ISCOMPLEX(rettype) && nargs==2)
{
expptr qr, qi;
qr = (expptr) argsp->listp->datap;
qi = (expptr) argsp->listp->nextp->datap;
if(ISCONST(qr) && ISCONST(qi))
q = mkcxcon(qr,qi);
else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
mkconv(rettype-2,qi));
}
else if(nargs == 1) {
if (f3field && ((Exprp)argsp->listp->datap)->vtype
== TYDCOMPLEX)
rettype = TYDREAL;
q = mkconv(rettype+100, (expptr)argsp->listp->datap);
if (q->tag == TADDR)
q->addrblock.parenused = 1;
}
else goto badnargs;
q->headblock.vtype = rettype;
frchain(&(argsp->listp));
free( (charptr) argsp);
return(q);
#if 0
case INTRCNST:
/* Machine-dependent f77 stuff that f2c omits:
intcon contains
radix for short int
radix for long int
radix for single precision
radix for double precision
precision for short int
precision for long int
precision for single precision
precision for double precision
emin for single precision
emin for double precision
emax for single precision
emax for double prcision
largest short int
largest long int
realcon contains
tiny for single precision
tiny for double precision
huge for single precision
huge for double precision
mrsp (epsilon) for single precision
mrsp (epsilon) for double precision
*/
{ register struct Incstblock *cstp;
extern ftnint intcon[14];
extern double realcon[6];
cstp = consttab + f3field;
for(i=0 ; i<f2field ; ++i)
if(cstp->atype == mtype)
goto foundconst;
else
++cstp;
goto badtype;
foundconst:
switch(cstp->rtype)
{
case TYLONG:
return(mkintcon(intcon[cstp->constno]));
case TYREAL:
case TYDREAL:
return(mkrealcon(cstp->rtype,
realcon[cstp->constno]) );
default:
Fatal("impossible intrinsic constant");
}
}
#endif
case INTRGEN:
sp = spectab + f3field;
if(no66flag)
if(sp->atype == mtype)
goto specfunct;
else err66("generic function");
for(i=0; i<f2field ; ++i)
if(sp->atype == mtype)
goto specfunct;
else
++sp;
warn1 ("bad argument type to intrinsic %s", np->fvarname);
/* Made this a warning rather than an error so things like "log (5) ==>
log (5.0)" can be accommodated. When none of these cases matches, the
argument is cast up to the first type in the spectab list; this first
type is assumed to be the "smallest" type, e.g. REAL before DREAL
before COMPLEX, before DCOMPLEX */
sp = spectab + f3field;
mtype = sp -> atype;
goto specfunct;
case INTRSPEC:
sp = spectab + f3field;
specfunct:
if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
&& (sp+1)->atype==sp->atype)
++sp;
if(nargs != sp->nargs)
goto badnargs;
if(mtype != sp->atype)
goto badtype;
/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
the inline expression wouldn't get put into the constant table */
fixargs (NO, argsp);
cast_args (mtype, argsp -> listp);
if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
{
frchain( &(argsp->listp) );
free( (charptr) argsp);
} else {
if(sp->othername) {
/* C library routines that return double... */
/* sp->rtype might be TYREAL */
ap = builtin(sp->rtype,
callbyvalue[sp->othername], 1);
q = fixexpr((Exprp)
mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
} else {
fixargs(YES, argsp);
ap = builtin(sp->rtype, sp->spxname, 0);
q = fixexpr((Exprp)
mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
} /* else */
} /* else */
return(q);
case INTRMIN:
case INTRMAX:
if(nargs < 2)
goto badnargs;
if( ! ONEOF(mtype, MSKINT|MSKREAL) )
goto badtype;
argsp->vtype = mtype;
q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
q->headblock.vtype = mtype;
rettype = f2field;
if(rettype == TYLONG)
rettype = tyint;
else if(rettype == TYUNKNOWN)
rettype = mtype;
return( mkconv(rettype, q) );
default:
fatali("intrcall: bad intrgroup %d", f1field);
}
badnargs:
errstr("bad number of arguments to intrinsic %s", np->fvarname);
goto bad;
badtype:
errstr("bad argument type to intrinsic %s", np->fvarname);
bad:
return( errnode() );
}
putentries(FILE *outfile)
#endif
/* put out wrappers for multiple entries */
{
char base[IDENT_LEN];
struct Entrypoint *e;
Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
chainp args, lengths;
int i, k, mt, nL, type;
extern char *dfltarg[], **dfltproc;
e = entries;
if (!e->enamep) /* only possible with erroneous input */
return;
nL = (nallargs + nallchargs) * sizeof(Namep *);
A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
Ae = A + nallargs;
Alp = (Namep **)(Ae1 = Ae + nallchargs);
i = k = 0;
for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
np = (Namep)args->datap;
if (np->vtype == TYCHAR && np->vclass != CLPROC)
*a1 = &Ae[i++];
}
mt = multitype;
multitype = 0;
sprintf(base, "%s0_", e->enamep->cvarname);
do {
np = e->enamep;
lengths = length_comp(e, 0);
proctype = type = np->vtype;
if (protofile)
protowrite(protofile, type, np->cvarname, e, lengths);
nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
nice_printf(outfile, "%s", np->cvarname);
if (!Ansi) {
listargs(outfile, e, 0, lengths);
nice_printf(outfile, "\n");
}
list_arg_types(outfile, e, lengths, 0, "\n");
nice_printf(outfile, "{\n");
frchain(&lengths);
next_tab(outfile);
if (mt)
nice_printf(outfile,
"Multitype ret_val;\n%s(%d, &ret_val",
base, k); /*)*/
else if (ISCOMPLEX(type))
nice_printf(outfile, "%s(%d,%s", base, k,
xretslot[type]->user.ident); /*)*/
else if (type == TYCHAR)
nice_printf(outfile,
"%s(%d, ret_val, ret_val_len", base, k); /*)*/
else
nice_printf(outfile, "return %s(%d", base, k); /*)*/
k++;
memset((char *)A, 0, nL);
for(args = e->arglist; args; args = args->nextp) {
np = (Namep)args->datap;
A[np->argno] = np;
if (np->vtype == TYCHAR && np->vclass != CLPROC)
*Alp[np->argno] = np;
}
args = allargs;
for(a = A; a < Ae; a++, args = args->nextp)
nice_printf(outfile, ", %s", (np = *a)
? np->cvarname
: ((Namep)args->datap)->vclass == CLPROC
? dfltproc[((Namep)args->datap)->vtype]
: dfltarg[((Namep)args->datap)->vtype]);
for(; a < Ae1; a++)
if (np = *a)
nice_printf(outfile, ", %s_len", np->fvarname);
else
nice_printf(outfile, ", (ftnint)0");
nice_printf(outfile, /*(*/ ");\n");
if (mt) {
if (type == TYCOMPLEX)
nice_printf(outfile,
"r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
else if (type == TYDCOMPLEX)
nice_printf(outfile,
"r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
else if (type <= TYLOGICAL)
nice_printf(outfile, "return ret_val.%s;\n",
postfix[type-TYINT1]);
}
nice_printf(outfile, "}\n");
prev_tab(outfile);
}
while(e = e->entnextp);
free((char *)A);
}
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);
}
prolog(FILE *outfile, register chainp p)
#endif
{
int addif, addif0, i, nd;
ftnint size;
int *ac;
register Namep q;
register struct Dimblock *dp;
chainp p0, p1;
if(procclass == CLBLOCK)
return;
p0 = p;
p1 = p = argsort(p);
wrote_comment = 0;
comment_file = outfile;
ac = 0;
/* Compute the base addresses and offsets for the array parameters, and
assign these values to local variables */
addif = addif0 = nentry > 1;
for(; p ; p = p->nextp)
{
q = (Namep) p->datap;
if(dp = q->vdim) /* if this param is an array ... */
{
expptr Q, expr;
/* See whether to protect the following with an if. */
/* This only happens when there are multiple entries. */
nd = dp->ndim - 1;
if (addif0) {
if (!ac)
ac = count_args();
if (ac[q->argno] == nentry)
addif = 0;
else if (dp->basexpr
|| dp->baseoffset->constblock.Const.ci)
addif = 1;
else for(addif = i = 0; i <= nd; i++)
if (dp->dims[i].dimexpr
&& (i < nd || !q->vlastdim)) {
addif = 1;
break;
}
if (addif) {
write_comment();
nice_printf(outfile, "if (%s) {\n", /*}*/
q->cvarname);
next_tab(outfile);
}
}
for(i = 0 ; i <= nd; ++i)
/* Store the variable length of each dimension (which is fixed upon
runtime procedure entry) into a local variable */
if ((Q = dp->dims[i].dimexpr)
&& (i < nd || !q->vlastdim)) {
expr = (expptr)cpexpr(Q);
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
fixtype(cpexpr(dp->dims[i].dimsize)), expr));
} /* if dp -> dims[i].dimexpr */
/* size will equal the size of a single element, or -1 if the type is
variable length character type */
size = typesize[ q->vtype ];
if(q->vtype == TYCHAR)
if( ISICON(q->vleng) )
size *= q->vleng->constblock.Const.ci;
else
size = -1;
/* Fudge the argument pointers for arrays so subscripts
* are 0-based. Not done if array bounds are being checked.
*/
if(dp->basexpr) {
/* Compute the base offset for this procedure */
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
cpexpr(fixtype(dp->baseoffset)),
cpexpr(fixtype(dp->basexpr))));
} /* if dp -> basexpr */
if(! checksubs) {
if(dp->basexpr) {
expptr tp;
/* If the base of this array has a variable adjustment ... */
tp = (expptr) cpexpr (dp -> baseoffset);
if(size < 0 || q -> vtype == TYCHAR)
tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
write_comment();
tp = mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv(TYINT, fixtype
(fixtype (tp))));
/* Avoid type clash by removing the type conversion */
tp = prune_left_conv (tp);
out_and_free_statement (outfile, tp);
} else if(dp->baseoffset->constblock.Const.ci != 0) {
/* if the base of this array has a nonzero constant adjustment ... */
expptr tp;
write_comment();
if(size > 0 && q -> vtype != TYCHAR) {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(cpexpr (dp->baseoffset)))));
out_and_free_statement (outfile, tp);
} else {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
cpexpr (q -> vleng))))));
out_and_free_statement (outfile, tp);
} /* else */
} /* if dp -> baseoffset -> const */
} /* if !checksubs */
if (addif) {
nice_printf(outfile, /*{*/ "}\n");
prev_tab(outfile);
}
}
}
if (wrote_comment)
nice_printf (outfile, "\n/* Function Body */\n");
if (ac)
free((char *)ac);
if (p0 != p1)
frchain(&p1);
} /* prolog */
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;
}
