743 lines
20 KiB
C
743 lines
20 KiB
C
/****************************************************************
|
|
Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
|
|
|
|
Permission to use, copy, modify, and distribute this software
|
|
and its documentation for any purpose and without fee is hereby
|
|
granted, provided that the above copyright notice appear in all
|
|
copies and that both that the copyright notice and this
|
|
permission notice and warranty disclaimer appear in supporting
|
|
documentation, and that the names of AT&T Bell Laboratories or
|
|
Bellcore or any of their entities not be used in advertising or
|
|
publicity pertaining to distribution of the software without
|
|
specific, written prior permission.
|
|
|
|
AT&T and Bellcore disclaim all warranties with regard to this
|
|
software, including all implied warranties of merchantability
|
|
and fitness. In no event shall AT&T or Bellcore be liable for
|
|
any special, indirect or consequential damages or any damages
|
|
whatsoever resulting from loss of use, data or profits, whether
|
|
in an action of contract, negligence or other tortious action,
|
|
arising out of or in connection with the use or performance of
|
|
this software.
|
|
****************************************************************/
|
|
|
|
#include "defs.h"
|
|
#include "output.h"
|
|
#include "names.h"
|
|
#include "iob.h"
|
|
|
|
|
|
/* Names generated by the translator are guaranteed to be unique from the
|
|
Fortan names because Fortran does not allow underscores in identifiers,
|
|
and all of the system generated names do have underscores. The various
|
|
naming conventions are outlined below:
|
|
|
|
FORMAT APPLICATION
|
|
----------------------------------------------------------------------
|
|
io_# temporaries generated by IO calls; these will
|
|
contain the device number (e.g. 5, 6, 0)
|
|
ret_val function return value, required for complex and
|
|
character functions.
|
|
ret_val_len length of the return value in character functions
|
|
|
|
ssss_len length of character argument "ssss"
|
|
|
|
c_# member of the literal pool, where # is an
|
|
arbitrary label assigned by the system
|
|
cs_# short integer constant in the literal pool
|
|
t_# expression temporary, # is the depth of arguments
|
|
on the stack.
|
|
L# label "#", given by user in the Fortran program.
|
|
This is unique because Fortran labels are numeric
|
|
pad_# label on an init field required for alignment
|
|
xxx_init label on a common block union, if a block data
|
|
requires a separate declaration
|
|
*/
|
|
|
|
/* generate variable references */
|
|
|
|
char *c_type_decl (type, is_extern)
|
|
int type, is_extern;
|
|
{
|
|
static char buff[100];
|
|
|
|
switch (type) {
|
|
case TYREAL: if (!is_extern || !forcedouble)
|
|
{ strcpy (buff, "real");break; }
|
|
case TYDREAL: strcpy (buff, "doublereal"); break;
|
|
case TYCOMPLEX: if (is_extern)
|
|
strcpy (buff, "/* Complex */ VOID");
|
|
else
|
|
strcpy (buff, "complex");
|
|
break;
|
|
case TYDCOMPLEX:if (is_extern)
|
|
strcpy (buff, "/* Double Complex */ VOID");
|
|
else
|
|
strcpy (buff, "doublecomplex");
|
|
break;
|
|
case TYADDR:
|
|
case TYINT1:
|
|
case TYSHORT:
|
|
case TYLONG:
|
|
#ifdef TYQUAD
|
|
case TYQUAD:
|
|
#endif
|
|
case TYLOGICAL1:
|
|
case TYLOGICAL2:
|
|
case TYLOGICAL: strcpy(buff, typename[type]);
|
|
break;
|
|
case TYCHAR: if (is_extern)
|
|
strcpy (buff, "/* Character */ VOID");
|
|
else
|
|
strcpy (buff, "char");
|
|
break;
|
|
|
|
case TYUNKNOWN: strcpy (buff, "UNKNOWN");
|
|
|
|
/* If a procedure's type is unknown, assume it's a subroutine */
|
|
|
|
if (!is_extern)
|
|
break;
|
|
|
|
/* Subroutines must return an INT, because they might return a label
|
|
value. Even if one doesn't, the caller will EXPECT it to. */
|
|
|
|
case TYSUBR: strcpy (buff, "/* Subroutine */ int");
|
|
break;
|
|
case TYERROR: strcpy (buff, "ERROR"); break;
|
|
case TYVOID: strcpy (buff, "void"); break;
|
|
case TYCILIST: strcpy (buff, "cilist"); break;
|
|
case TYICILIST: strcpy (buff, "icilist"); break;
|
|
case TYOLIST: strcpy (buff, "olist"); break;
|
|
case TYCLLIST: strcpy (buff, "cllist"); break;
|
|
case TYALIST: strcpy (buff, "alist"); break;
|
|
case TYINLIST: strcpy (buff, "inlist"); break;
|
|
case TYFTNLEN: strcpy (buff, "ftnlen"); break;
|
|
default: sprintf (buff, "BAD DECL '%d'", type);
|
|
break;
|
|
} /* switch */
|
|
|
|
return buff;
|
|
} /* c_type_decl */
|
|
|
|
|
|
char *new_func_length()
|
|
{ return "ret_val_len"; }
|
|
|
|
char *new_arg_length(arg)
|
|
Namep arg;
|
|
{
|
|
static char buf[64];
|
|
sprintf (buf, "%s_len", arg->fvarname);
|
|
|
|
return buf;
|
|
} /* new_arg_length */
|
|
|
|
|
|
/* declare_new_addr -- Add a new local variable to the function, given a
|
|
pointer to an Addrblock structure (which must have the uname_tag set)
|
|
This list of idents will be printed in reverse (i.e., chronological)
|
|
order */
|
|
|
|
void
|
|
declare_new_addr (addrp)
|
|
struct Addrblock *addrp;
|
|
{
|
|
extern chainp new_vars;
|
|
|
|
new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
|
|
} /* declare_new_addr */
|
|
|
|
|
|
wr_nv_ident_help (outfile, addrp)
|
|
FILE *outfile;
|
|
struct Addrblock *addrp;
|
|
{
|
|
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 */
|
|
|
|
int nv_type_help (addrp)
|
|
struct Addrblock *addrp;
|
|
{
|
|
if (addrp == (struct Addrblock *) NULL)
|
|
return -1;
|
|
|
|
return addrp -> vtype;
|
|
} /* nv_type_help */
|
|
|
|
|
|
/* lit_name -- returns a unique identifier for the given literal. Make
|
|
the label useful, when possible. For example:
|
|
|
|
1 -> c_1 (constant 1)
|
|
2 -> c_2 (constant 2)
|
|
1000 -> c_1000 (constant 1000)
|
|
1000000 -> c_b<memno> (big constant number)
|
|
1.2 -> c_1_2 (constant 1.2)
|
|
1.234345 -> c_b<memno> (big constant number)
|
|
-1 -> c_n1 (constant -1)
|
|
-1.0 -> c_n1_0 (constant -1.0)
|
|
.true. -> c_true (constant true)
|
|
.false. -> c_false (constant false)
|
|
default -> c_b<memno> (default label)
|
|
*/
|
|
|
|
char *lit_name (litp)
|
|
struct Literal *litp;
|
|
{
|
|
static char buf[CONST_IDENT_MAX];
|
|
ftnint val;
|
|
|
|
if (litp == (struct Literal *) NULL)
|
|
return NULL;
|
|
|
|
switch (litp -> littype) {
|
|
case TYINT1:
|
|
val = litp -> litval.litival;
|
|
if (val >= 256 || val < -255)
|
|
sprintf (buf, "c_b%d", litp -> litnum);
|
|
else if (val < 0)
|
|
sprintf (buf, "ci1_n%ld", -val);
|
|
else
|
|
sprintf(buf, "ci1__%ld", val);
|
|
case TYSHORT:
|
|
val = litp -> litval.litival;
|
|
if (val >= 32768 || val <= -32769)
|
|
sprintf (buf, "c_b%d", litp -> litnum);
|
|
else if (val < 0)
|
|
sprintf (buf, "cs_n%ld", -val);
|
|
else
|
|
sprintf (buf, "cs__%ld", val);
|
|
break;
|
|
case TYLONG:
|
|
#ifdef TYQUAD
|
|
case TYQUAD:
|
|
#endif
|
|
val = litp -> litval.litival;
|
|
if (val >= 100000 || val <= -10000)
|
|
sprintf (buf, "c_b%d", litp -> litnum);
|
|
else if (val < 0)
|
|
sprintf (buf, "c_n%ld", -val);
|
|
else
|
|
sprintf (buf, "c__%ld", val);
|
|
break;
|
|
case TYLOGICAL1:
|
|
case TYLOGICAL2:
|
|
case TYLOGICAL:
|
|
sprintf (buf, "c_%s", (litp -> litval.litival
|
|
? "true" : "false"));
|
|
break;
|
|
case TYREAL:
|
|
case TYDREAL:
|
|
/* Given a limit of 6 or 8 character on external names, */
|
|
/* few f.p. values can be meaningfully encoded in the */
|
|
/* constant name. Just going with the default cb_# */
|
|
/* seems to be the best course for floating-point */
|
|
/* constants. */
|
|
case TYCHAR:
|
|
/* Shouldn't be any of these */
|
|
case TYADDR:
|
|
case TYCOMPLEX:
|
|
case TYDCOMPLEX:
|
|
case TYSUBR:
|
|
default:
|
|
sprintf (buf, "c_b%d", litp -> litnum);
|
|
} /* switch */
|
|
return buf;
|
|
} /* lit_name */
|
|
|
|
|
|
|
|
char *
|
|
comm_union_name(count)
|
|
int count;
|
|
{
|
|
static char buf[12];
|
|
|
|
sprintf(buf, "%d", count);
|
|
return buf;
|
|
}
|
|
|
|
|
|
|
|
|
|
/* wr_globals -- after every function has been translated, we need to
|
|
output the global declarations, such as the static table of constant
|
|
values */
|
|
|
|
wr_globals (outfile)
|
|
FILE *outfile;
|
|
{
|
|
struct Literal *litp, *lastlit;
|
|
extern int hsize;
|
|
extern char *lit_name();
|
|
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 */
|
|
|
|
ftnint
|
|
commlen(vl)
|
|
register chainp vl;
|
|
{
|
|
ftnint size;
|
|
int type;
|
|
struct Dimblock *t;
|
|
Namep v;
|
|
|
|
while(vl->nextp)
|
|
vl = vl->nextp;
|
|
v = (Namep)vl->datap;
|
|
type = v->vtype;
|
|
if (type == TYCHAR)
|
|
size = v->vleng->constblock.Const.ci;
|
|
else
|
|
size = typesize[type];
|
|
if ((t = v->vdim) && ISCONST(t->nelt))
|
|
size *= t->nelt->constblock.Const.ci;
|
|
return size + v->voffset;
|
|
}
|
|
|
|
static void /* Pad common block if an EQUIVALENCE extended it. */
|
|
pad_common(c)
|
|
Extsym *c;
|
|
{
|
|
register chainp cvl;
|
|
register Namep v;
|
|
long L = c->maxleng;
|
|
int type;
|
|
struct Dimblock *t;
|
|
int szshort = typesize[TYSHORT];
|
|
|
|
for(cvl = c->allextp; cvl; cvl = cvl->nextp)
|
|
if (commlen((chainp)cvl->datap) >= L)
|
|
return;
|
|
v = ALLOC(Nameblock);
|
|
v->vtype = type = L % szshort ? TYCHAR
|
|
: type_choice[L/szshort % 4];
|
|
v->vstg = STGCOMMON;
|
|
v->vclass = CLVAR;
|
|
v->tag = TNAME;
|
|
v->vdim = t = ALLOC(Dimblock);
|
|
t->ndim = 1;
|
|
t->dims[0].dimsize = ICON(L / typesize[type]);
|
|
v->fvarname = v->cvarname = "eqv_pad";
|
|
if (type == TYCHAR)
|
|
v->vleng = ICON(1);
|
|
c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
|
|
}
|
|
|
|
|
|
/* wr_common_decls -- outputs the common declarations in one of three
|
|
formats. If all references to a common block look the same (field
|
|
names and types agree), only one actual declaration will appear.
|
|
Otherwise, the same block will require many structs. If there is no
|
|
block data, these structs will be union'ed together (so the linker
|
|
knows the size of the largest one). If there IS a block data, only
|
|
that version will be associated with the variable, others will only be
|
|
defined as types, so the pointer can be cast to it. e.g.
|
|
|
|
FORTRAN C
|
|
----------------------------------------------------------------------
|
|
common /com1/ a, b, c struct { real a, b, c; } com1_;
|
|
|
|
common /com1/ a, b, c union {
|
|
common /com1/ i, j, k struct { real a, b, c; } _1;
|
|
struct { integer i, j, k; } _2;
|
|
} com1_;
|
|
|
|
common /com1/ a, b, c struct com1_1_ { real a, b, c; };
|
|
block data struct { integer i, j, k; } com1_ =
|
|
common /com1/ i, j, k { 1, 2, 3 };
|
|
data i/1/, j/2/, k/3/
|
|
|
|
|
|
All of these versions will be followed by #defines, since the code in
|
|
the function bodies can't know ahead of time which of these options
|
|
will be taken */
|
|
|
|
/* Macros for deciding the output type */
|
|
|
|
#define ONE_STRUCT 1
|
|
#define UNION_STRUCT 2
|
|
#define INIT_STRUCT 3
|
|
|
|
wr_common_decls(outfile)
|
|
FILE *outfile;
|
|
{
|
|
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_struct (outfile, var_list)
|
|
FILE *outfile;
|
|
chainp var_list;
|
|
{
|
|
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, *wr_ardecls ();
|
|
|
|
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 */
|
|
|
|
|
|
char *user_label(stateno)
|
|
ftnint stateno;
|
|
{
|
|
static char buf[USER_LABEL_MAX + 1];
|
|
static char *Lfmt[2] = { "L_%ld", "L%ld" };
|
|
|
|
if (stateno >= 0)
|
|
sprintf(buf, Lfmt[shiftcase], stateno);
|
|
else
|
|
sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
|
|
return buf;
|
|
} /* user_label */
|
|
|
|
|
|
char *temp_name (starter, num, storage)
|
|
char *starter;
|
|
int num;
|
|
char *storage;
|
|
{
|
|
static char buf[IDENT_LEN];
|
|
char *pointer = buf;
|
|
char *prefix = "t";
|
|
|
|
if (storage)
|
|
pointer = storage;
|
|
|
|
if (starter && *starter)
|
|
prefix = starter;
|
|
|
|
sprintf (pointer, "%s__%d", prefix, num);
|
|
return pointer;
|
|
} /* temp_name */
|
|
|
|
|
|
char *equiv_name (memno, store)
|
|
int memno;
|
|
char *store;
|
|
{
|
|
static char buf[IDENT_LEN];
|
|
char *pointer = buf;
|
|
|
|
if (store)
|
|
pointer = store;
|
|
|
|
sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
|
|
return pointer;
|
|
} /* equiv_name */
|
|
|
|
void
|
|
def_commons(of)
|
|
FILE *of;
|
|
{
|
|
Extsym *ext;
|
|
int c, onefile, Union;
|
|
char buf[64];
|
|
chainp comm;
|
|
extern int ext1comm;
|
|
FILE *c_filesave = c_file;
|
|
|
|
if (ext1comm == 1) {
|
|
onefile = 1;
|
|
c_file = of;
|
|
fprintf(of, "/*>>>'/dev/null'<<<*/\n\
|
|
#ifdef Define_COMMONs\n\
|
|
/*<<</dev/null>>>*/\n");
|
|
}
|
|
else
|
|
onefile = 0;
|
|
for(ext = extsymtab; ext < nextext; ext++)
|
|
if (ext->extstg == STGCOMMON
|
|
&& !ext->extinit && (comm = ext->allextp)) {
|
|
sprintf(buf, "%scom.c", ext->cextname);
|
|
if (onefile)
|
|
fprintf(of, "/*>>>'%s'<<<*/\n",
|
|
buf);
|
|
else {
|
|
c_file = of = fopen(buf,textwrite);
|
|
if (!of)
|
|
fatalstr("can't open %s", buf);
|
|
}
|
|
fprintf(of, "#include \"f2c.h\"\n");
|
|
if (comm->nextp) {
|
|
Union = 1;
|
|
nice_printf(of, "union {\n");
|
|
next_tab(of);
|
|
}
|
|
else
|
|
Union = 0;
|
|
for(c = 1; comm; comm = comm->nextp) {
|
|
nice_printf(of, "struct {\n");
|
|
next_tab(of);
|
|
wr_struct(of, (chainp)comm->datap);
|
|
prev_tab(of);
|
|
if (Union)
|
|
nice_printf(of, "} _%d;\n", c++);
|
|
}
|
|
if (Union)
|
|
prev_tab(of);
|
|
nice_printf(of, "} %s;\n", ext->cextname);
|
|
if (onefile)
|
|
fprintf(of, "/*<<<%s>>>*/\n", buf);
|
|
else
|
|
fclose(of);
|
|
}
|
|
if (onefile)
|
|
fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
|
|
/*<<</dev/null>>>*/\n");
|
|
c_file = c_filesave;
|
|
}
|
|
|
|
/* C Language keywords. Needed to filter unwanted fortran identifiers like
|
|
* "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
|
|
* Also includes C++ keywords and types used for I/O in f2c.h .
|
|
* These keywords must be in alphabetical order (as defined by strcmp()).
|
|
*/
|
|
|
|
char *c_keywords[] = {
|
|
"Long", "Multitype", "Namelist", "Vardesc",
|
|
"abs", "acos", "address", "alist", "asin", "asm",
|
|
"atan", "atan2", "auto", "break",
|
|
"case", "catch", "char", "cilist", "class", "cllist",
|
|
"complex", "const", "continue", "cos", "cosh",
|
|
"dabs", "default", "defined", "delete",
|
|
"dmax", "dmin", "do", "double", "doublecomplex", "doublereal",
|
|
"else", "entry", "enum", "exp", "extern",
|
|
"flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
|
|
"icilist", "if", "include", "inline", "inlist", "int", "integer",
|
|
"integer1", "log", "logical", "logical1", "long", "longint",
|
|
"max", "min", "new",
|
|
"olist", "operator", "overload", "private", "protected", "public",
|
|
"real", "register", "return",
|
|
"short", "shortint", "shortlogical", "signed", "sin", "sinh",
|
|
"sizeof", "sqrt", "static", "struct", "switch",
|
|
"tan", "tanh", "template", "this", "try", "typedef",
|
|
"union", "unsigned", "virtual", "void", "volatile", "while"
|
|
}; /* c_keywords */
|
|
|
|
int n_keywords = sizeof(c_keywords)/sizeof(char *);
|
|
|
|
char *st_fields[] = {
|
|
"addr", "aerr", "aunit", "c", "cerr", "ciend", "cierr",
|
|
"cifmt", "cirec", "ciunit", "csta", "cunit", "d", "dims",
|
|
"h", "i", "iciend", "icierr", "icifmt", "icirlen",
|
|
"icirnum", "iciunit", "inacc", "inacclen", "inblank",
|
|
"inblanklen", "indir", "indirlen", "inerr", "inex",
|
|
"infile", "infilen", "infmt", "infmtlen", "inform",
|
|
"informlen", "inname", "innamed", "innamlen", "innrec",
|
|
"innum", "inopen", "inrecl", "inseq", "inseqlen", "inunf",
|
|
"inunflen", "inunit", "name", "nvars", "oacc", "oblnk",
|
|
"oerr", "ofm", "ofnm", "ofnmlen", "orl", "osta", "ounit",
|
|
"r", "type", "vars", "z"
|
|
};
|
|
int n_st_fields = sizeof(st_fields)/sizeof(char *);
|