V10/cmd/f77/data.c

#include "defs"

/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */

static char datafmt[] = "%s\t%05ld\t%05ld\t%d" ;

/* another initializer, called from parser */
dataval(repp, valp)
register expptr repp, valp;
{
	int i, nrep;
	ftnint elen, vlen;
	register Addrp p;
	Addrp nextdata();

	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) )
	{
		err("non-constant initializer");
		goto ret;
	}

	if(toomanyinit) goto ret;
	for(i = 0 ; i < nrep ; ++i)
	{
		p = nextdata(&elen, &vlen);
		if(p == NULL)
		{
			err("too many initializers");
			toomanyinit = YES;
			goto ret;
		}
		setdata(p, valp, elen, vlen);
		frexpr(p);
	}

ret:
	frexpr(valp);
}


Addrp nextdata(elenp, vlenp)
ftnint *elenp, *vlenp;
{
	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;

	while(curdtp)
	{
		p = 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(ip->varvp);
			ip->isactive = NO;
			curdtp = curdtp->nextp;
			goto next;
		}

		pp = (struct Primblock *) p;
		np = pp->namep;
		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( cpexpr(pp) );
		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 == STGCOMMON)
			*vlenp = extsymtab[np->vardesc.varno].maxleng;
		else if(np->vstg == STGEQUIV)
			*vlenp = eqvclass[np->vardesc.varno].eqvleng;
		else	{
			*vlenp =  (np->vtype==TYCHAR ?
			    np->vleng->constblock.Const.ci :
			    typesize[np->vtype]);
			if(np->vstg==STGBSS && *vlenp>0)
				np->vstg = STGINIT;
			if(np->vdim)
				*vlenp *= np->vdim->nelt->constblock.Const.ci;
		}
		return( (Addrp) q );

doerr:
		err("nonconstant implied DO parameter");
		frexpr(q);
		curdtp = curdtp->nextp;

next:	
		curdtelt = 0;
	}

	return(NULL);
}






setdata(varp, valp, elen, vlen)
register Addrp varp;
ftnint elen, vlen;
register Constp valp;
{
	union Constant con;
	register int type;
	int i, k, valtype;
	ftnint offset;
	char *dataname(), *varname;

	varname = dataname(varp->vstg, varp->memno);
	offset = varp->memoffset->constblock.Const.ci;
	type = varp->vtype;
	valtype = valp->vtype;
	if(type!=TYCHAR && valtype==TYCHAR)
	{
		if(! ftn66flag)
			warn("non-character datum initialized with character string");
		varp->vleng = ICON(typesize[type]);
		varp->vtype = type = TYCHAR;
	}
	else if( (type==TYCHAR && valtype!=TYCHAR) ||
	    (cktype(OPASSIGN,type,valtype) == TYERROR) )
	{
		err("incompatible types in initialization");
		return;
	}
	if(type == TYADDR)
		con.ci = valp->Const.ci;
	else if(type != TYCHAR)
	{
		if(valtype == TYUNKNOWN)
			con.ci = valp->Const.ci;
		else	consconv(type, &con, valtype, &valp->Const);
	}

	k = 1;
	switch(type)
	{
	case TYLOGICAL:
		type = tylogical;
	case TYSHORT:
	case TYLONG:
		dataline(varname, offset, vlen, type);
		prconi(initfile, type, con.ci);
		break;

	case TYADDR:
		dataline(varname, offset, vlen, type);
		prcona(initfile, con.ci);
		break;

	case TYCOMPLEX:
		k = 2;
		type = TYREAL;
	case TYREAL:
		goto flpt;

	case TYDCOMPLEX:
		k = 2;
		type = TYDREAL;
	case TYDREAL:
flpt:

		for(i = 0 ; i < k ; ++i)
		{
			dataline(varname, offset, vlen, type);
			prconr(initfile, type, con.cd[i]);
			offset += typesize[type];
		}
		break;

	case TYCHAR:
		k = valp->vleng->constblock.Const.ci;
		if(elen < k)
			k = elen;

		for(i = 0 ; i < k ; ++i)
		{
			dataline(varname, offset++, vlen, TYCHAR);
			fprintf(initfile, "\t%d\n",
			    valp->Const.ccp[i]);
		}
		k = elen - valp->vleng->constblock.Const.ci;
		if(k > 0)
		{
			dataline(varname, offset, vlen, TYBLANK);
			fprintf(initfile, "\t%d\n", k);
			offset += k;
		}
		break;

	default:
		badtype("setdata", type);
	}

}



/*
   output form of name is padded with blanks and preceded
   with a storage class digit
*/
char *dataname(stg,memno)
int stg, memno;
{
	static char varname[XL+2];
	register char *s, *t;
	char *memname();

	varname[0] = (stg==STGCOMMON ? '2' : (stg==STGEQUIV ? '1' : '0') );
	s = memname(stg, memno);
	for(t = varname+1 ; *s ; )
		*t++ = *s++;
	while(t < varname+XL+1)
		*t++ = ' ';
	varname[XL+1] = '\0';
	return(varname);
}





frdata(p0)
chainp p0;
{
	register struct Chain *p;
	register tagptr q;

	for(p = p0 ; p ; p = p->nextp)
	{
		q = 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);
}



dataline(varname, offset, vlen, type)
char *varname;
ftnint offset, vlen;
int type;
{
	fprintf(initfile, datafmt, varname, offset, vlen, type);
}


 void
make_param(p, e)
 register struct Paramblock *p;
 expptr e;
{
	p->vclass = CLPARAM;
	impldcl(p);
	if (p->vtype != ((Constp)e)->vtype && bugwarn & 1)
		warnb1("old f77 typed parameter %s incorrectly",
			varstr(VL, p->varname));
	p->paramval = (bugwarn & 2) ? e : mkconv(p->vtype, e);
	}