def_start(FILE *outfile, char *s1, char *s2, char *post)
#endif
{
defines *d;
int n, n1;
extern int in_define;
n = n1 = strlen(s1);
if (s2)
n += strlen(s2);
d = (defines *)mem(sizeof(defines)+n, 1);
d->next = define_list;
define_list = d;
strcpy(d->defname, s1);
if (s2)
strcpy(d->defname + n1, s2);
in_define = 1;
nice_printf(outfile, "#define %s", d->defname);
if (post)
nice_printf(outfile, " %s", post);
}
wr_abbrevs(FILE *outfile, int function_head, chainp vars)
#endif
{
for (; vars; vars = vars -> nextp) {
Namep name = (Namep) vars -> datap;
if (!name->visused)
continue;
if (function_head)
nice_printf (outfile, "#define ");
else
nice_printf (outfile, "#undef ");
out_name (outfile, name);
if (function_head) {
Extsym *comm = &extsymtab[name -> vardesc.varno];
nice_printf (outfile, " (");
extern_out (outfile, comm);
nice_printf (outfile, "%d.", comm->curno);
nice_printf (outfile, "%s)", name->cvarname);
} /* if function_head */
nice_printf (outfile, "\n");
} /* for */
} /* wr_abbrevs */
wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp)
#endif
{
int eltcount = 0;
if (addrp == (struct Addrblock *) NULL)
return;
if (addrp -> isarray) {
frexpr (addrp -> memoffset);
addrp -> memoffset = ICON(0);
eltcount = addrp -> ntempelt;
addrp -> ntempelt = 0;
addrp -> isarray = 0;
} /* if */
out_addr (outfile, addrp);
if (eltcount)
nice_printf (outfile, "[%d]", eltcount);
} /* wr_nv_ident_help */
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 */
wr_globals(FILE *outfile)
#endif
{
struct Literal *litp, *lastlit;
extern int hsize;
char *litname;
int did_one, t;
struct Constblock cb;
ftnint x, y;
if (nliterals == 0)
return;
lastlit = litpool + nliterals;
did_one = 0;
for (litp = litpool; litp < lastlit; litp++) {
if (!litp->lituse)
continue;
litname = lit_name(litp);
if (!did_one) {
margin_printf(outfile, "/* Table of constant values */\n\n");
did_one = 1;
}
cb.vtype = litp->littype;
if (litp->littype == TYCHAR) {
x = litp->litval.litival2[0] + litp->litval.litival2[1];
if (y = x % hsize)
x += y = hsize - y;
nice_printf(outfile,
"static struct { %s fill; char val[%ld+1];", halign, x);
nice_printf(outfile, " char fill2[%ld];", hsize - 1);
nice_printf(outfile, " } %s_st = { 0,", litname);
cb.vleng = ICON(litp->litval.litival2[0]);
cb.Const.ccp = litp->cds[0];
cb.Const.ccp1.blanks = litp->litval.litival2[1] + y;
cb.vtype = TYCHAR;
out_const(outfile, &cb);
frexpr(cb.vleng);
nice_printf(outfile, " };\n");
nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
continue;
}
nice_printf(outfile, "static %s %s = ",
c_type_decl(litp->littype,0), litname);
t = litp->littype;
if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
cb.vstg = 1;
cb.Const.cds[0] = litp->cds[0];
cb.Const.cds[1] = litp->cds[1];
}
else {
memcpy((char *)&cb.Const, (char *)&litp->litval,
sizeof(cb.Const));
cb.vstg = 0;
}
out_const(outfile, &cb);
nice_printf (outfile, ";\n");
} /* for */
if (did_one)
nice_printf (outfile, "\n");
} /* wr_globals */
putentries(FILE *outfile)
#endif
/* put out wrappers for multiple entries */
{
char base[IDENT_LEN];
struct Entrypoint *e;
Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
chainp args, lengths;
int i, k, mt, nL, type;
extern char *dfltarg[], **dfltproc;
e = entries;
if (!e->enamep) /* only possible with erroneous input */
return;
nL = (nallargs + nallchargs) * sizeof(Namep *);
A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
Ae = A + nallargs;
Alp = (Namep **)(Ae1 = Ae + nallchargs);
i = k = 0;
for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
np = (Namep)args->datap;
if (np->vtype == TYCHAR && np->vclass != CLPROC)
*a1 = &Ae[i++];
}
mt = multitype;
multitype = 0;
sprintf(base, "%s0_", e->enamep->cvarname);
do {
np = e->enamep;
lengths = length_comp(e, 0);
proctype = type = np->vtype;
if (protofile)
protowrite(protofile, type, np->cvarname, e, lengths);
nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
nice_printf(outfile, "%s", np->cvarname);
if (!Ansi) {
listargs(outfile, e, 0, lengths);
nice_printf(outfile, "\n");
}
list_arg_types(outfile, e, lengths, 0, "\n");
nice_printf(outfile, "{\n");
frchain(&lengths);
next_tab(outfile);
if (mt)
nice_printf(outfile,
"Multitype ret_val;\n%s(%d, &ret_val",
base, k); /*)*/
else if (ISCOMPLEX(type))
nice_printf(outfile, "%s(%d,%s", base, k,
xretslot[type]->user.ident); /*)*/
else if (type == TYCHAR)
nice_printf(outfile,
"%s(%d, ret_val, ret_val_len", base, k); /*)*/
else
nice_printf(outfile, "return %s(%d", base, k); /*)*/
k++;
memset((char *)A, 0, nL);
for(args = e->arglist; args; args = args->nextp) {
np = (Namep)args->datap;
A[np->argno] = np;
if (np->vtype == TYCHAR && np->vclass != CLPROC)
*Alp[np->argno] = np;
}
args = allargs;
for(a = A; a < Ae; a++, args = args->nextp)
nice_printf(outfile, ", %s", (np = *a)
? np->cvarname
: ((Namep)args->datap)->vclass == CLPROC
? dfltproc[((Namep)args->datap)->vtype]
: dfltarg[((Namep)args->datap)->vtype]);
for(; a < Ae1; a++)
if (np = *a)
nice_printf(outfile, ", %s_len", np->fvarname);
else
nice_printf(outfile, ", (ftnint)0");
nice_printf(outfile, /*(*/ ");\n");
if (mt) {
if (type == TYCOMPLEX)
nice_printf(outfile,
"r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
else if (type == TYDCOMPLEX)
nice_printf(outfile,
"r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
else if (type <= TYLOGICAL)
nice_printf(outfile, "return ret_val.%s;\n",
postfix[type-TYINT1]);
}
nice_printf(outfile, "}\n");
prev_tab(outfile);
}
while(e = e->entnextp);
free((char *)A);
}
prolog(FILE *outfile, register chainp p)
#endif
{
int addif, addif0, i, nd;
ftnint size;
int *ac;
register Namep q;
register struct Dimblock *dp;
chainp p0, p1;
if(procclass == CLBLOCK)
return;
p0 = p;
p1 = p = argsort(p);
wrote_comment = 0;
comment_file = outfile;
ac = 0;
/* Compute the base addresses and offsets for the array parameters, and
assign these values to local variables */
addif = addif0 = nentry > 1;
for(; p ; p = p->nextp)
{
q = (Namep) p->datap;
if(dp = q->vdim) /* if this param is an array ... */
{
expptr Q, expr;
/* See whether to protect the following with an if. */
/* This only happens when there are multiple entries. */
nd = dp->ndim - 1;
if (addif0) {
if (!ac)
ac = count_args();
if (ac[q->argno] == nentry)
addif = 0;
else if (dp->basexpr
|| dp->baseoffset->constblock.Const.ci)
addif = 1;
else for(addif = i = 0; i <= nd; i++)
if (dp->dims[i].dimexpr
&& (i < nd || !q->vlastdim)) {
addif = 1;
break;
}
if (addif) {
write_comment();
nice_printf(outfile, "if (%s) {\n", /*}*/
q->cvarname);
next_tab(outfile);
}
}
for(i = 0 ; i <= nd; ++i)
/* Store the variable length of each dimension (which is fixed upon
runtime procedure entry) into a local variable */
if ((Q = dp->dims[i].dimexpr)
&& (i < nd || !q->vlastdim)) {
expr = (expptr)cpexpr(Q);
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
fixtype(cpexpr(dp->dims[i].dimsize)), expr));
} /* if dp -> dims[i].dimexpr */
/* size will equal the size of a single element, or -1 if the type is
variable length character type */
size = typesize[ q->vtype ];
if(q->vtype == TYCHAR)
if( ISICON(q->vleng) )
size *= q->vleng->constblock.Const.ci;
else
size = -1;
/* Fudge the argument pointers for arrays so subscripts
* are 0-based. Not done if array bounds are being checked.
*/
if(dp->basexpr) {
/* Compute the base offset for this procedure */
write_comment();
out_and_free_statement (outfile, mkexpr (OPASSIGN,
cpexpr(fixtype(dp->baseoffset)),
cpexpr(fixtype(dp->basexpr))));
} /* if dp -> basexpr */
if(! checksubs) {
if(dp->basexpr) {
expptr tp;
/* If the base of this array has a variable adjustment ... */
tp = (expptr) cpexpr (dp -> baseoffset);
if(size < 0 || q -> vtype == TYCHAR)
tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
write_comment();
tp = mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv(TYINT, fixtype
(fixtype (tp))));
/* Avoid type clash by removing the type conversion */
tp = prune_left_conv (tp);
out_and_free_statement (outfile, tp);
} else if(dp->baseoffset->constblock.Const.ci != 0) {
/* if the base of this array has a nonzero constant adjustment ... */
expptr tp;
write_comment();
if(size > 0 && q -> vtype != TYCHAR) {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(cpexpr (dp->baseoffset)))));
out_and_free_statement (outfile, tp);
} else {
tp = prune_left_conv (mkexpr (OPMINUSEQ,
mkconv (TYADDR, (expptr)p->datap),
mkconv (TYINT, fixtype
(mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
cpexpr (q -> vleng))))));
out_and_free_statement (outfile, tp);
} /* else */
} /* if dp -> baseoffset -> const */
} /* if !checksubs */
if (addif) {
nice_printf(outfile, /*{*/ "}\n");
prev_tab(outfile);
}
}
}
if (wrote_comment)
nice_printf (outfile, "\n/* Function Body */\n");
if (ac)
free((char *)ac);
if (p0 != p1)
frchain(&p1);
} /* prolog */
