wr_struct(FILE *outfile, chainp var_list)
#endif
{
int last_type = -1;
int did_one = 0;
chainp this_var;
for (this_var = var_list; this_var; this_var = this_var -> nextp) {
Namep var = (Namep) this_var -> datap;
int type;
char *comment = NULL;
if (var == (Namep) NULL)
err ("wr_struct: null variable");
else if (var -> tag != TNAME)
erri ("wr_struct: bad tag on variable '%d'",
var -> tag);
type = var -> vtype;
if (last_type == type && did_one)
nice_printf (outfile, ", ");
else {
if (did_one)
nice_printf (outfile, ";\n");
nice_printf (outfile, "%s ",
c_type_decl (type, var -> vclass == CLPROC));
} /* else */
/* Character type is really a string type. Put out a '*' for parameters
with unknown length and functions returning character */
if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
|| var -> vclass == CLPROC))
nice_printf (outfile, "*");
var -> vstg = STGAUTO;
out_name (outfile, var);
if (var -> vclass == CLPROC)
nice_printf (outfile, "()");
else if (var -> vdim)
comment = wr_ardecls(outfile, var->vdim,
var->vtype == TYCHAR && ISICON(var->vleng)
? var->vleng->constblock.Const.ci : 1L);
else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
ISICON ((var -> vleng)))
nice_printf (outfile, "[%ld]",
var -> vleng -> constblock.Const.ci);
if (comment)
nice_printf (outfile, "%s", comment);
did_one = 1;
last_type = type;
} /* for this_var */
if (did_one)
nice_printf (outfile, ";\n");
} /* wr_struct */
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);
}
