isstatic(register expptr p)
#endif
{
extern int useauto;
if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
return(NO);
switch(p->tag)
{
case TCONST:
return(YES);
case TADDR:
if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
ISCONST(p->addrblock.memoffset) && !useauto)
return(YES);
default:
return(NO);
}
}
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);
}
/*
NAME {* fdd\_scanallvar *}
SECTION {* fdd *}
SHORT {* Finds one satisfying value of all FDD variables *}
PROTO {* int* fdd_scanallvar(BDD r) *}
DESCR {* Finds one satisfying assignment in {\tt r} of all the defined
FDD variables. Each value is stored in an array which is
returned. The size of this array is exactly the number of
FDD variables defined. It is the user's responsibility to
free this array using {\tt free()}. *}
RETURN {* An array with all satisfying values. If {\tt r} is the trivially
false BDD, then NULL is returned. *}
ALSO {* fdd\_scanvar *}
*/
int* fdd_scanallvar(BDD r)
{
int n;
char *store;
int *res;
BDD p = r;
CHECKa(r,NULL);
if (r == bddfalse)
return NULL;
store = NEW(char,bddvarnum);
for (n=0 ; n<bddvarnum ; n++)
store[n] = 0;
while (!ISCONST(p))
{
if (!ISZERO(LOW(p)))
{
store[bddlevel2var[LEVEL(p)]] = 0;
p = LOW(p);
}
else
{
store[bddlevel2var[LEVEL(p)]] = 1;
p = HIGH(p);
}
}
res = NEW(int, fdvarnum);
for (n=0 ; n<fdvarnum ; n++)
{
int m;
int val=0;
for (m=domain[n].binsize-1 ; m>=0 ; m--)
if ( store[domain[n].ivar[m]] )
val = val*2 + 1;
else
val = val*2;
res[n] = val;
}
free(store);
return res;
}
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);
}
static void bdd_fprintdot_rec(FILE* ofile, BDD r)
{
if (ISCONST(r) || MARKED(r))
return;
fprintf(ofile, "%d [label=\"", r);
if (filehandler)
filehandler(ofile, bddlevel2var[LEVEL(r)]);
else
fprintf(ofile, "%d", bddlevel2var[LEVEL(r)]);
fprintf(ofile, "\"];\n");
fprintf(ofile, "%d -> %d [style=dotted];\n", r, LOW(r));
fprintf(ofile, "%d -> %d [style=filled];\n", r, HIGH(r));
SETMARK(r);
bdd_fprintdot_rec(ofile, LOW(r));
bdd_fprintdot_rec(ofile, HIGH(r));
}
commlen(register chainp vl)
#endif
{
ftnint size;
int type;
struct Dimblock *t;
Namep v;
while(vl->nextp)
vl = vl->nextp;
v = (Namep)vl->datap;
type = v->vtype;
if (type == TYCHAR)
size = v->vleng->constblock.Const.ci;
else
size = typesize[type];
if ((t = v->vdim) && ISCONST(t->nelt))
size *= t->nelt->constblock.Const.ci;
return size + v->voffset;
}
make_param(register struct Paramblock *p, expptr e)
#endif
{
register expptr q;
struct Constblock qc;
p->vclass = CLPARAM;
impldcl((Namep)p);
if (e->headblock.vtype != TYCHAR)
e = putx(fixtype(e));
p->paramval = q = mkconv(p->vtype, e);
if (p->vtype == TYCHAR) {
if (q->tag == TEXPR)
p->paramval = q = fixexpr((Exprp)q);
if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) {
qc.Const = q->addrblock.user.Const;
qc.tag = TCONST;
qc.vtype = q->addrblock.vtype;
qc.vleng = q->addrblock.vleng;
q = (expptr)&qc;
}
if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
errstr("invalid value for character parameter %s",
p->fvarname);
return;
}
if (!(e = p->vleng))
p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
+ q->constblock.Const.ccp1.blanks);
else if (q->constblock.vleng->constblock.Const.ci
> e->constblock.Const.ci) {
q->constblock.vleng->constblock.Const.ci
= e->constblock.Const.ci;
q->constblock.Const.ccp1.blanks = 0;
}
else
q->constblock.Const.ccp1.blanks
= e->constblock.Const.ci
- q->constblock.vleng->constblock.Const.ci;
}
}
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);
}
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() );
}
void
Ceval(Node *tp)
{
unsigned int i1, i2;
Node * tp0;
if(tp->Cone || tp->Czero) return;
switch(tp->code) {
case 0:
return;
case ELIST:
if(tp->t1 != 0)
Ceval(tp->t1);
if(tp->t2 != 0)
Ceval(tp->t2);
tp->Czero = tp->Cone = 0;
return;
case ASSIGN:
Ceval(tp->t2);
tp->Czero = tp->t2->Czero;
tp->Cone = tp->t2->Cone;
return;
case DONTCARE:
Ceval(tp->t2);
tp->Czero = tp->t2->Czero;
tp->Cone = tp->t2->Cone;
return;
case AND:
Ceval(tp->t2);
Ceval(tp->t1);
tp->Czero = tp->t2->Czero | tp->t1->Czero;
tp->Cone = tp->t2->Cone & tp->t1->Cone;
return;
case OR:
Ceval(tp->t2);
Ceval(tp->t1);
tp->Czero = tp->t2->Czero & tp->t1->Czero;
tp->Cone = tp->t2->Cone | tp->t1->Cone;
return;
case LAND:
Ceval(tp->t2);
Ceval(tp->t1);
tp->Czero = (~0 << 1) | ((tp->t2->Czero == ~0) || (tp->t1->Czero == ~0));
tp->Cone = (tp->t1->Cone) && (tp->t2->Cone);
return;
case LOR:
Ceval(tp->t2);
Ceval(tp->t1);
tp->Czero = (~0 << 1) | ((tp->t2->Czero == ~0) && (tp->t1->Czero == ~0));
tp->Cone = (tp->t1->Cone) ||(tp->t2->Cone);
return;
case NEG:
Ceval(tp->t1);
tp->Cone = tp->Czero = 0;
if(ISCONST(tp->t1))
tp->Czero = ~(tp->Cone = -tp->t1->Cone);
return;
case XOR:
Ceval(tp->t2);
Ceval(tp->t1);
tp->Czero = (tp->t2->Czero & tp->t1->Czero)
| (tp->t2->Cone & tp->t1->Cone);
tp->Cone = (tp->t2->Czero & tp->t1->Cone)
| (tp->t2->Cone & tp->t1->Czero);
return;
case FLONE:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done find left one for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1);
tp->Czero = ~tp->Cone;
return;
case FRONE:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done find right one for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1);
tp->Czero = ~tp->Cone;
return;
case GREY:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done grey code for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1);
tp->Czero = ~tp->Cone;
return;
case NOT:
Ceval(tp->t1);
tp->Cone = (tp->t1->Czero == ~0);
tp->Czero = (tp->t1->Cone) ? ~0 : (~0 << 1);
return;
case COM:
Ceval(tp->t1);
tp->Cone = (tp->t1->Czero);
tp->Czero = (tp->t1->Cone);
return;
case ADD:
Ceval(tp->t2);
Ceval(tp->t1);
i1 = tp->t1->Cone | tp->t1->Czero;
i1 = i1 & ~(i1 + 1);
i2 = tp->t2->Cone | tp->t2->Czero;
i2 = i2 & ~(i2 + 1);
tp->Cone = i1 & i2 & (tp->t1->Cone + tp->t2->Cone);
tp->Czero = i1 & i2 & ~tp->Cone;
for(i1 = 0; ; i1 = i1<<1 | 1)
if(((tp->t1->Czero | i1) == ~0)
&& ((tp->t2->Czero | i1) == ~0)) break;
tp->Czero |= ~(i1<<1 | 1);
return;
case SUB:
Ceval(tp->t2);
Ceval(tp->t1);
i1 = tp->t1->Cone | tp->t1->Czero;
i1 = i1 & ~(i1 + 1);
i2 = tp->t2->Cone | tp->t2->Czero;
i2 = i2 & ~(i2 + 1);
tp->Cone = i1 & i2 & (tp->t1->Cone + tp->t2->Cone);
tp->Czero = i1 & i2 & ~tp->Cone;
for(i1 = 0; ; i1 = i1<<1 | 1)
if(((tp->t1->Czero | i1) == ~0)
&& ((tp->t2->Czero | i1) == ~0)) break;
i2 = i1 ^ i1>>1;
if((tp->t1->Cone & i2) && (tp->t2->Czero & i2))
tp->Czero |= ~(i1<<1 | 1);
else if((tp->t1->Czero & i2) && (tp->t2->Cone & i2))
tp->Cone |= ~(i1<<1 | 1);
return;
case MUL:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done mult for variable\n");
exits("error");;
}
if(!vconst(tp->t2)) {
fprintf(stderr, "Restrick hasn't done mult for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1) * eval(tp->t2);
tp->Czero = ~tp->Cone;
return;
case DIV:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done div for variable\n");
exits("error");;
}
if(!vconst(tp->t2)) {
fprintf(stderr, "Restrick hasn't done div for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1) / eval(tp->t2);
tp->Czero = ~tp->Cone;
return;
case MOD:
if(!vconst(tp->t1)) {
fprintf(stderr, "Restrick hasn't done mod for variable\n");
exits("error");;
}
if(!vconst(tp->t2)) {
fprintf(stderr, "Restrick hasn't done mod for variable\n");
exits("error");;
}
tp->Cone = eval(tp->t1) % eval(tp->t2);
tp->Czero = ~tp->Cone;
return;
case GT:
case LT:
case GE:
case LE:
Ceval(tp->t2);
Ceval(tp->t1);
for(i1 = 0; ; i1 = i1<<1 | 1)
if(((tp->t1->Czero | tp->t1->Cone | i1) == ~0)
&& ((tp->t2->Czero | tp->t2->Cone | i1) == ~0)) break;
i1 = ~i1;
switch(tp->code) {
case LT:
case LE:
tp->Cone = (tp->t1->Cone & i1) < (tp->t2->Cone & i1);
tp->Czero = (tp->t1->Cone & i1) > (tp->t2->Cone & i1);
break;
case GT:
case GE:
tp->Cone = (tp->t1->Cone & i1) > (tp->t2->Cone & i1);
tp->Czero = (tp->t1->Cone & i1) < (tp->t2->Cone & i1);
}
return;
case EQ:
Ceval(tp->t2);
Ceval(tp->t1);
if(ISCONST(tp->t1) && ISCONST(tp->t2)) {
tp->Cone = (tp->t1->Cone == tp->t2->Cone) ? 1 : 0;
tp->Czero = ~tp->Cone;
}
else {
i1 = (tp->t1->Cone | tp->t1->Czero)
& (tp->t2->Cone | tp->t2->Czero);
tp->Czero = (i1 & (tp->t1->Cone ^ tp->t2->Cone)) ?
~0 : ~1;
tp->Cone = 0;
}
return;
case NE:
Ceval(tp->t2);
Ceval(tp->t1);
if(ISCONST(tp->t1) && ISCONST(tp->t2)) {
tp->Cone = (tp->t1->Cone != tp->t2->Cone) ? 1 : 0;
tp->Czero = ~tp->Cone;
}
else {
tp->Czero = ~1;
i1 = (tp->t1->Cone | tp->t1->Czero)
& (tp->t2->Cone | tp->t2->Czero);
tp->Cone = (i1 & (tp->t1->Cone ^ tp->t2->Cone)) ?
1 : 0;
}
return;
case LS:
Ceval(tp->t2);
Ceval(tp->t1);
if(ISCONST(tp->t2)) {
tp->Cone = tp->t1->Cone << tp->t2->Cone;
tp->Czero = tp->t1->Czero << tp->t2->Cone;
i1 = ~0 << tp->t2->Cone;
tp->Czero |= ~i1;
return;
}
tp->Cone = tp->Czero = 0;
return;
case RS:
Ceval(tp->t2);
Ceval(tp->t1);
if(ISCONST(tp->t2)) {
tp->Cone = tp->t1->Cone >> tp->t2->Cone;
tp->Czero = tp->t1->Czero >> tp->t2->Cone;
i1 = ~0 >> tp->t2->Cone;
tp->Czero |= ~i1;
return;
}
tp->Cone = tp->Czero = 0;
return;
case CND:
Ceval(tp->t1);
Ceval(tp->t2->t1);
Ceval(tp->t2->t2);
if(ISCONST(tp->t1)) {
if (tp->t1->Cone) {
tp->Cone = tp->t2->t1->Cone;
tp->Czero = tp->t2->t1->Czero;
return;
}
tp->Cone = tp->t2->t2->Cone;
tp->Czero = tp->t2->t2->Czero;
return;
}
tp->Cone = tp->t2->t1->Cone & tp->t2->t2->Cone;
tp->Czero = tp->t2->t1->Czero & tp->t2->t2->Czero;
return;
case SWITCH:
{
int o, z;
if(vconst(tp)) {
tp->Cone = eval(tp);
tp->Czero = ~tp->Cone;
return;
}
Ceval(tp->t1);
tp0 = tp;
o = z = ~0;
for(tp = tp->t2; tp; tp = tp->t2) {
if(tp->code == ALT) {
if(tp->t1) {
Ceval(tp->t1);
continue;
}
tp = tp->t2;
if(tp == 0)
break;
if(tp->code != CASE)
break;
Ceval(tp->t1);
o &= tp->t1->Cone;
z &= tp->t1->Czero;
continue;
}
if(tp->code != CASE)
break;
Ceval(tp->t1);
o &= tp->t1->Cone;
z &= tp->t1->Czero;
}
tp0->Cone = o;
tp0->Czero = z;
return;
}
case EQN:
tp0 = ((Hshtab *) (tp->t1))->assign;
Ceval(tp0);
tp->Cone = tp0->Cone;
tp->Czero = tp0->Czero;
return;
case BOTH:
case INPUT:
tp->Czero = ~1;
tp->Cone = 0;
return;
case FIELD:
i1 = HI((Hshtab *) tp->t1) - LO((Hshtab *) tp->t1);
tp->Cone = 0;
tp->Czero = (i1 > 31) ? 0 : ( ~0 << i1);
return;
case NUMBER:
tp->Cone = (int) tp->t1;
tp->Czero = ~tp->Cone;
return;
default:
fprintf(stderr,"unknown Ceval op %d\n", tp->code);
exits("error");;
}
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;
}
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 */
