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

impldecl(p)
register ptr p;
{
extern char *types[];
register ptr q;
int n;

if(((struct varblock *)p)->vtype==TYSUBR) return;
if(((struct headbits *)p)->tag == TCALL)
	{
	impldecl(((struct exprblock *)p)->leftp);
	((struct varblock *)p)->vtype = ((struct varblock *)((struct exprblock *)p)->leftp)->vtype;
	((struct varblock *)p)->vtypep = ((struct varblock *)((struct exprblock *)p)->leftp)->vtypep;
	return;
	}

if(inbound)
	n = TYINT;
else	{
	n = impltype[((struct stentry *)((struct varblock *)p)->sthead)->namep[0] - 'a' ];
	if(n==TYREAL && ((struct varblock *)p)->vprec!=0)
		n = TYLREAL;
	sprintf(msg,  "%s implicitly typed %s",((struct stentry *)((struct varblock *)p)->sthead)->namep, types[n]);
	warn(msg);
	}
q = ((struct stentry *)((struct varblock *)p)->sthead)->varp;
((struct varblock *)p)->vtype = ((struct varblock *)q)->vtype = n;
if(((struct headbits *)p)->blklevel>1 && ((struct varblock *)p)->vdclstart==0)
	{
	((struct headbits *)p)->blklevel = ((struct headbits *)q)->blklevel = ((struct headbits *)((struct varblock *)p)->sthead)->blklevel = 1;
	((struct varblock *)p)->vdclstart = ((struct varblock *)q)->vdclstart = 1;
	--ndecl[blklevel];
	++ndecl[1];
	}
}



extname(p)
register ptr p;
{
register int i;
register char *q, *s;

/*	if(((struct varblock *)p)->vclass == CLARG) return;	*/
if(((struct varblock *)p)->vextbase) return;
q = ((struct stentry *)((struct varblock *)p)->sthead)->namep;
setvproc(p, PROCYES);

/* external names are automatically at block level 1 */

if( (i =((struct headbits *)p)->blklevel) >1)
	{
	((struct headbits *)((struct varblock *)p)->sthead)->blklevel = 1;
	((struct headbits *)p)->blklevel = 1;
	((struct headbits *)((struct stentry *)((struct varblock *)p)->sthead)->varp)->blklevel = 1;
	++ndecl[1];
	--ndecl[i];
	}

if(((struct varblock *)p)->vclass!=CLUNDEFINED && ((struct varblock *)p)->vclass!=CLARG)
	{
	dclerr("illegal class for procedure", q);
	return;
	}
if(((struct varblock *)p)->vclass!=CLARG && strlen(q)>XL)
	{
	if(! ioop(q) )
		dclerr("procedure name too long", q);
	return;
	}
if(lookftn(q) > 0)
	dclerr("procedure name already used", q);
else	{
	for(i=0 ; i<NFTNTYPES ; ++i)
		if(((struct varblock *)p)->vbase[i]) break;
	if(i < NFTNTYPES)
		((struct varblock *)p)->vextbase = ((struct varblock *)p)->vbase[i];
	else	((struct varblock *)p)->vextbase = nxtftn();

	if(((struct varblock *)p)->vext==0 || ((struct varblock *)p)->vclass!=CLARG)
		for(s = ftnames[ ((struct varblock *)p)->vextbase ]; *s++ = *q++ ; ) ; 
	return;
	}
}



dclit(p)
register ptr p;
{
register ptr q;

if(((struct headbits *)p)->tag == TERROR)
	return;

q = ((struct stentry *)((struct varblock *)p)->sthead)->varp;

if(((struct headbits *)p)->tag == TCALL)
	{
	dclit(((struct exprblock *)p)->leftp);
	if( ioop(((struct stentry *)((struct varblock *)((struct exprblock *)p)->leftp)->sthead)->namep) )
		((struct varblock *)((struct exprblock *)p)->leftp)->vtype = TYLOG;
	((struct varblock *)p)->vtype = ((struct varblock *)((struct exprblock *)p)->leftp)->vtype;
	((struct varblock *)p)->vtypep = ((struct varblock *)((struct exprblock *)p)->leftp)->vtypep;
	return;
	}

if(((struct varblock *)q)->vdcldone == 0)
	mkftnp(q);
if(p != q)
	cpblock(q,p, sizeof(struct exprblock));
}


mkftnp(p)
register ptr p;
{
int i,k;
if(inbound || ((struct varblock *)p)->vdcldone) return;
if(p == 0)
	fatal("mkftnp: zero argument");
if(((struct headbits *)p)->tag!=TNAME && ((struct headbits *)p)->tag!=TTEMP)
	badtag("mkftnp", ((struct headbits *)p)->tag);

if(((struct varblock *)p)->vtype == TYUNDEFINED)
	if(((struct varblock *)p)->vextbase)
		return;
	else	impldecl(p);
((struct varblock *)p)->vdcldone = 1;

switch(((struct varblock *)p)->vtype)
	{
	case TYCHAR:
	case TYINT:
	case TYREAL:
	case TYLREAL:
	case TYLOG:
	case TYCOMPLEX:
	case TYLCOMPLEX:
		((struct varblock *)p)->vbase[ eflftn[((struct varblock *)p)->vtype] ] = nxtftn();
		break;

	case TYSTRUCT:
		k = ((struct typeblock *)((struct varblock *)p)->vtypep)->basetypes;
		for(i=0; i<NFTNTYPES ; ++i)
			if(k & ftnmask[i])
				((struct varblock *)p)->vbase[i] = nxtftn();
		break;

	case TYSUBR:
		break;

	default:
		fatal1("invalid type for %s", ((struct stentry *)((struct varblock *)p)->sthead)->namep);
		break;
	}
}


namegen()
{
register ptr p;
register struct stentry **hp;
register int i;

for(hp = hashtab ; hp<hashend ; ++hp)
	if(*hp && (p = (*hp)->varp) )
		if(((struct headbits *)p)->tag == TNAME)
			mkft(p);

for(p = (ptr)gonelist ; p ; p = ((struct chain *)p)->nextp)
	mkft(((struct chain *)p)->datap);

for(p = (ptr)hidlist ; p ; p = ((struct chain *)p)->nextp)
	if(((struct headbits *)((struct chain *)p)->datap)->tag == TNAME)  mkft(((struct chain *)p)->datap);

for(p = (ptr)tempvarlist ; p ; p = ((struct chain *)p)->nextp)
	mkft(((struct chain *)p)->datap);

TEST fprintf(diagfile, "Fortran names:\n");
TEST for(i=1; i<=nftnames ; ++i)  fprintf(diagfile, "%s\n", ftnames[i]);
}


mkft(p)
register ptr p;
{
int i;
register char *s, *t;

if(((struct varblock *)p)->vnamedone)
	return;

if(((struct varblock *)p)->vdcldone==0 && p!=procname)
	{
	if(((struct varblock *)p)->vext && ((struct varblock *)p)->vtype==TYUNDEFINED)
		((struct varblock *)p)->vtype = TYSUBR;
	else if(((struct varblock *)p)->vextbase==0 && ((struct varblock *)p)->vadjdim==0 && ((struct varblock *)p)->vclass!=CLCOMMON)
		warn1("%s never used", ((struct stentry *)((struct varblock *)p)->sthead)->namep);
	mkftnp(p);
	}

if(((struct varblock *)p)->vextbase)
	mkftname(((struct varblock *)p)->vextbase, ((struct stentry *)((struct varblock *)p)->sthead)->namep);

for(i=0; i<NFTNTYPES ; ++i)
	if(((struct varblock *)p)->vbase[i] != 0)
	if(p!=procname && ((struct varblock *)p)->vextbase!=0)
		{
		s = ftnames[((struct varblock *)p)->vextbase];
		t = ftnames[((struct varblock *)p)->vbase[i]];
		while(*t++ = *s++ )
			;
		}
	else if(((struct varblock *)p)->sthead)
		mkftname(((struct varblock *)p)->vbase[i], ((struct stentry *)((struct varblock *)p)->sthead)->namep);
	else
		mkftname(((struct varblock *)p)->vbase[i], CHNULL);
((struct varblock *)p)->vnamedone = 1;
}





mkftname(n,s)
int n;
char *s;
{
int i, j;
register int k;
char fn[7];
register char *c1, *c2;

if(ftnames[n][0] != '\0')  return;

if(s==0 || *s=='\0')
	s = "temp";
else if(*s == '_')
	++s;
k = strlen(s);

for(i=0; i<k && i<(XL/2) ; ++i)
	fn[i] = s[i];
if(k > XL)
	{
	s += (k-XL);
	k = XL;
	}

for( ; i<k ; ++i)
	fn[i] = s[i];
fn[i] = '\0';

if( lookftn(fn) )
	{
	if(k < XL)
		++k;
	fn[k] = '\0';
	c1 = fn + k-1;
	for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
		if(lookftn(fn) == 0)
			goto nameok;

	if(k < XL)
		++k;
	fn[k] = '\0';
	c1 = fn + k-2;
	c2 = c1 + 1;

	for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
		for(*c2 = '0' ; *c2 <= '9' ; *c2 += 1)
			if(lookftn(fn) == 0)
				goto nameok;
	fatal1("mkftname: cannot generate fortran name for %s", s);
	}

nameok:
for(j=0; j<=k ; ++j)
	ftnames[n][j] = fn[j];
}



nxtftn()
{
if( ++nftnames < MAXFTNAMES)
	{
	ftnames[nftnames][0] = '\0';
	return(nftnames);
	}

fatal("too many Fortran names generated");
/* NOTREACHED */
}



lookftn(s)
char *s;
{
register int i;

for(i=1 ; i<=nftnames ; ++i)
	if(equals(ftnames[i],s))  return(i);
return(0);
}



ptr mkftnblock(type, name)
int type;
char *name;
{
register struct varblock *p;
register int k;

p = (struct varblock *)allexpblock();
((struct headbits *)p)->tag = TFTNBLOCK;
((struct varblock *)p)->vtype = type;
((struct varblock *)p)->vdcldone = 1;

if( (k = lookftn(name)) == 0)
	{
	k = nxtftn();
	strcpy(ftnames[k], name);
	}
((struct varblock *)p)->vbase[ eflftn[type] ] = k;
((struct varblock *)p)->vextbase = k;
return((ptr)p);
}
