BSD 4_3 development

[unix-history] / usr / src / usr.bin / efl / dclgen.c

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

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

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

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


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

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

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

for(hp = hashtab ; hp<hashend ; ++hp)
       if( *hp && (q = (*hp)->varp) )
               if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
                   q->vclass!=CLARG && q!=procname &&
                   (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
                       z = z->nextp = 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 = p->nextp)
       {
       q = p->datap;
       p2stmt(0);
       first = 1;
       p2key(FEQUIVALENCE);
       p2str( "(" );
       for(i=0; i<NFTNTYPES; ++i)
               if(q->vbase[i])
                       {
                       if(first) first = 0;
                       else p2str( ", " );
                       p2str(ftnames[ q->vbase[i] ]);
                       p2str( "(1" );
                       if(q1 = q->vdim)
                               for(q1 = q1->datap; q1 ; q1 = 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(p->comname);
p2str("/ ");
first = 1;
for(q = p->comchain ; q; q = q->nextp)
       {
       if(first) first=0;
       else p2str(", ");
       prname(q->datap);
       }
dclchain(p->comchain, DOCOMMON);
}



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

switch(p->tag)
       {
       case TCONST:
               p2str(p->leftp);
               return;

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

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

       default:
               badtag("prname", 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 = pn->nextp)
       {
       p = pn->datap;
       if( (p->tag==TNAME || p->tag==TTEMP) && p->vext!=0)
               {
               if(nline%NAMESPERLINE == 0)
                       {
                       p2stmt(0);
                       p2key(FEXTERNAL);
                       }
               else    p2str(", ");
               ++nline;
               p2str(ftnames[p->vextbase]);
               }
       }


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

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