wr_struct(FILE *outfile, chainp var_list)
#endif
{
int last_type = -1;
int did_one = 0;
chainp this_var;
for (this_var = var_list; this_var; this_var = this_var -> nextp) {
Namep var = (Namep) this_var -> datap;
int type;
char *comment = NULL;
if (var == (Namep) NULL)
err ("wr_struct: null variable");
else if (var -> tag != TNAME)
erri ("wr_struct: bad tag on variable '%d'",
var -> tag);
type = var -> vtype;
if (last_type == type && did_one)
nice_printf (outfile, ", ");
else {
if (did_one)
nice_printf (outfile, ";\n");
nice_printf (outfile, "%s ",
c_type_decl (type, var -> vclass == CLPROC));
} /* else */
/* Character type is really a string type. Put out a '*' for parameters
with unknown length and functions returning character */
if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
|| var -> vclass == CLPROC))
nice_printf (outfile, "*");
var -> vstg = STGAUTO;
out_name (outfile, var);
if (var -> vclass == CLPROC)
nice_printf (outfile, "()");
else if (var -> vdim)
comment = wr_ardecls(outfile, var->vdim,
var->vtype == TYCHAR && ISICON(var->vleng)
? var->vleng->constblock.Const.ci : 1L);
else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
ISICON ((var -> vleng)))
nice_printf (outfile, "[%ld]",
var -> vleng -> constblock.Const.ci);
if (comment)
nice_printf (outfile, "%s", comment);
did_one = 1;
last_type = type;
} /* for this_var */
if (did_one)
nice_printf (outfile, ";\n");
} /* wr_struct */
iarrlen(register Namep q)
#endif
{
ftnint leng;
leng = typesize[q->vtype];
if(leng <= 0)
return(-1);
if(q->vdim)
if( ISICON(q->vdim->nelt) )
leng *= q->vdim->nelt->constblock.Const.ci;
else return(-1);
if(q->vleng)
if( ISICON(q->vleng) )
leng *= q->vleng->constblock.Const.ci;
else return(-1);
return(leng);
}
p1_const(register Constp cp)
#endif
{
int type = cp->vtype;
expptr vleng = cp->vleng;
union Constant *c = &cp->Const;
char cdsbuf0[64], cdsbuf1[64];
char *cds0, *cds1;
switch (type) {
case TYINT1:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD0
case TYQUAD:
#endif
case TYLOGICAL:
case TYLOGICAL1:
case TYLOGICAL2:
fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
break;
#ifndef NO_LONG_LONG
case TYQUAD:
fprintf(pass1_file, "%d: %d %llx\n", P1_CONST, type, c->cq);
break;
#endif
case TYREAL:
case TYDREAL:
fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
break;
case TYCOMPLEX:
case TYDCOMPLEX:
if (cp->vstg) {
cds0 = c->cds[0];
cds1 = c->cds[1];
}
else {
cds0 = cds(dtos(c->cd[0]), cdsbuf0);
cds1 = cds(dtos(c->cd[1]), cdsbuf1);
}
fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
cds0, cds1);
break;
case TYCHAR:
if (vleng && !ISICON (vleng))
err("p1_const: bad vleng\n");
else
fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
cpexpr((expptr)cp));
break;
default:
erri ("p1_const: bad constant type '%d'", type);
break;
} /* switch */
} /* p1_const */
dataval(register expptr repp, register expptr valp)
#endif
{
int i, nrep;
ftnint elen;
register Addrp p;
if (parstate < INDATA) {
frexpr(repp);
goto ret;
}
if(repp == NULL)
nrep = 1;
else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
nrep = repp->constblock.Const.ci;
else
{
err("invalid repetition count in DATA statement");
frexpr(repp);
goto ret;
}
frexpr(repp);
if( ! ISCONST(valp) ) {
if (valp->tag == TADDR
&& valp->addrblock.uname_tag == UNAM_CONST) {
/* kludge */
frexpr(valp->addrblock.memoffset);
valp->tag = TCONST;
}
else {
err("non-constant initializer");
goto ret;
}
}
if(toomanyinit) goto ret;
for(i = 0 ; i < nrep ; ++i)
{
p = nextdata(&elen);
if(p == NULL)
{
err("too many initializers");
toomanyinit = YES;
goto ret;
}
setdata((Addrp)p, (Constp)valp, elen);
frexpr((expptr)p);
}
ret:
frexpr(valp);
}
LOCAL NODE *
putpower(bigptr p)
{
NODE *p3;
bigptr base;
struct bigblock *t1, *t2;
ftnint k = 0; /* XXX gcc */
int type;
if(!ISICON(p->b_expr.rightp) ||
(k = p->b_expr.rightp->b_const.fconst.ci)<2)
fatal("putpower: bad call");
base = p->b_expr.leftp;
type = base->vtype;
t1 = fmktemp(type, NULL);
t2 = NULL;
p3 = putassign(cpexpr(t1), cpexpr(base) );
sendp2(p3);
for( ; (k&1)==0 && k>2 ; k>>=1 ) {
p3 = putassign(cpexpr(t1),
mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
sendp2(p3);
}
if(k == 2)
p3 = putx(mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
else {
t2 = fmktemp(type, NULL);
p3 = putassign(cpexpr(t2), cpexpr(t1));
sendp2(p3);
for(k>>=1 ; k>1 ; k>>=1) {
p3 = putassign(cpexpr(t1),
mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)));
sendp2(p3);
if(k & 1) {
p3 = putassign(cpexpr(t2),
mkexpr(OPSTAR, cpexpr(t2), cpexpr(t1)));
sendp2(p3);
}
}
p3 = putx( mkexpr(OPSTAR, cpexpr(t2),
mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
}
frexpr(t1);
if(t2)
frexpr(t2);
frexpr(p);
return p3;
}
lencat(register expptr p)
#endif
{
if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
return(p->headblock.vleng->constblock.Const.ci);
else if(p->tag==TADDR && p->addrblock.varleng!=0)
return(p->addrblock.varleng);
else
{
err("impossible element in concatenation");
return(0);
}
}
LOCAL struct bigblock *
putch1(bigptr p)
{
struct bigblock *t;
switch(p->tag) {
case TCONST:
return( putconst(p) );
case TADDR:
return(p);
case TEXPR:
switch(p->b_expr.opcode) {
case OPCALL:
case OPCCALL:
t = putcall(p);
sendp2(callval);
break;
case OPCONCAT:
t = fmktemp(TYCHAR, cpexpr(p->vleng) );
sendp2(putcat( cpexpr(t), p ));
break;
case OPCONV:
if(!ISICON(p->vleng) ||
p->vleng->b_const.fconst.ci!=1
|| ! XINT(p->b_expr.leftp->vtype) )
fatal("putch1: bad character conversion");
t = fmktemp(TYCHAR, MKICON(1) );
sendp2(putassign( cpexpr(t), p));
break;
default:
fatal1("putch1: invalid opcode %d", p->b_expr.opcode);
t = NULL; /* XXX gcc */
}
return(t);
default:
fatal1("putch1: bad tag %d", p->tag);
}
/* NOTREACHED */
return NULL; /* XXX gcc */
}
mktmpn(int nelt, register int type, expptr lengp)
#endif
{
ftnint leng;
chainp p, oldp;
register Addrp q;
extern int krparens;
if(type==TYUNKNOWN || type==TYERROR)
badtype("mktmpn", type);
if(type==TYCHAR)
if(lengp && ISICON(lengp) )
leng = lengp->constblock.Const.ci;
else {
err("adjustable length");
return( (Addrp) errnode() );
}
else if (type > TYCHAR || type < TYADDR) {
erri("mktmpn: unexpected type %d", type);
exit(1);
}
/*
* if a temporary of appropriate shape is on the templist,
* remove it from the list and return it
*/
if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
type++;
for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp)
{
q = (Addrp) (p->datap);
if(q->ntempelt==nelt &&
(type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
{
if(oldp)
oldp->nextp = p->nextp;
else
templist[type] = p->nextp;
free( (charptr) p);
return(q);
}
}
q = autovar(nelt, type, lengp, "");
return(q);
}
autovar(register int nelt0, register int t, expptr lengp, char *name)
#endif
{
ftnint leng;
register Addrp q;
register int nelt = nelt0 > 0 ? nelt0 : 1;
extern char *av_pfix[];
if(t == TYCHAR)
if( ISICON(lengp) )
leng = lengp->constblock.Const.ci;
else {
Fatal("automatic variable of nonconstant length");
}
else
leng = typesize[t];
q = ALLOC(Addrblock);
q->tag = TADDR;
q->vtype = t;
if(t == TYCHAR)
{
q->vleng = ICON(leng);
q->varleng = leng;
}
q->vstg = STGAUTO;
q->ntempelt = nelt;
q->isarray = (nelt > 1);
q->memoffset = ICON(0);
/* kludge for nls so we can have ret_val rather than ret_val_4 */
if (*name == ' ')
unamstring(q, name);
else {
q->uname_tag = UNAM_IDENT;
temp_name(av_pfix[t], ++autonum[t], q->user.ident);
}
if (nelt0 > 0)
declare_new_addr (q);
return(q);
}
/* 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);
}
}
nextdata(ftnint *elenp)
#endif
{
register struct Impldoblock *ip;
struct Primblock *pp;
register Namep np;
register struct Rplblock *rp;
tagptr p;
expptr neltp;
register expptr q;
int skip;
ftnint off, vlen;
while(curdtp)
{
p = (tagptr)curdtp->datap;
if(p->tag == TIMPLDO)
{
ip = &(p->impldoblock);
if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
fatali("bad impldoblock 0%o", (int) ip);
if(ip->isactive)
ip->varvp->Const.ci += ip->impdiff;
else
{
q = fixtype(cpexpr(ip->implb));
if( ! ISICON(q) )
goto doerr;
ip->varvp = (Constp) q;
if(ip->impstep)
{
q = fixtype(cpexpr(ip->impstep));
if( ! ISICON(q) )
goto doerr;
ip->impdiff = q->constblock.Const.ci;
frexpr(q);
}
else
ip->impdiff = 1;
q = fixtype(cpexpr(ip->impub));
if(! ISICON(q))
goto doerr;
ip->implim = q->constblock.Const.ci;
frexpr(q);
ip->isactive = YES;
rp = ALLOC(Rplblock);
rp->rplnextp = rpllist;
rpllist = rp;
rp->rplnp = ip->varnp;
rp->rplvp = (expptr) (ip->varvp);
rp->rpltag = TCONST;
}
if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
|| (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
{ /* start new loop */
curdtp = ip->datalist;
goto next;
}
/* clean up loop */
if(rpllist)
{
rp = rpllist;
rpllist = rpllist->rplnextp;
free( (charptr) rp);
}
else
Fatal("rpllist empty");
frexpr((expptr)ip->varvp);
ip->isactive = NO;
curdtp = curdtp->nextp;
goto next;
}
pp = (struct Primblock *) p;
np = pp->namep;
cur_varname = np->fvarname;
skip = YES;
if(p->primblock.argsp==NULL && np->vdim!=NULL)
{ /* array initialization */
q = (expptr) mkaddr(np);
off = typesize[np->vtype] * curdtelt;
if(np->vtype == TYCHAR)
off *= np->vleng->constblock.Const.ci;
q->addrblock.memoffset =
mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
if( (neltp = np->vdim->nelt) && ISCONST(neltp))
{
if(++curdtelt < neltp->constblock.Const.ci)
skip = NO;
}
else
err("attempt to initialize adjustable array");
}
else
q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
if(skip)
{
curdtp = curdtp->nextp;
curdtelt = 0;
}
if(q->headblock.vtype == TYCHAR)
if(ISICON(q->headblock.vleng))
*elenp = q->headblock.vleng->constblock.Const.ci;
else {
err("initialization of string of nonconstant length");
continue;
}
else *elenp = typesize[q->headblock.vtype];
if (np->vstg == STGBSS) {
vlen = np->vtype==TYCHAR
? np->vleng->constblock.Const.ci
: typesize[np->vtype];
if(vlen > 0)
np->vstg = STGINIT;
}
return( (Addrp) q );
doerr:
err("nonconstant implied DO parameter");
frexpr(q);
curdtp = curdtp->nextp;
next:
curdtelt = 0;
}
return(NULL);
}
/*
* Convert a f77 tree statement to something that looks like a
* pcc expression tree.
*/
NODE *
putx(bigptr q)
{
struct bigblock *x1;
NODE *p = NULL; /* XXX */
int opc;
int type, k;
#ifdef PCC_DEBUG
if (tflag) {
printf("putx %p\n", q);
fprint(q, 0);
}
#endif
switch(q->tag) {
case TERROR:
ckfree(q);
break;
case TCONST:
switch(type = q->vtype) {
case TYLOGICAL:
type = tyint;
case TYLONG:
case TYSHORT:
p = mklnode(ICON, q->b_const.fconst.ci,
0, types2[type]);
ckfree(q);
break;
case TYADDR:
p = mklnode(ICON, 0, 0, types2[type]);
p->n_name = copys(memname(STGCONST,
(int)q->b_const.fconst.ci));
ckfree(q);
break;
default:
p = putx(putconst(q));
break;
}
break;
case TEXPR:
switch(opc = q->b_expr.opcode) {
case OPCALL:
case OPCCALL:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else {
putcall(q);
p = callval;
}
break;
case OPMIN:
case OPMAX:
p = putmnmx(q);
break;
case OPASSIGN:
if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
ISCOMPLEX(q->b_expr.rightp->vtype)) {
frexpr(putcxeq(q));
} else if (ISCHAR(q))
p = putcheq(q);
else
goto putopp;
break;
case OPEQ:
case OPNE:
if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
ISCOMPLEX(q->b_expr.rightp->vtype) ) {
p = putcxcmp(q);
break;
}
case OPLT:
case OPLE:
case OPGT:
case OPGE:
if(ISCHAR(q->b_expr.leftp))
p = putchcmp(q);
else
goto putopp;
break;
case OPPOWER:
p = putpower(q);
break;
case OPSTAR:
/* m * (2**k) -> m<<k */
if (XINT(q->b_expr.leftp->vtype) &&
ISICON(q->b_expr.rightp) &&
((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
q->b_expr.opcode = OPLSHIFT;
frexpr(q->b_expr.rightp);
q->b_expr.rightp = MKICON(k);
goto putopp;
}
case OPMOD:
goto putopp;
case OPPLUS:
case OPMINUS:
case OPSLASH:
case OPNEG:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else
goto putopp;
break;
case OPCONV:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
p = putx(mkconv(q->vtype,
realpart(putcx1(q->b_expr.leftp))));
ckfree(q);
} else
goto putopp;
break;
case OPAND:
/* Create logical AND */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
k = newlabel();
putif(q->b_expr.leftp, k);
putif(q->b_expr.rightp, k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
putlabel(k);
p = putx(x1);
break;
case OPNOT: /* Logical NOT */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
k = newlabel();
putif(q->b_expr.leftp, k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
putlabel(k);
p = putx(x1);
break;
case OPOR: /* Create logical OR */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
k = newlabel();
putif(mkexpr(OPEQ, q->b_expr.leftp,
mklogcon(0)), k);
putif(mkexpr(OPEQ, q->b_expr.rightp,
mklogcon(0)), k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
putlabel(k);
p = putx(x1);
break;
case OPCOMMA:
for (x1 = q; x1->b_expr.opcode == OPCOMMA;
x1 = x1->b_expr.leftp)
putexpr(x1->b_expr.rightp);
p = putx(x1);
break;
case OPEQV:
case OPNEQV:
case OPADDR:
case OPBITOR:
case OPBITAND:
case OPBITXOR:
case OPBITNOT:
case OPLSHIFT:
case OPRSHIFT:
putopp:
p = putop(q);
break;
default:
fatal1("putx: invalid opcode %d", opc);
}
break;
case TADDR:
p = putaddr(q, YES);
break;
default:
fatal1("putx: impossible tag %d", q->tag);
}
return p;
}
p1_addr(register struct Addrblock *addrp)
#endif
{
int stg;
if (addrp == (struct Addrblock *) NULL)
return;
stg = addrp -> vstg;
if (ONEOF(stg, M(STGINIT)|M(STGREG))
|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
(!ISICON(addrp->memoffset)
|| (addrp->uname_tag == UNAM_NAME
? addrp->memoffset->constblock.Const.ci
!= addrp->user.name->voffset
: addrp->memoffset->constblock.Const.ci))
|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
(!ISICON(addrp->memoffset)
|| addrp->memoffset->constblock.Const.ci)
|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
{
p1_big_addr (addrp);
return;
}
/* Write out a level of indirection for non-array arguments, which have
addrp -> memoffset set and are handled by p1_big_addr().
Lengths are passed by value, so don't check STGLENG
28-Jun-89 (dmg) Added the check for != TYCHAR
*/
if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
p1_expr (ENULL); /* Put dummy vleng */
} /* if stg == STGARG */
switch (addrp -> uname_tag) {
case UNAM_NAME:
p1_name (addrp -> user.name);
break;
case UNAM_IDENT:
p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
addrp->user.ident);
break;
case UNAM_CHARP:
p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
addrp->user.Charp);
break;
case UNAM_EXTERN:
p1putd (P1_EXTERN, (long) addrp -> memno);
if (addrp->vclass == CLPROC)
extsymtab[addrp->memno].extype = addrp->vtype;
break;
case UNAM_CONST:
if (addrp -> memno != BAD_MEMNO)
p1_literal (addrp -> memno);
else
p1_const((struct Constblock *)addrp);
break;
case UNAM_UNKNOWN:
default:
erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag);
break;
} /* switch */
} /* p1_addr */
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 */
