void
enddcl(Void)
{
register struct Entrypoint *ep;
struct Entrypoint *ep0;
chainp cp;
extern char *err_proc;
static char comblks[] = "common blocks";
err_proc = comblks;
docommon();
/* Now the hash table entries for fields of common blocks have STGCOMMON,
vdcldone, voffset, and varno. And the common blocks themselves have
their full sizes in extleng. */
err_proc = "equivalences";
doequiv();
err_proc = comblks;
docomleng();
/* This implies that entry points in the declarations are buffered in
entries but not written out */
err_proc = "entries";
if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
/* entries could be 0 in case of an error */
do doentry(ep);
while(ep = ep->entnextp);
entries = (struct Entrypoint *)revchain((chainp)ep0);
}
err_proc = 0;
parstate = INEXEC;
p1put(P1_PROCODE);
freetemps();
if (earlylabs) {
for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
p1_label((long)cp->datap);
frchain(&earlylabs);
}
p1_line_number(lineno); /* for files that start with a MAIN program */
/* that starts with an executable statement */
}
static void
fix_entry_returns(Void) /* for multiple entry points */
{
Addrp a;
int i;
struct Entrypoint *e;
Namep np;
e = entries = (struct Entrypoint *)revchain((chainp)entries);
allargs = revchain(allargs);
if (!multitype)
return;
/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
for(i = TYINT1; i <= TYLOGICAL; i++)
if (a = xretslot[i])
sprintf(a->user.ident, "(*ret_val).%s",
postfix[i-TYINT1]);
do {
np = e->enamep;
switch(np->vtype) {
case TYINT1:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD
case TYQUAD:
#endif
case TYREAL:
case TYDREAL:
case TYCOMPLEX:
case TYDCOMPLEX:
case TYLOGICAL1:
case TYLOGICAL2:
case TYLOGICAL:
np->vstg = STGARG;
}
}
while(e = e->entnextp);
}
entrypt(int Class, int type, ftnint length, Extsym *entry, chainp args)
#endif
{
register Namep q;
register struct Entrypoint *p;
if(Class != CLENTRY)
puthead( procname = entry->cextname, Class);
else
fprintf(diagfile, " entry ");
fprintf(diagfile, " %s:\n", entry->fextname);
fflush(diagfile);
q = mkname(entry->fextname);
if (type == TYSUBR)
q->vstg = STGEXT;
type = lengtype(type, length);
if(Class == CLPROC)
{
procclass = CLPROC;
proctype = type;
procleng = type == TYCHAR ? length : 0;
}
p = ALLOC(Entrypoint);
p->entnextp = entries;
entries = p;
p->entryname = entry;
p->arglist = revchain(args);
p->enamep = q;
if(Class == CLENTRY)
{
Class = CLPROC;
if(proctype == TYSUBR)
type = TYSUBR;
}
q->vclass = Class;
q->vprocclass = 0;
settype(q, type, length);
q->vprocclass = PTHISPROC;
/* hold all initial entry points till end of declarations */
if(parstate >= INDATA)
doentry(p);
}
wr_common_decls(FILE *outfile)
#endif
{
Extsym *ext;
extern int extcomm;
static char *Extern[4] = {"", "Extern ", "extern "};
char *E, *E0 = Extern[extcomm];
int did_one = 0;
for (ext = extsymtab; ext < nextext; ext++) {
if (ext -> extstg == STGCOMMON && ext->allextp) {
chainp comm;
int count = 1;
int which; /* which display to use;
ONE_STRUCT, UNION or INIT */
if (!did_one)
nice_printf (outfile, "/* Common Block Declarations */\n\n");
pad_common(ext);
/* Construct the proper, condensed list of structs; eliminate duplicates
from the initial list ext -> allextp */
comm = ext->allextp = revchain(ext->allextp);
if (ext -> extinit)
which = INIT_STRUCT;
else if (comm->nextp) {
which = UNION_STRUCT;
nice_printf (outfile, "%sunion {\n", E0);
next_tab (outfile);
E = "";
}
else {
which = ONE_STRUCT;
E = E0;
}
for (; comm; comm = comm -> nextp, count++) {
if (which == INIT_STRUCT)
nice_printf (outfile, "struct %s%d_ {\n",
ext->cextname, count);
else
nice_printf (outfile, "%sstruct {\n", E);
next_tab (c_file);
wr_struct (outfile, (chainp) comm -> datap);
prev_tab (c_file);
if (which == UNION_STRUCT)
nice_printf (outfile, "} _%d;\n", count);
else if (which == ONE_STRUCT)
nice_printf (outfile, "} %s;\n", ext->cextname);
else
nice_printf (outfile, "};\n");
} /* for */
if (which == UNION_STRUCT) {
prev_tab (c_file);
nice_printf (outfile, "} %s;\n", ext->cextname);
} /* if */
did_one = 1;
nice_printf (outfile, "\n");
for (count = 1, comm = ext -> allextp; comm;
comm = comm -> nextp, count++) {
def_start(outfile, ext->cextname,
comm_union_name(count), "");
switch (which) {
case ONE_STRUCT:
extern_out (outfile, ext);
break;
case UNION_STRUCT:
nice_printf (outfile, "(");
extern_out (outfile, ext);
nice_printf(outfile, "._%d)", count);
break;
case INIT_STRUCT:
nice_printf (outfile, "(*(struct ");
extern_out (outfile, ext);
nice_printf (outfile, "%d_ *) &", count);
extern_out (outfile, ext);
nice_printf (outfile, ")");
break;
} /* switch */
nice_printf (outfile, "\n");
} /* for count = 1, comm = ext -> allextp */
nice_printf (outfile, "\n");
} /* if ext -> extstg == STGCOMMON */
} /* for ext = extsymtab */
} /* wr_common_decls */
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 */
