static char rcsid[] = "$Header:dclgen.c 12.0$";
#include "defs"

#define DOCOMMON 1
#define NOCOMMON 0

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 = ((struct chain *)p)->nextp)
	{
	sp = (char *)((struct chain *)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(((struct varblock *)procname)->vtype==TYSUBR || ((struct varblock *)procname)->vtype==TYUNDEFINED)
		p2key(FSUBROUTINE);
	else	{
		p2str(types[((struct varblock *)procname)->vtype]);
		p2key(FFUNCTION);
		}

	p2str(((struct stentry *)((struct varblock *)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 = ((struct chain *)p)->nextp)
		if( (q=(ptr)((struct varblock *)((struct chain *)p)->datap)->vextbase))
			{
			if(first) first = 0;
			else p2str(", ");
			p2str(ftnames[((struct varblock *)q)->vextbase]);
			}
		else	for(i=0 ; i<NFTNTYPES ; ++i)
				if(j = ((struct varblock *)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 = (chainp)& y;
for(hp = hashtab ; hp<hashend; ++hp)
	if( *hp && (q = ((struct stentry *)(*hp))->varp) )
		if(((struct headbits *)q)->tag==TNAME && ((struct varblock *)q)->vadjdim && q!=procname)
			z = (chainp)(((struct chain *)z)->nextp = (ptr)mkchain(q,CHNULL));

dclchain(y, NOCOMMON);
frchain(&y);

/* then declare the rest of the arguments */
z = (chainp)& y;
for(p = thisargs ; p ; p = ((struct chain *)p)->nextp)
	if(((struct varblock *)((struct chain *)p)->datap)->vadjdim == 0)
		z = (chainp)(((struct chain *)z)->nextp = (ptr)mkchain(((struct chain *)p)->datap,CHNULL));
dclchain(y, NOCOMMON);
frchain(&y);
frchain(&thisargs);


/* now put out declarations for common blocks */
for(p = (ptr)commonlist ; p ; p = ((struct chain *)p)->nextp)
	prcomm(((struct chain *)p)->datap);

TEST fprintf(diagfile, "\nend of common declarations");
z = (chainp)&y;

/* next the other variables that are in the symbol table */

for(hp = hashtab ; hp<hashend ; ++hp)
	if( *hp && (q = ((struct stentry *)(*hp))->varp) )
		if(((struct headbits *)q)->tag==TNAME && ((struct varblock *)q)->vadjdim==0 && ((struct varblock *)q)->vclass!=CLCOMMON &&
		    ((struct varblock *)q)->vclass!=CLARG && q!=procname &&
		    (tailor.dclintrinsics || ((struct exprblock *)q)->vproc!=PROCINTRINSIC) )
			z = (chainp)(((struct chain *)z)->nextp = (ptr)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 = ((struct chain *)p)->nextp)
	{
	q = ((struct chain *)p)->datap;
	p2stmt(0);
	first = 1;
	p2key(FEQUIVALENCE);
	p2str( "(" );
	for(i=0; i<NFTNTYPES; ++i)
		if(((struct varblock *)q)->vbase[i])
			{
			if(first) first = 0;
			else p2str( ", " );
			p2str(ftnames[ ((struct varblock *)q)->vbase[i] ]);
			p2str( "(1" );
			if(q1 = ((struct varblock *)q)->vdim)
				for(q1 = ((struct chain *)q1)->datap; q1 ; q1 = ((struct chain *)q1)->nextp)
					p2str( ",1" );
			p2str( ")" );
			}
	p2str( ")" );
	}
frchain(&genequivs);
}




prcomm(p)
register ptr p;
{
register int first;
register ptr q;

p2stmt(0);
p2key(FCOMMON);
p2str( "/" );
p2str(((struct comentry *)p)->comname);
p2str("/ ");
first = 1;
for(q = (ptr)((struct comentry *)p)->comchain ; q; q = ((struct chain *)q)->nextp)
	{
	if(first) first=0;
	else p2str(", ");
	prname(((struct chain *)q)->datap);
	}
dclchain(((struct comentry *)p)->comchain, DOCOMMON);
}



prname(p)
register ptr p;
{
register int i;

switch(((struct headbits *)p)->tag)
	{
	case TCONST:
		p2str(((struct exprblock *)p)->leftp);
		return;

	case TNAME:
		if( ! ((struct varblock *)p)->vdcldone )
			if(((struct headbits *)p)->blklevel == 1)
				dclit(p);
			else	mkftnp(p);
		for(i=0; i<NFTNTYPES ; ++i)
			if(((struct varblock *)p)->vbase[i])
				{
				p2str(ftnames[((struct varblock *)p)->vbase[i]]);
				return;
				}
		fatal1("prname: no fortran types for name %s",
			((struct stentry *)((struct varblock *)p)->sthead)->namep);

	case TFTNBLOCK:
		for(i=0; i<NFTNTYPES ; ++i)
			if(((struct varblock *)p)->vbase[i])
				{
				p2str(ftnames[((struct varblock *)p)->vbase[i]]);
				return;
				}
		return;

	default:
		badtag("prname", ((struct headbits *)p)->tag);
	}
}




dclchain(chp, okcom)
ptr chp;
int okcom;
{
extern char *ftntypes[];
register ptr pn, p;
register int i;
int first, nline;
ptr q,v;
int ntypes;
int size,align,mask;
int subval;

nline = 0;
for(pn = chp ; pn ; pn = ((struct dimblock *)pn)->nextp)
	{
	p = ((struct chain *)pn)->datap;
	if( (((struct headbits *)p)->tag==TNAME || ((struct headbits *)p)->tag==TTEMP) && ((struct varblock *)p)->vext!=0)
		{
		if(nline%NAMESPERLINE == 0)
			{
			p2stmt(0);
			p2key(FEXTERNAL);
			}
		else	p2str(", ");
		++nline;
		p2str(ftnames[((struct varblock *)p)->vextbase]);
		}
	}


for(pn = chp ; pn ; pn = ((struct chain *)pn)->nextp)
	{
	p = ((struct chain *)pn)->datap;
	if( (((struct headbits *)p)->tag==TNAME || ((struct headbits *)p)->tag==TTEMP) &&
	    ((struct varblock *)p)->vtype==TYSTRUCT && ((struct varblock *)p)->vclass!=CLARG)
		{
		ntypes = 0;
		for(i=0; i<NFTNTYPES; ++i)
			if(((struct varblock *)p)->vbase[i])
				++ntypes;
		if(ntypes > 1)
			genequivs = (ptr)mkchain(p, genequivs);
		}
	}

for(i=0; i<NFTNTYPES; ++i)
	{
	nline = 0;
	for(pn = chp; pn ; pn = ((struct chain *)pn)->nextp)
		{
		p = ((struct chain *)pn)->datap;
		if( (((struct headbits *)p)->tag==TNAME || ((struct headbits *)p)->tag==TTEMP) &&
		    ((struct varblock *)p)->vtype!=TYSUBR && ((struct varblock *)p)->vbase[i]!=0 &&
		    (okcom || ((struct varblock *)p)->vclass!=CLCOMMON) )
			{
			if(nline%NAMESPERLINE == 0)
				{
				p2stmt(0);
				p2str(ftntypes[i]);
				}
			else	p2str( ", " );
			++nline;
			p2str(ftnames[((struct varblock *)p)->vbase[i]]);
			first = -1;
		
			if(((struct varblock *)p)->vtype==TYCHAR || ((struct varblock *)p)->vtype==TYSTRUCT ||
			   (((struct varblock *)p)->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL))
				{
				p2str( "(" );
				sizalign(p, &size,&align,&mask);
				p2int( size/tailor.ftnsize[i] );
				first = 0;
				}
			else if(((struct varblock *)p)->vdim)
				{
				p2str( "(" );
				first = 1;
				}
			if(first >=0)
				{
				if(q = ((struct varblock *)p)->vdim)
				    for(q = ((struct chain *)q)->datap ; q ; q = ((struct chain *)q)->nextp)
					{
					if(((struct dimblock *)q)->upperb == 0)
						{
						((struct dimblock *)q)->upperb = mkint(1);
						if(((struct dimblock *)q)->lowerb)
							{
							frexpr(((struct dimblock *)q)->lowerb);
							((struct dimblock *)q)->lowerb = 0;
							}
						}
					else if(((struct dimblock *)q)->lowerb)
						{
						v = fold( mknode(TAROP,OPMINUS,
							mkint(1),cpexpr(((struct dimblock *)q)->lowerb)) );
						v = fold( mknode(TAROP,OPPLUS,
							cpexpr(((struct dimblock *)q)->upperb),v) );
						((struct dimblock *)q)->lowerb = 0;
						((struct dimblock *)q)->upperb = v;
						}
					if(first) first = 0;
					else p2str( ", " );
					v = ((struct dimblock *)q)->upperb = simple(RVAL,((struct dimblock *)q)->upperb);
					if( (((struct headbits *)v)->tag==TNAME && ((struct varblock *)v)->vclass==CLARG) ||
					    (isicon(v,&subval) && subval>0) )
						prname(v);
					else	dclerr("invalid array bound",
						((struct stentry *)((struct varblock *)p)->sthead)->namep);
					}
				p2str( ")" );
				}
			}
		}
	}
}
