diff options
author | ljo <ljo@FreeBSD.org> | 1994-01-05 02:53:40 +0000 |
---|---|---|
committer | ljo <ljo@FreeBSD.org> | 1994-01-05 02:53:40 +0000 |
commit | b0bfbf3dbded7a8d47a844bd1ae18498e620a6f2 (patch) | |
tree | b30007e77419520e5afba465be75d7cc308df521 /usr.bin/f2c/formatdata.c | |
download | FreeBSD-src-b0bfbf3dbded7a8d47a844bd1ae18498e620a6f2.zip FreeBSD-src-b0bfbf3dbded7a8d47a844bd1ae18498e620a6f2.tar.gz |
f2c from netlib.att.com Jan 4 1994
Diffstat (limited to 'usr.bin/f2c/formatdata.c')
-rw-r--r-- | usr.bin/f2c/formatdata.c | 1081 |
1 files changed, 1081 insertions, 0 deletions
diff --git a/usr.bin/f2c/formatdata.c b/usr.bin/f2c/formatdata.c new file mode 100644 index 0000000..541472a --- /dev/null +++ b/usr.bin/f2c/formatdata.c @@ -0,0 +1,1081 @@ +/**************************************************************** +Copyright 1990, 1991, 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 "format.h" + +#define MAX_INIT_LINE 100 +#define NAME_MAX 64 + +static int memno2info(); + +extern char *initbname; +extern void def_start(); + +void list_init_data(Infile, Inname, outfile) + FILE **Infile, *outfile; + char *Inname; +{ + FILE *sortfp; + int status; + + fclose(*Infile); + *Infile = 0; + + if (status = dsort(Inname, sortfname)) + fatali ("sort failed, status %d", status); + + scrub(Inname); /* optionally unlink Inname */ + + if ((sortfp = fopen(sortfname, textread)) == NULL) + Fatal("Couldn't open sorted initialization data"); + + do_init_data(outfile, sortfp); + fclose(sortfp); + scrub(sortfname); + +/* Insert a blank line after any initialized data */ + + nice_printf (outfile, "\n"); + + if (debugflag && infname) + /* don't back block data file up -- it won't be overwritten */ + backup(initfname, initbname); +} /* list_init_data */ + + + +/* do_init_data -- returns YES when at least one declaration has been + written */ + +int do_init_data(outfile, infile) +FILE *outfile, *infile; +{ + char varname[NAME_MAX], ovarname[NAME_MAX]; + ftnint offset; + ftnint type; + int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */ + int did_one = 0; /* True when one has been output */ + chainp values = CHNULL; /* Actual data values */ + int keepit = 0; + Namep np; + + ovarname[0] = '\0'; + + while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset) + && rdlong (infile, &type)) { + if (strcmp (varname, ovarname)) { + + /* If this is a new variable name, the old initialization has been + completed */ + + wr_one_init(outfile, ovarname, &values, keepit); + + strcpy (ovarname, varname); + values = CHNULL; + if (vargroup == 0) { + if (memno2info(atoi(varname+2), &np)) { + if (((Addrp)np)->uname_tag != UNAM_NAME) { + err("do_init_data: expected NAME"); + goto Keep; + } + np = ((Addrp)np)->user.name; + } + if (!(keepit = np->visused) && !np->vimpldovar) + warn1("local variable %s never used", + np->fvarname); + } + else { + Keep: + keepit = 1; + } + if (keepit && !did_one) { + nice_printf (outfile, "/* Initialized data */\n\n"); + did_one = YES; + } + } /* if strcmp */ + + values = mkchain((char *)data_value(infile, offset, (int)type), values); + } /* while */ + +/* Write out the last declaration */ + + wr_one_init (outfile, ovarname, &values, keepit); + + return did_one; +} /* do_init_data */ + + + ftnint +wr_char_len(outfile, dimp, n, extra1) + FILE *outfile; + int n; + struct Dimblock *dimp; + int extra1; +{ + int i, nd; + expptr e; + ftnint rv; + + if (!dimp) { + nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n); + return n + extra1; + } + nice_printf(outfile, "[%d", n); + nd = dimp->ndim; + rv = n; + for(i = 0; i < nd; i++) { + e = dimp->dims[i].dimsize; + if (!ISICON (e)) + err ("wr_char_len: nonconstant array size"); + else { + nice_printf(outfile, "*%ld", e->constblock.Const.ci); + rv *= e->constblock.Const.ci; + } + } + /* extra1 allows for stupid C compilers that complain about + * too many initializers in + * char x[2] = "ab"; + */ + nice_printf(outfile, extra1 ? "+1]" : "]"); + return extra1 ? rv+1 : rv; + } + + static int ch_ar_dim = -1; /* length of each element of char string array */ + static int eqvmemno; /* kludge */ + + static void +write_char_init(outfile, Values, namep) + FILE *outfile; + chainp *Values; + Namep namep; +{ + struct Equivblock *eqv; + long size; + struct Dimblock *dimp; + int i, nd, type; + expptr ds; + + if (!namep) + return; + if(nequiv >= maxequiv) + many("equivalences", 'q', maxequiv); + eqv = &eqvclass[nequiv]; + eqv->eqvbottom = 0; + type = namep->vtype; + size = type == TYCHAR + ? namep->vleng->constblock.Const.ci + : typesize[type]; + if (dimp = namep->vdim) + for(i = 0, nd = dimp->ndim; i < nd; i++) { + ds = dimp->dims[i].dimsize; + if (!ISICON(ds)) + err("write_char_values: nonconstant array size"); + else + size *= ds->constblock.Const.ci; + } + *Values = revchain(*Values); + eqv->eqvtop = size; + eqvmemno = ++lastvarno; + eqv->eqvtype = type; + wr_equiv_init(outfile, nequiv, Values, 0); + def_start(outfile, namep->cvarname, CNULL, ""); + if (type == TYCHAR) + ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno); + else + ind_printf(0, outfile, dimp + ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n", + c_type_decl(type,0), eqvmemno); + } + +/* wr_one_init -- outputs the initialization of the variable pointed to + by info. When is_addr is true, info is an Addrp; otherwise, + treat it as a Namep */ + +void wr_one_init (outfile, varname, Values, keepit) +FILE *outfile; +char *varname; +chainp *Values; +int keepit; +{ + static int memno; + static union { + Namep name; + Addrp addr; + } info; + Namep namep; + int is_addr, size, type; + ftnint last, loc; + int is_scalar = 0; + char *array_comment = NULL, *name; + chainp cp, values; + extern char datachar[]; + static int e1[3] = {1, 0, 1}; + ftnint x; + extern int hsize; + + if (!keepit) + goto done; + if (varname == NULL || varname[1] != '.') + goto badvar; + +/* Get back to a meaningful representation; find the given memno in one + of the appropriate tables (user-generated variables in the hash table, + system-generated variables in a separate list */ + + memno = atoi(varname + 2); + switch(varname[0]) { + case 'q': + /* Must subtract eqvstart when the source file + * contains more than one procedure. + */ + wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0); + goto done; + case 'Q': + /* COMMON initialization (BLOCK DATA) */ + wr_equiv_init(outfile, memno, Values, 1); + goto done; + case 'v': + break; + default: + badvar: + errstr("wr_one_init: unknown variable name '%s'", varname); + goto done; + } + + is_addr = memno2info (memno, &info.name); + if (info.name == (Namep) NULL) { + err ("wr_one_init -- unknown variable"); + return; + } + if (is_addr) { + if (info.addr -> uname_tag != UNAM_NAME) { + erri ("wr_one_init -- couldn't get name pointer; tag is %d", + info.addr -> uname_tag); + namep = (Namep) NULL; + nice_printf (outfile, " /* bad init data */"); + } else + namep = info.addr -> user.name; + } else + namep = info.name; + + /* check for character initialization */ + + *Values = values = revchain(*Values); + type = info.name->vtype; + if (type == TYCHAR) { + for(last = 0; values; values = values->nextp) { + cp = (chainp)values->datap; + loc = (ftnint)cp->datap; + if (loc > last) { + write_char_init(outfile, Values, namep); + goto done; + } + last = (int)cp->nextp->datap == TYBLANK + ? loc + (int)cp->nextp->nextp->datap + : loc + 1; + } + if (halign && info.name->tag == TNAME) { + nice_printf(outfile, "static struct { %s fill; char val", + halign); + x = wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, 1); + if (x %= hsize) + nice_printf(outfile, "; char fill2[%ld]", hsize - x); + name = info.name->cvarname; + nice_printf(outfile, "; } %s_st = { 0,", name); + wr_output_values(outfile, namep, *Values); + nice_printf(outfile, " };\n"); + ch_ar_dim = -1; + def_start(outfile, name, CNULL, name); + ind_printf(0, outfile, "_st.val\n"); + goto done; + } + } + else { + size = typesize[type]; + loc = 0; + for(; values; values = values->nextp) { + if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) { + write_char_init(outfile, Values, namep); + goto done; + } + last = ((long) ((chainp) values->datap)->datap) / size; + if (last - loc > 4) { + write_char_init(outfile, Values, namep); + goto done; + } + loc = last; + } + } + values = *Values; + + nice_printf (outfile, "static %s ", c_type_decl (type, 0)); + + if (is_addr) + write_nv_ident (outfile, info.addr); + else + out_name (outfile, info.name); + + if (namep) + is_scalar = namep -> vdim == (struct Dimblock *) NULL; + + if (namep && !is_scalar) + array_comment = type == TYCHAR + ? 0 : wr_ardecls(outfile, namep->vdim, 1L); + + if (type == TYCHAR) + if (ISICON (info.name -> vleng)) + +/* We'll make single strings one character longer, so that we can use the + standard C initialization. All this does is pad an extra zero onto the + end of the string */ + wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, e1[Ansi]); + else + err ("variable length character initialization"); + + if (array_comment) + nice_printf (outfile, "%s", array_comment); + + nice_printf (outfile, " = "); + wr_output_values (outfile, namep, values); + ch_ar_dim = -1; + nice_printf (outfile, ";\n"); + done: + frchain(Values); +} /* wr_one_init */ + + + + +chainp data_value (infile, offset, type) +FILE *infile; +ftnint offset; +int type; +{ + char line[MAX_INIT_LINE + 1], *pointer; + chainp vals, prev_val; +#ifndef atol + long atol(); +#endif + char *newval; + + if (fgets (line, MAX_INIT_LINE, infile) == NULL) { + err ("data_value: error reading from intermediate file"); + return CHNULL; + } /* if fgets */ + +/* Get rid of the trailing newline */ + + if (line[0]) + line[strlen (line) - 1] = '\0'; + +#define iswhite(x) (isspace (x) || (x) == ',') + + pointer = line; + prev_val = vals = CHNULL; + + while (*pointer) { + register char *end_ptr, old_val; + +/* Move pointer to the start of the next word */ + + while (*pointer && iswhite (*pointer)) + pointer++; + if (*pointer == '\0') + break; + +/* Move end_ptr to the end of the current word */ + + for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr); + end_ptr++) + ; + + old_val = *end_ptr; + *end_ptr = '\0'; + +/* Add this value to the end of the list */ + + if (ONEOF(type, MSKREAL|MSKCOMPLEX)) + newval = cpstring(pointer); + else + newval = (char *)atol(pointer); + if (vals) { + prev_val->nextp = mkchain(newval, CHNULL); + prev_val = prev_val -> nextp; + } else + prev_val = vals = mkchain(newval, CHNULL); + *end_ptr = old_val; + pointer = end_ptr; + } /* while *pointer */ + + return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals)); +} /* data_value */ + + static void +overlapping() +{ + extern char *filename0; + static int warned = 0; + + if (warned) + return; + warned = 1; + + fprintf(stderr, "Error"); + if (filename0) + fprintf(stderr, " in file %s", filename0); + fprintf(stderr, ": overlapping initializations\n"); + nerr++; + } + + static void make_one_const(); + static long charlen; + +void wr_output_values (outfile, namep, values) +FILE *outfile; +Namep namep; +chainp values; +{ + int type = TYUNKNOWN; + struct Constblock Const; + static expptr Vlen; + + if (namep) + type = namep -> vtype; + +/* Handle array initializations away from scalars */ + + if (namep && namep -> vdim) + wr_array_init (outfile, namep -> vtype, values); + + else if (values->nextp && type != TYCHAR) + overlapping(); + + else { + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; + if (type== TYCHAR) { + if (!Vlen) + Vlen = ICON(0); + Const.vleng = Vlen; + Vlen->constblock.Const.ci = charlen; + out_const (outfile, &Const); + free (Const.Const.ccp); + } + else + out_const (outfile, &Const); + } + } + + +wr_array_init (outfile, type, values) +FILE *outfile; +int type; +chainp values; +{ + int size = typesize[type]; + long index, main_index = 0; + int k; + + if (type == TYCHAR) { + nice_printf(outfile, "\""); + k = 0; + if (Ansi != 1) + ch_ar_dim = -1; + } + else + nice_printf (outfile, "{ "); + while (values) { + struct Constblock Const; + + index = ((long) ((chainp) values->datap)->datap) / size; + while (index > main_index) { + +/* Fill with zeros. The structure shorthand works because the compiler + will expand the "0" in braces to fill the size of the entire structure + */ + + switch (type) { + case TYREAL: + case TYDREAL: + nice_printf (outfile, "0.0,"); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + nice_printf (outfile, "{0},"); + break; + case TYCHAR: + nice_printf(outfile, " "); + break; + default: + nice_printf (outfile, "0,"); + break; + } /* switch */ + main_index++; + } /* while index > main_index */ + + if (index < main_index) + overlapping(); + else switch (type) { + case TYCHAR: + { int this_char; + + if (k == ch_ar_dim) { + nice_printf(outfile, "\" \""); + k = 0; + } + this_char = (int) ((chainp) values->datap)-> + nextp->nextp->datap; + if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { + main_index += this_char; + k += this_char; + while(--this_char >= 0) + nice_printf(outfile, " "); + values = values -> nextp; + continue; + } + nice_printf(outfile, str_fmt[this_char], this_char); + k++; + } /* case TYCHAR */ + break; + + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + case TYREAL: + case TYDREAL: + case TYLOGICAL: + case TYLOGICAL1: + case TYLOGICAL2: + case TYCOMPLEX: + case TYDCOMPLEX: + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; + out_const(outfile, &Const); + break; + default: + erri("wr_array_init: bad type '%d'", type); + break; + } /* switch */ + values = values->nextp; + + main_index++; + if (values && type != TYCHAR) + nice_printf (outfile, ","); + } /* while values */ + + if (type == TYCHAR) { + nice_printf(outfile, "\""); + } + else + nice_printf (outfile, " }"); +} /* wr_array_init */ + + + static void +make_one_const(type, storage, values) + int type; + union Constant *storage; + chainp values; +{ + union Constant *Const; + register char **L; + + if (type == TYCHAR) { + char *str, *str_ptr; + chainp v, prev; + int b = 0, k, main_index = 0; + +/* Find the max length of init string, by finding the highest offset + value stored in the list of initial values */ + + for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp) + ; + if (prev != CHNULL) + k = ((int) (((chainp) prev->datap)->datap)) + 2; + /* + 2 above for null char at end */ + str = Alloc (k); + for (str_ptr = str; values; str_ptr++) { + int index = (int) (((chainp) values->datap)->datap); + + if (index < main_index) + overlapping(); + while (index > main_index++) + *str_ptr++ = ' '; + + k = (int) (((chainp) values->datap)->nextp->nextp->datap); + if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { + b = k; + break; + } + *str_ptr = k; + values = values -> nextp; + } /* for str_ptr */ + *str_ptr = '\0'; + Const = storage; + Const -> ccp = str; + Const -> ccp1.blanks = b; + charlen = str_ptr - str; + } else { + int i = 0; + chainp vals; + + vals = ((chainp)values->datap)->nextp->nextp; + if (vals) { + L = (char **)storage; + do L[i++] = vals->datap; + while(vals = vals->nextp); + } + + } /* else */ + +} /* make_one_const */ + + + +rdname (infile, vargroupp, name) +FILE *infile; +int *vargroupp; +char *name; +{ + register int i, c; + + c = getc (infile); + + if (feof (infile)) + return NO; + + *vargroupp = c - '0'; + for (i = 1;; i++) { + if (i >= NAME_MAX) + Fatal("rdname: oversize name"); + c = getc (infile); + if (feof (infile)) + return NO; + if (c == '\t') + break; + *name++ = c; + } + *name = 0; + return YES; +} /* rdname */ + +rdlong (infile, n) +FILE *infile; +ftnint *n; +{ + register int c; + + for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile)) + ; + + if (feof (infile)) + return NO; + + for (*n = 0; isdigit (c); c = getc (infile)) + *n = 10 * (*n) + c - '0'; + return YES; +} /* rdlong */ + + + static int +memno2info (memno, info) + int memno; + Namep *info; +{ + chainp this_var; + extern chainp new_vars; + extern struct Hashentry *hashtab, *lasthash; + struct Hashentry *entry; + + for (this_var = new_vars; this_var; this_var = this_var -> nextp) { + Addrp var = (Addrp) this_var->datap; + + if (var == (Addrp) NULL) + Fatal("memno2info: null variable"); + else if (var -> tag != TADDR) + Fatal("memno2info: bad tag"); + if (memno == var -> memno) { + *info = (Namep) var; + return 1; + } /* if memno == var -> memno */ + } /* for this_var = new_vars */ + + for (entry = hashtab; entry < lasthash; ++entry) { + Namep var = entry -> varp; + + if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) { + *info = (Namep) var; + return 0; + } /* if entry -> vardesc.varno == memno */ + } /* for entry = hashtab */ + + Fatal("memno2info: couldn't find memno"); + return 0; +} /* memno2info */ + + static chainp +do_string(outfile, v, nloc) + FILEP outfile; + register chainp v; + ftnint *nloc; +{ + register chainp cp, v0; + ftnint dloc, k, loc; + unsigned long uk; + char buf[8], *comma; + + nice_printf(outfile, "{"); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + comma = ""; + for(v0 = v;;) { + switch((int)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) { + nice_printf(outfile, "%s' '", comma); + comma = ", "; + } + break; + case TYCHAR: + uk = (ftnint)cp->nextp->nextp->datap; + sprintf(buf, chr_fmt[uk], uk); + nice_printf(outfile, "%s'%s'", comma, buf); + comma = ", "; + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp)) + break; + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "}"); + *nloc = loc; + return v0; + } + + static chainp +Ado_string(outfile, v, nloc) + FILEP outfile; + register chainp v; + ftnint *nloc; +{ + register chainp cp, v0; + ftnint dloc, k, loc; + + nice_printf(outfile, "\""); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + for(v0 = v;;) { + switch((int)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) + nice_printf(outfile, " "); + break; + case TYCHAR: + k = (ftnint)cp->nextp->nextp->datap; + nice_printf(outfile, str_fmt[k], k); + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp)) + break; + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "\""); + *nloc = loc; + return v0; + } + + static char * +Len(L,type) + long L; + int type; +{ + static char buf[24]; + if (L == 1 && type != TYCHAR) + return ""; + sprintf(buf, "[%ld]", L); + return buf; + } + +wr_equiv_init(outfile, memno, Values, iscomm) + FILE *outfile; + int memno; + chainp *Values; + int iscomm; +{ + struct Equivblock *eqv; + char *equiv_name (); + int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype; + static char Blank[] = ""; + register char *comma = Blank; + register chainp cp, v; + chainp sentinel, values, v1, vlast; + ftnint L, L1, dL, dloc, loc, loc0; + union Constant Const; + char imag_buf[50], real_buf[50]; + int szshort = typesize[TYSHORT]; + static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG, +#ifdef TYQUAD + TYQUAD, +#endif + TYREAL, TYDREAL, TYREAL, TYDREAL, + TYLOGICAL1, TYLOGICAL2, + TYLOGICAL, TYCHAR}; + static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG, +#ifdef TYQUAD + TYDREAL, +#endif + TYLONG, TYDREAL, TYLONG, TYDREAL, + TYCHAR, TYSHORT, + TYLONG, TYCHAR}; + extern int htype; + char *z; + + /* add sentinel */ + if (iscomm) { + L = extsymtab[memno].maxleng; + xtype = extsymtab[memno].extype; + } + else { + eqv = &eqvclass[memno]; + L = eqv->eqvtop - eqv->eqvbottom; + xtype = eqv->eqvtype; + } + + if (halign && typealign[typepref[xtype]] < typealign[htype]) + xtype = htype; + *Values = values = revchain(vlast = *Values); + + if (xtype != TYCHAR) { + + /* unless the data include a value of the appropriate + * type, we add an extra element in an attempt + * to force correct alignment */ + + btype = basetype[xtype]; + loc = 0; + for(v = *Values;;v = v->nextp) { + if (!v) { + dtype = typepref[xtype]; + z = ISREAL(dtype) ? cpstring("0.") : (char *)0; + k = typesize[dtype]; + if (j = L % k) + L += k - j; + v = mkchain((char *)L, + mkchain((char *)LONG_CAST dtype, + mkchain(z, CHNULL))); + vlast = vlast->nextp = + mkchain((char *)v, CHNULL); + L += k; + break; + } + cp = (chainp)v->datap; + if (basetype[(int)cp->nextp->datap] == btype) + break; + dloc = (ftnint)cp->datap; + L1 = dloc - loc; + if (L1 > 0 + && !(L1 % szshort) + && !(loc % szshort) + && btype <= type_choice[L1/szshort % 4] + && btype <= type_choice[loc/szshort % 4]) + break; + dtype = (int)cp->nextp->datap; + loc = dloc + dtype == TYBLANK + ? (ftnint)cp->nextp->nextp->datap + : typesize[dtype]; + } + } + sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL)); + vlast->nextp = mkchain((char *)sentinel, CHNULL); + + /* use doublereal fillers only if there are doublereal values */ + + k = TYLONG; + for(v = values; v; v = v->nextp) + if (ONEOF((int)((chainp)v->datap)->nextp->datap, + M(TYDREAL)|M(TYDCOMPLEX))) { + k = TYDREAL; + break; + } + type_choice[0] = k; + + nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static "); + next_tab(outfile); + loc = loc0 = k = 0; + curtype = -1; + for(v = values; v; v = v->nextp) { + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + L = dloc - loc; + if (L < 0) { + overlapping(); + if ((int)cp->nextp->datap != TYERROR) { + v1 = cp; + frchain(&v1); + v->datap = 0; + } + continue; + } + dtype = (int)cp->nextp->datap; + if (dtype == TYBLANK) { + dtype = TYCHAR; + wasblank = 1; + } + else + wasblank = 0; + if (curtype != dtype || L > 0) { + if (curtype != -1) { + L1 = (loc - loc0)/dL; + nice_printf(outfile, "%s e_%d%s;\n", + typename[curtype], ++k, + Len(L1,curtype)); + } + curtype = dtype; + loc0 = dloc; + } + if (L > 0) { + if (xtype == TYCHAR) + filltype = TYCHAR; + else { + filltype = L % szshort ? TYCHAR + : type_choice[L/szshort % 4]; + filltype1 = loc % szshort ? TYCHAR + : type_choice[loc/szshort % 4]; + if (typesize[filltype] > typesize[filltype1]) + filltype = filltype1; + } + L1 = L / typesize[filltype]; + nice_printf(outfile, "%s fill_%d[%ld];\n", + typename[filltype], ++k, L1); + loc = dloc; + } + if (wasblank) { + loc += (ftnint)cp->nextp->nextp->datap; + dL = 1; + } + else { + dL = typesize[dtype]; + loc += dL; + } + } + nice_printf(outfile, "} %s = { ", iscomm + ? extsymtab[memno].cextname + : equiv_name(eqvmemno, CNULL)); + loc = 0; + for(v = values; ; v = v->nextp) { + cp = (chainp)v->datap; + if (!cp) + continue; + dtype = (int)cp->nextp->datap; + if (dtype == TYERROR) + break; + dloc = (ftnint)cp->datap; + if (dloc > loc) { + nice_printf(outfile, "%s{0}", comma); + comma = ", "; + loc = dloc; + } + if (comma != Blank) + nice_printf(outfile, ", "); + comma = ", "; + if (dtype == TYCHAR || dtype == TYBLANK) { + v = Ansi == 1 ? Ado_string(outfile, v, &loc) + : do_string(outfile, v, &loc); + continue; + } + make_one_const(dtype, &Const, v); + switch(dtype) { + case TYLOGICAL: + case TYLOGICAL2: + case TYLOGICAL1: + if (Const.ci < 0 || Const.ci > 1) + errl( + "wr_equiv_init: unexpected logical value %ld", + Const.ci); + nice_printf(outfile, + Const.ci ? "TRUE_" : "FALSE_"); + break; + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + nice_printf(outfile, "%ld", Const.ci); + break; + case TYREAL: + nice_printf(outfile, "%s", + flconst(real_buf, Const.cds[0])); + break; + case TYDREAL: + nice_printf(outfile, "%s", Const.cds[0]); + break; + case TYCOMPLEX: + nice_printf(outfile, "%s, %s", + flconst(real_buf, Const.cds[0]), + flconst(imag_buf, Const.cds[1])); + break; + case TYDCOMPLEX: + nice_printf(outfile, "%s, %s", + Const.cds[0], Const.cds[1]); + break; + default: + erri("unexpected type %d in wr_equiv_init", + dtype); + } + loc += typesize[dtype]; + } + nice_printf(outfile, " };\n\n"); + prev_tab(outfile); + frchain(&sentinel); + } |