00001 /****************************************************************
00002 Copyright 1990, 1991, 1993-6 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "defs.h"
00025 #include "output.h"
00026 #include "names.h"
00027 #include "format.h"
00028 
00029 #define MAX_INIT_LINE 100
00030 #define NAME_MAX 64
00031 
00032 static int memno2info Argdcl((int, Namep*));
00033 
00034  extern char *initbname;
00035 
00036  void
00037 #ifdef KR_headers
00038 list_init_data(Infile, Inname, outfile)
00039         FILE **Infile;
00040         char *Inname;
00041         FILE *outfile;
00042 #else
00043 list_init_data(FILE **Infile, char *Inname, FILE *outfile)
00044 #endif
00045 {
00046     FILE *sortfp;
00047     int status;
00048 
00049     fclose(*Infile);
00050     *Infile = 0;
00051 
00052     if (status = dsort(Inname, sortfname))
00053         fatali ("sort failed, status %d", status);
00054 
00055     scrub(Inname); /* optionally unlink Inname */
00056 
00057     if ((sortfp = fopen(sortfname, textread)) == NULL)
00058         Fatal("Couldn't open sorted initialization data");
00059 
00060     do_init_data(outfile, sortfp);
00061     fclose(sortfp);
00062     scrub(sortfname);
00063 
00064 /* Insert a blank line after any initialized data */
00065 
00066         nice_printf (outfile, "\n");
00067 
00068     if (debugflag && infname)
00069          /* don't back block data file up -- it won't be overwritten */
00070         backup(initfname, initbname);
00071 } /* list_init_data */
00072 
00073 
00074 
00075 /* do_init_data -- returns YES when at least one declaration has been
00076    written */
00077 
00078  int
00079 #ifdef KR_headers
00080 do_init_data(outfile, infile)
00081         FILE *outfile;
00082         FILE *infile;
00083 #else
00084 do_init_data(FILE *outfile, FILE *infile)
00085 #endif
00086 {
00087     char varname[NAME_MAX], ovarname[NAME_MAX];
00088     ftnint offset;
00089     ftnint type;
00090     int vargroup;       /* 0 --> init, 1 --> equiv, 2 --> common */
00091     int did_one = 0;            /* True when one has been output */
00092     chainp values = CHNULL;     /* Actual data values */
00093     int keepit = 0;
00094     Namep np;
00095 
00096     ovarname[0] = '\0';
00097 
00098     while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
00099             && rdlong (infile, &type)) {
00100         if (strcmp (varname, ovarname)) {
00101 
00102         /* If this is a new variable name, the old initialization has been
00103            completed */
00104 
00105                 wr_one_init(outfile, ovarname, &values, keepit);
00106 
00107                 strcpy (ovarname, varname);
00108                 values = CHNULL;
00109                 if (vargroup == 0) {
00110                         if (memno2info(atoi(varname+2), &np)) {
00111                                 if (((Addrp)np)->uname_tag != UNAM_NAME) {
00112                                         err("do_init_data: expected NAME");
00113                                         goto Keep;
00114                                         }
00115                                 np = ((Addrp)np)->user.name;
00116                                 }
00117                         if (!(keepit = np->visused) && !np->vimpldovar)
00118                                 warn1("local variable %s never used",
00119                                         np->fvarname);
00120                         }
00121                 else {
00122  Keep:
00123                         keepit = 1;
00124                         }
00125                 if (keepit && !did_one) {
00126                         nice_printf (outfile, "/* Initialized data */\n\n");
00127                         did_one = YES;
00128                         }
00129         } /* if strcmp */
00130 
00131         values = mkchain((char *)data_value(infile, offset, (int)type), values);
00132     } /* while */
00133 
00134 /* Write out the last declaration */
00135 
00136     wr_one_init (outfile, ovarname, &values, keepit);
00137 
00138     return did_one;
00139 } /* do_init_data */
00140 
00141 
00142  ftnint
00143 #ifdef KR_headers
00144 wr_char_len(outfile, dimp, n, extra1)
00145         FILE *outfile;
00146         struct Dimblock *dimp;
00147         int n;
00148         int extra1;
00149 #else
00150 wr_char_len(FILE *outfile, struct Dimblock *dimp, int n, int extra1)
00151 #endif
00152 {
00153         int i, nd;
00154         expptr e;
00155         ftnint j, rv;
00156 
00157         if (!dimp) {
00158                 nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
00159                 return n + extra1;
00160                 }
00161         nice_printf(outfile, "[%d", n);
00162         nd = dimp->ndim;
00163         rv = n;
00164         for(i = 0; i < nd; i++) {
00165                 e = dimp->dims[i].dimsize;
00166                 if (ISCONST(e)) {
00167                         if (ISINT(e->constblock.vtype))
00168                                 j = e->constblock.Const.ci;
00169                         else if (ISREAL(e->constblock.vtype))
00170                                 j = (ftnint)e->constblock.Const.cd[0];
00171                         else
00172                                 goto non_const;
00173                         nice_printf(outfile, "*%ld", j);
00174                         rv *= j;
00175                         }
00176                 else {
00177  non_const:
00178                         err ("wr_char_len:  nonconstant array size");
00179                         }
00180                 }
00181         /* extra1 allows for stupid C compilers that complain about
00182          * too many initializers in
00183          *      char x[2] = "ab";
00184          */
00185         nice_printf(outfile, extra1 ? "+1]" : "]");
00186         return extra1 ? rv+1 : rv;
00187         }
00188 
00189  static int ch_ar_dim = -1; /* length of each element of char string array */
00190  static int eqvmemno;   /* kludge */
00191 
00192  static void
00193 #ifdef KR_headers
00194 write_char_init(outfile, Values, namep)
00195         FILE *outfile;
00196         chainp *Values;
00197         Namep namep;
00198 #else
00199 write_char_init(FILE *outfile, chainp *Values, Namep namep)
00200 #endif
00201 {
00202         struct Equivblock *eqv;
00203         long size;
00204         struct Dimblock *dimp;
00205         int i, nd, type;
00206         ftnint j;
00207         expptr ds;
00208 
00209         if (!namep)
00210                 return;
00211         if(nequiv >= maxequiv)
00212                 many("equivalences", 'q', maxequiv);
00213         eqv = &eqvclass[nequiv];
00214         eqv->eqvbottom = 0;
00215         type = namep->vtype;
00216         size = type == TYCHAR
00217                 ? namep->vleng->constblock.Const.ci
00218                 : typesize[type];
00219         if (dimp = namep->vdim)
00220                 for(i = 0, nd = dimp->ndim; i < nd; i++) {
00221                         ds = dimp->dims[i].dimsize;
00222                         if (ISCONST(ds)) {
00223                                 if (ISINT(ds->constblock.vtype))
00224                                         j = ds->constblock.Const.ci;
00225                                 else if (ISREAL(ds->constblock.vtype))
00226                                         j = (ftnint)ds->constblock.Const.cd[0];
00227                                 else
00228                                         goto non_const;
00229                                 size *= j;
00230                                 }
00231                         else {
00232  non_const:
00233                                 err("write_char_values: nonconstant array size");
00234                                 }
00235                         }
00236         *Values = revchain(*Values);
00237         eqv->eqvtop = size;
00238         eqvmemno = ++lastvarno;
00239         eqv->eqvtype = type;
00240         wr_equiv_init(outfile, nequiv, Values, 0);
00241         def_start(outfile, namep->cvarname, CNULL, "");
00242         if (type == TYCHAR)
00243                 margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
00244         else
00245                 margin_printf(outfile, dimp
00246                         ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
00247                         c_type_decl(type,0), eqvmemno);
00248         }
00249 
00250 /* wr_one_init -- outputs the initialization of the variable pointed to
00251    by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
00252    treat it as a Namep */
00253 
00254  void
00255 #ifdef KR_headers
00256 wr_one_init(outfile, varname, Values, keepit)
00257         FILE *outfile;
00258         char *varname;
00259         chainp *Values;
00260         int keepit;
00261 #else
00262 wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit)
00263 #endif
00264 {
00265     static int memno;
00266     static union {
00267         Namep name;
00268         Addrp addr;
00269     } info;
00270     Namep namep;
00271     int is_addr, size, type;
00272     ftnint last, loc;
00273     int is_scalar = 0;
00274     char *array_comment = NULL, *name;
00275     chainp cp, values;
00276     extern char datachar[];
00277     static int e1[3] = {1, 0, 1};
00278     ftnint x;
00279     extern int hsize;
00280 
00281     if (!keepit)
00282         goto done;
00283     if (varname == NULL || varname[1] != '.')
00284         goto badvar;
00285 
00286 /* Get back to a meaningful representation; find the given   memno in one
00287    of the appropriate tables (user-generated variables in the hash table,
00288    system-generated variables in a separate list */
00289 
00290     memno = atoi(varname + 2);
00291     switch(varname[0]) {
00292         case 'q':
00293                 /* Must subtract eqvstart when the source file
00294                  * contains more than one procedure.
00295                  */
00296                 wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
00297                 goto done;
00298         case 'Q':
00299                 /* COMMON initialization (BLOCK DATA) */
00300                 wr_equiv_init(outfile, memno, Values, 1);
00301                 goto done;
00302         case 'v':
00303                 break;
00304         default:
00305  badvar:
00306                 errstr("wr_one_init:  unknown variable name '%s'", varname);
00307                 goto done;
00308         }
00309 
00310     is_addr = memno2info (memno, &info.name);
00311     if (info.name == (Namep) NULL) {
00312         err ("wr_one_init -- unknown variable");
00313         return;
00314         }
00315     if (is_addr) {
00316         if (info.addr -> uname_tag != UNAM_NAME) {
00317             erri ("wr_one_init -- couldn't get name pointer; tag is %d",
00318                     info.addr -> uname_tag);
00319             namep = (Namep) NULL;
00320             nice_printf (outfile, " /* bad init data */");
00321         } else
00322             namep = info.addr -> user.name;
00323     } else
00324         namep = info.name;
00325 
00326         /* check for character initialization */
00327 
00328     *Values = values = revchain(*Values);
00329     type = info.name->vtype;
00330     if (type == TYCHAR) {
00331         for(last = 0; values; values = values->nextp) {
00332                 cp = (chainp)values->datap;
00333                 loc = (ftnint)cp->datap;
00334                 if (loc > last) {
00335                         write_char_init(outfile, Values, namep);
00336                         goto done;
00337                         }
00338                 last = (int)cp->nextp->datap == TYBLANK
00339                         ? loc + (int)cp->nextp->nextp->datap
00340                         : loc + 1;
00341                 }
00342         if (halign && info.name->tag == TNAME) {
00343                 nice_printf(outfile, "static struct { %s fill; char val",
00344                         halign);
00345                 x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
00346                         info.name -> vleng -> constblock.Const.ci, 1);
00347                 if (x %= hsize)
00348                         nice_printf(outfile, "; char fill2[%ld]", hsize - x);
00349                 name = info.name->cvarname;
00350                 nice_printf(outfile, "; } %s_st = { 0,", name);
00351                 wr_output_values(outfile, namep, *Values);
00352                 nice_printf(outfile, " };\n");
00353                 ch_ar_dim = -1;
00354                 def_start(outfile, name, CNULL, name);
00355                 margin_printf(outfile, "_st.val\n");
00356                 goto done;
00357                 }
00358         }
00359     else {
00360         size = typesize[type];
00361         loc = 0;
00362         for(; values; values = values->nextp) {
00363                 if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
00364                         write_char_init(outfile, Values, namep);
00365                         goto done;
00366                         }
00367                 last = ((long) ((chainp) values->datap)->datap) / size;
00368                 if (last - loc > 4) {
00369                         write_char_init(outfile, Values, namep);
00370                         goto done;
00371                         }
00372                 loc = last;
00373                 }
00374         }
00375     values = *Values;
00376 
00377     nice_printf (outfile, "static %s ", c_type_decl (type, 0));
00378 
00379     if (is_addr)
00380         write_nv_ident (outfile, info.addr);
00381     else
00382         out_name (outfile, info.name);
00383 
00384     if (namep)
00385         is_scalar = namep -> vdim == (struct Dimblock *) NULL;
00386 
00387     if (namep && !is_scalar)
00388         array_comment = type == TYCHAR
00389                 ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
00390 
00391     if (type == TYCHAR)
00392         if (ISICON (info.name -> vleng))
00393 
00394 /* We'll make single strings one character longer, so that we can use the
00395    standard C initialization.  All this does is pad an extra zero onto the
00396    end of the string */
00397                 wr_char_len(outfile, namep->vdim, ch_ar_dim =
00398                         info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
00399         else
00400                 err ("variable length character initialization");
00401 
00402     if (array_comment)
00403         nice_printf (outfile, "%s", array_comment);
00404 
00405     nice_printf (outfile, " = ");
00406     wr_output_values (outfile, namep, values);
00407     ch_ar_dim = -1;
00408     nice_printf (outfile, ";\n");
00409  done:
00410     frchain(Values);
00411 } /* wr_one_init */
00412 
00413 
00414 
00415 
00416  chainp
00417 #ifdef KR_headers
00418 data_value(infile, offset, type)
00419         FILE *infile;
00420         ftnint offset;
00421         int type;
00422 #else
00423 data_value(FILE *infile, ftnint offset, int type)
00424 #endif
00425 {
00426     char line[MAX_INIT_LINE + 1], *pointer;
00427     chainp vals, prev_val;
00428     char *newval;
00429 
00430     if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
00431         err ("data_value:  error reading from intermediate file");
00432         return CHNULL;
00433     } /* if fgets */
00434 
00435 /* Get rid of the trailing newline */
00436 
00437     if (line[0])
00438         line[strlen (line) - 1] = '\0';
00439 
00440 #define iswhite(x) (isspace (x) || (x) == ',')
00441 
00442     pointer = line;
00443     prev_val = vals = CHNULL;
00444 
00445     while (*pointer) {
00446         register char *end_ptr, old_val;
00447 
00448 /* Move   pointer   to the start of the next word */
00449 
00450         while (*pointer && iswhite (*pointer))
00451             pointer++;
00452         if (*pointer == '\0')
00453             break;
00454 
00455 /* Move   end_ptr   to the end of the current word */
00456 
00457         for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
00458                 end_ptr++)
00459             ;
00460 
00461         old_val = *end_ptr;
00462         *end_ptr = '\0';
00463 
00464 /* Add this value to the end of the list */
00465 
00466         if (ONEOF(type, MSKREAL|MSKCOMPLEX))
00467                 newval = cpstring(pointer);
00468         else
00469                 newval = (char *)atol(pointer);
00470         if (vals) {
00471             prev_val->nextp = mkchain(newval, CHNULL);
00472             prev_val = prev_val -> nextp;
00473         } else
00474             prev_val = vals = mkchain(newval, CHNULL);
00475         *end_ptr = old_val;
00476         pointer = end_ptr;
00477     } /* while *pointer */
00478 
00479     return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
00480 } /* data_value */
00481 
00482  static void
00483 overlapping(Void)
00484 {
00485         extern char *filename0;
00486         static int warned = 0;
00487 
00488         if (warned)
00489                 return;
00490         warned = 1;
00491 
00492         fprintf(stderr, "Error");
00493         if (filename0)
00494                 fprintf(stderr, " in file %s", filename0);
00495         fprintf(stderr, ": overlapping initializations\n");
00496         nerr++;
00497         }
00498 
00499  static void make_one_const Argdcl((int, union Constant*, chainp));
00500  static long charlen;
00501 
00502  void
00503 #ifdef KR_headers
00504 wr_output_values(outfile, namep, values)
00505         FILE *outfile;
00506         Namep namep;
00507         chainp values;
00508 #else
00509 wr_output_values(FILE *outfile, Namep namep, chainp values)
00510 #endif
00511 {
00512         int type = TYUNKNOWN;
00513         struct Constblock Const;
00514         static expptr Vlen;
00515 
00516         if (namep)
00517                 type = namep -> vtype;
00518 
00519 /* Handle array initializations away from scalars */
00520 
00521         if (namep && namep -> vdim)
00522                 wr_array_init (outfile, namep -> vtype, values);
00523 
00524         else if (values->nextp && type != TYCHAR)
00525                 overlapping();
00526 
00527         else {
00528                 make_one_const(type, &Const.Const, values);
00529                 Const.vtype = type;
00530                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
00531                 if (type== TYCHAR) {
00532                         if (!Vlen)
00533                                 Vlen = ICON(0);
00534                         Const.vleng = Vlen;
00535                         Vlen->constblock.Const.ci = charlen;
00536                         out_const (outfile, &Const);
00537                         free (Const.Const.ccp);
00538                         }
00539                 else
00540                         out_const (outfile, &Const);
00541                 }
00542         }
00543 
00544 
00545  void
00546 #ifdef KR_headers
00547 wr_array_init(outfile, type, values)
00548         FILE *outfile;
00549         int type;
00550         chainp values;
00551 #else
00552 wr_array_init(FILE *outfile, int type, chainp values)
00553 #endif
00554 {
00555     int size = typesize[type];
00556     long index, main_index = 0;
00557     int k;
00558 
00559     if (type == TYCHAR) {
00560         nice_printf(outfile, "\"");
00561         k = 0;
00562         if (Ansi != 1)
00563                 ch_ar_dim = -1;
00564         }
00565     else
00566         nice_printf (outfile, "{ ");
00567     while (values) {
00568         struct Constblock Const;
00569 
00570         index = ((long) ((chainp) values->datap)->datap) / size;
00571         while (index > main_index) {
00572 
00573 /* Fill with zeros.  The structure shorthand works because the compiler
00574    will expand the "0" in braces to fill the size of the entire structure
00575    */
00576 
00577             switch (type) {
00578                 case TYREAL:
00579                 case TYDREAL:
00580                     nice_printf (outfile, "0.0,");
00581                     break;
00582                 case TYCOMPLEX:
00583                 case TYDCOMPLEX:
00584                     nice_printf (outfile, "{0},");
00585                     break;
00586                 case TYCHAR:
00587                         nice_printf(outfile, " ");
00588                         break;
00589                 default:
00590                     nice_printf (outfile, "0,");
00591                     break;
00592             } /* switch */
00593             main_index++;
00594         } /* while index > main_index */
00595 
00596         if (index < main_index)
00597                 overlapping();
00598         else switch (type) {
00599             case TYCHAR:
00600                 { int this_char;
00601 
00602                 if (k == ch_ar_dim) {
00603                         nice_printf(outfile, "\" \"");
00604                         k = 0;
00605                         }
00606                 this_char = (int) ((chainp) values->datap)->
00607                                 nextp->nextp->datap;
00608                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
00609                         main_index += this_char;
00610                         k += this_char;
00611                         while(--this_char >= 0)
00612                                 nice_printf(outfile, " ");
00613                         values = values -> nextp;
00614                         continue;
00615                         }
00616                 nice_printf(outfile, str_fmt[this_char], this_char);
00617                 k++;
00618                 } /* case TYCHAR */
00619                 break;
00620 
00621             case TYINT1:
00622             case TYSHORT:
00623             case TYLONG:
00624 #ifdef TYQUAD
00625             case TYQUAD:
00626 #endif
00627             case TYREAL:
00628             case TYDREAL:
00629             case TYLOGICAL:
00630             case TYLOGICAL1:
00631             case TYLOGICAL2:
00632             case TYCOMPLEX:
00633             case TYDCOMPLEX:
00634                 make_one_const(type, &Const.Const, values);
00635                 Const.vtype = type;
00636                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
00637                 out_const(outfile, &Const);
00638                 break;
00639             default:
00640                 erri("wr_array_init: bad type '%d'", type);
00641                 break;
00642         } /* switch */
00643         values = values->nextp;
00644 
00645         main_index++;
00646         if (values && type != TYCHAR)
00647             nice_printf (outfile, ",");
00648     } /* while values */
00649 
00650     if (type == TYCHAR) {
00651         nice_printf(outfile, "\"");
00652         }
00653     else
00654         nice_printf (outfile, " }");
00655 } /* wr_array_init */
00656 
00657 
00658  static void
00659 #ifdef KR_headers
00660 make_one_const(type, storage, values)
00661         int type;
00662         union Constant *storage;
00663         chainp values;
00664 #else
00665 make_one_const(int type, union Constant *storage, chainp values)
00666 #endif
00667 {
00668     union Constant *Const;
00669     register char **L;
00670 
00671     if (type == TYCHAR) {
00672         char *str, *str_ptr;
00673         chainp v, prev;
00674         int b = 0, k, main_index = 0;
00675 
00676 /* Find the max length of init string, by finding the highest offset
00677    value stored in the list of initial values */
00678 
00679         for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
00680             ;
00681         if (prev != CHNULL)
00682             k = ((int) (((chainp) prev->datap)->datap)) + 2;
00683                 /* + 2 above for null char at end */
00684         str = Alloc (k);
00685         for (str_ptr = str; values; str_ptr++) {
00686             int index = (int) (((chainp) values->datap)->datap);
00687 
00688             if (index < main_index)
00689                 overlapping();
00690             while (index > main_index++)
00691                 *str_ptr++ = ' ';
00692 
00693                 k = (int) (((chainp) values->datap)->nextp->nextp->datap);
00694                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
00695                         b = k;
00696                         break;
00697                         }
00698                 *str_ptr = k;
00699                 values = values -> nextp;
00700         } /* for str_ptr */
00701         *str_ptr = '\0';
00702         Const = storage;
00703         Const -> ccp = str;
00704         Const -> ccp1.blanks = b;
00705         charlen = str_ptr - str;
00706     } else {
00707         int i = 0;
00708         chainp vals;
00709 
00710         vals = ((chainp)values->datap)->nextp->nextp;
00711         if (vals) {
00712                 L = (char **)storage;
00713                 do L[i++] = vals->datap;
00714                         while(vals = vals->nextp);
00715                 }
00716 
00717     } /* else */
00718 
00719 } /* make_one_const */
00720 
00721 
00722  int
00723 #ifdef KR_headers
00724 rdname(infile, vargroupp, name)
00725         FILE *infile;
00726         int *vargroupp;
00727         char *name;
00728 #else
00729 rdname(FILE *infile, int *vargroupp, char *name)
00730 #endif
00731 {
00732     register int i, c;
00733 
00734     c = getc (infile);
00735 
00736     if (feof (infile))
00737         return NO;
00738 
00739     *vargroupp = c - '0';
00740     for (i = 1;; i++) {
00741         if (i >= NAME_MAX)
00742                 Fatal("rdname: oversize name");
00743         c = getc (infile);
00744         if (feof (infile))
00745             return NO;
00746         if (c == '\t')
00747                 break;
00748         *name++ = c;
00749     }
00750     *name = 0;
00751     return YES;
00752 } /* rdname */
00753 
00754  int
00755 #ifdef KR_headers
00756 rdlong(infile, n)
00757         FILE *infile;
00758         ftnint *n;
00759 #else
00760 rdlong(FILE *infile, ftnint *n)
00761 #endif
00762 {
00763     register int c;
00764 
00765     for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
00766         ;
00767 
00768     if (feof (infile))
00769         return NO;
00770 
00771     for (*n = 0; isdigit (c); c = getc (infile))
00772         *n = 10 * (*n) + c - '0';
00773     return YES;
00774 } /* rdlong */
00775 
00776 
00777  static int
00778 #ifdef KR_headers
00779 memno2info(memno, info)
00780         int memno;
00781         Namep *info;
00782 #else
00783 memno2info(int memno, Namep *info)
00784 #endif
00785 {
00786     chainp this_var;
00787     extern chainp new_vars;
00788     extern struct Hashentry *hashtab, *lasthash;
00789     struct Hashentry *entry;
00790 
00791     for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
00792         Addrp var = (Addrp) this_var->datap;
00793 
00794         if (var == (Addrp) NULL)
00795             Fatal("memno2info:  null variable");
00796         else if (var -> tag != TADDR)
00797             Fatal("memno2info:  bad tag");
00798         if (memno == var -> memno) {
00799             *info = (Namep) var;
00800             return 1;
00801         } /* if memno == var -> memno */
00802     } /* for this_var = new_vars */
00803 
00804     for (entry = hashtab; entry < lasthash; ++entry) {
00805         Namep var = entry -> varp;
00806 
00807         if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
00808             *info = (Namep) var;
00809             return 0;
00810         } /* if entry -> vardesc.varno == memno */
00811     } /* for entry = hashtab */
00812 
00813     Fatal("memno2info:  couldn't find memno");
00814     return 0;
00815 } /* memno2info */
00816 
00817  static chainp
00818 #ifdef KR_headers
00819 do_string(outfile, v, nloc)
00820         FILE *outfile;
00821         register chainp v;
00822         ftnint *nloc;
00823 #else
00824 do_string(FILE *outfile, register chainp v, ftnint *nloc)
00825 #endif
00826 {
00827         register chainp cp, v0;
00828         ftnint dloc, k, loc;
00829         unsigned long uk;
00830         char buf[8], *comma;
00831 
00832         nice_printf(outfile, "{");
00833         cp = (chainp)v->datap;
00834         loc = (ftnint)cp->datap;
00835         comma = "";
00836         for(v0 = v;;) {
00837                 switch((int)cp->nextp->datap) {
00838                         case TYBLANK:
00839                                 k = (ftnint)cp->nextp->nextp->datap;
00840                                 loc += k;
00841                                 while(--k >= 0) {
00842                                         nice_printf(outfile, "%s' '", comma);
00843                                         comma = ", ";
00844                                         }
00845                                 break;
00846                         case TYCHAR:
00847                                 uk = (ftnint)cp->nextp->nextp->datap;
00848                                 sprintf(buf, chr_fmt[uk], uk);
00849                                 nice_printf(outfile, "%s'%s'", comma, buf);
00850                                 comma = ", ";
00851                                 loc++;
00852                                 break;
00853                         default:
00854                                 goto done;
00855                         }
00856                 v0 = v;
00857                 if (!(v = v->nextp) || !(cp = (chainp)v->datap))
00858                         break;
00859                 dloc = (ftnint)cp->datap;
00860                 if (loc != dloc)
00861                         break;
00862                 }
00863  done:
00864         nice_printf(outfile, "}");
00865         *nloc = loc;
00866         return v0;
00867         }
00868 
00869  static chainp
00870 #ifdef KR_headers
00871 Ado_string(outfile, v, nloc)
00872         FILE *outfile;
00873         register chainp v;
00874         ftnint *nloc;
00875 #else
00876 Ado_string(FILE *outfile, register chainp v, ftnint *nloc)
00877 #endif
00878 {
00879         register chainp cp, v0;
00880         ftnint dloc, k, loc;
00881 
00882         nice_printf(outfile, "\"");
00883         cp = (chainp)v->datap;
00884         loc = (ftnint)cp->datap;
00885         for(v0 = v;;) {
00886                 switch((int)cp->nextp->datap) {
00887                         case TYBLANK:
00888                                 k = (ftnint)cp->nextp->nextp->datap;
00889                                 loc += k;
00890                                 while(--k >= 0)
00891                                         nice_printf(outfile, " ");
00892                                 break;
00893                         case TYCHAR:
00894                                 k = (ftnint)cp->nextp->nextp->datap;
00895                                 nice_printf(outfile, str_fmt[k], k);
00896                                 loc++;
00897                                 break;
00898                         default:
00899                                 goto done;
00900                         }
00901                 v0 = v;
00902                 if (!(v = v->nextp) || !(cp = (chainp)v->datap))
00903                         break;
00904                 dloc = (ftnint)cp->datap;
00905                 if (loc != dloc)
00906                         break;
00907                 }
00908  done:
00909         nice_printf(outfile, "\"");
00910         *nloc = loc;
00911         return v0;
00912         }
00913 
00914  static char *
00915 #ifdef KR_headers
00916 Len(L, type)
00917         long L;
00918         int type;
00919 #else
00920 Len(long L, int type)
00921 #endif
00922 {
00923         static char buf[24];
00924         if (L == 1 && type != TYCHAR)
00925                 return "";
00926         sprintf(buf, "[%ld]", L);
00927         return buf;
00928         }
00929 
00930  void
00931 #ifdef KR_headers
00932 wr_equiv_init(outfile, memno, Values, iscomm)
00933         FILE *outfile;
00934         int memno;
00935         chainp *Values;
00936         int iscomm;
00937 #else
00938 wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
00939 #endif
00940 {
00941         struct Equivblock *eqv;
00942         int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
00943         static char Blank[] = "";
00944         register char *comma = Blank;
00945         register chainp cp, v;
00946         chainp sentinel, values, v1, vlast;
00947         ftnint L, L1, dL, dloc, loc, loc0;
00948         union Constant Const;
00949         char imag_buf[50], real_buf[50];
00950         int szshort = typesize[TYSHORT];
00951         static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
00952 #ifdef TYQUAD
00953                                   TYQUAD,
00954 #endif
00955                                   TYREAL, TYDREAL, TYREAL, TYDREAL,
00956                                   TYLOGICAL1, TYLOGICAL2,
00957                                   TYLOGICAL, TYCHAR};
00958         static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
00959 #ifdef TYQUAD
00960                                   TYDREAL,
00961 #endif
00962                                   TYLONG, TYDREAL, TYLONG, TYDREAL,
00963                                   TYCHAR, TYSHORT,
00964                                   TYLONG, TYCHAR, 0 /* for TYBLANK */ };
00965         extern int htype;
00966         char *z;
00967 
00968         /* add sentinel */
00969         if (iscomm) {
00970                 L = extsymtab[memno].maxleng;
00971                 xtype = extsymtab[memno].extype;
00972                 }
00973         else {
00974                 eqv = &eqvclass[memno];
00975                 L = eqv->eqvtop - eqv->eqvbottom;
00976                 xtype = eqv->eqvtype;
00977                 }
00978 
00979         if (halign && typealign[typepref[xtype]] < typealign[htype])
00980                 xtype = htype;
00981         *Values = values = revchain(vlast = *Values);
00982 
00983         if (xtype != TYCHAR) {
00984 
00985                 /* unless the data include a value of the appropriate
00986                  * type, we add an extra element in an attempt
00987                  * to force correct alignment */
00988 
00989                 btype = basetype[xtype];
00990                 loc = 0;
00991                 for(v = *Values;;v = v->nextp) {
00992                         if (!v) {
00993                                 dtype = typepref[xtype];
00994                                 z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
00995                                 k = typesize[dtype];
00996                                 if (j = L % k)
00997                                         L += k - j;
00998                                 v = mkchain((char *)L,
00999                                         mkchain((char *)LONG_CAST dtype,
01000                                                 mkchain(z, CHNULL)));
01001                                 vlast = vlast->nextp =
01002                                         mkchain((char *)v, CHNULL);
01003                                 L += k;
01004                                 break;
01005                                 }
01006                         cp = (chainp)v->datap;
01007                         if (basetype[(int)cp->nextp->datap] == btype)
01008                                 break;
01009                         dloc = (ftnint)cp->datap;
01010                         L1 = dloc - loc;
01011                         if (L1 > 0
01012                          && !(L1 % szshort)
01013                          && !(loc % szshort)
01014                          && btype <= type_choice[L1/szshort % 4]
01015                          && btype <= type_choice[loc/szshort % 4])
01016                                 break;
01017                         dtype = (int)cp->nextp->datap;
01018                         loc = dloc + dtype == TYBLANK
01019                                         ? (ftnint)cp->nextp->nextp->datap
01020                                         : typesize[dtype];
01021                         }
01022                 }
01023         sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
01024         vlast->nextp = mkchain((char *)sentinel, CHNULL);
01025 
01026         /* use doublereal fillers only if there are doublereal values */
01027 
01028         k = TYLONG;
01029         for(v = values; v; v = v->nextp)
01030                 if (ONEOF((int)((chainp)v->datap)->nextp->datap,
01031                                 M(TYDREAL)|M(TYDCOMPLEX))) {
01032                         k = TYDREAL;
01033                         break;
01034                         }
01035         type_choice[0] = k;
01036 
01037         nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
01038         next_tab(outfile);
01039         loc = loc0 = k = 0;
01040         curtype = -1;
01041         for(v = values; v; v = v->nextp) {
01042                 cp = (chainp)v->datap;
01043                 dloc = (ftnint)cp->datap;
01044                 L = dloc - loc;
01045                 if (L < 0) {
01046                         overlapping();
01047                         if ((int)cp->nextp->datap != TYERROR) {
01048                                 v1 = cp;
01049                                 frchain(&v1);
01050                                 v->datap = 0;
01051                                 }
01052                         continue;
01053                         }
01054                 dtype = (int)cp->nextp->datap;
01055                 if (dtype == TYBLANK) {
01056                         dtype = TYCHAR;
01057                         wasblank = 1;
01058                         }
01059                 else
01060                         wasblank = 0;
01061                 if (curtype != dtype || L > 0) {
01062                         if (curtype != -1) {
01063                                 L1 = (loc - loc0)/dL;
01064                                 nice_printf(outfile, "%s e_%d%s;\n",
01065                                         typename[curtype], ++k,
01066                                         Len(L1,curtype));
01067                                 }
01068                         curtype = dtype;
01069                         loc0 = dloc;
01070                         }
01071                 if (L > 0) {
01072                         if (xtype == TYCHAR)
01073                                 filltype = TYCHAR;
01074                         else {
01075                                 filltype = L % szshort ? TYCHAR
01076                                                 : type_choice[L/szshort % 4];
01077                                 filltype1 = loc % szshort ? TYCHAR
01078                                                 : type_choice[loc/szshort % 4];
01079                                 if (typesize[filltype] > typesize[filltype1])
01080                                         filltype = filltype1;
01081                                 }
01082                         L1 = L / typesize[filltype];
01083                         nice_printf(outfile, "%s fill_%d[%ld];\n",
01084                                 typename[filltype], ++k, L1);
01085                         loc = dloc;
01086                         }
01087                 if (wasblank) {
01088                         loc += (ftnint)cp->nextp->nextp->datap;
01089                         dL = 1;
01090                         }
01091                 else {
01092                         dL = typesize[dtype];
01093                         loc += dL;
01094                         }
01095                 }
01096         nice_printf(outfile, "} %s = { ", iscomm
01097                 ? extsymtab[memno].cextname
01098                 : equiv_name(eqvmemno, CNULL));
01099         loc = 0;
01100         for(v = values; ; v = v->nextp) {
01101                 cp = (chainp)v->datap;
01102                 if (!cp)
01103                         continue;
01104                 dtype = (int)cp->nextp->datap;
01105                 if (dtype == TYERROR)
01106                         break;
01107                 dloc = (ftnint)cp->datap;
01108                 if (dloc > loc) {
01109                         nice_printf(outfile, "%s{0}", comma);
01110                         comma = ", ";
01111                         loc = dloc;
01112                         }
01113                 if (comma != Blank)
01114                         nice_printf(outfile, ", ");
01115                 comma = ", ";
01116                 if (dtype == TYCHAR || dtype == TYBLANK) {
01117                         v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
01118                                         :  do_string(outfile, v, &loc);
01119                         continue;
01120                         }
01121                 make_one_const(dtype, &Const, v);
01122                 switch(dtype) {
01123                         case TYLOGICAL:
01124                         case TYLOGICAL2:
01125                         case TYLOGICAL1:
01126                                 if (Const.ci < 0 || Const.ci > 1)
01127                                         errl(
01128                           "wr_equiv_init: unexpected logical value %ld",
01129                                                 Const.ci);
01130                                 nice_printf(outfile,
01131                                         Const.ci ? "TRUE_" : "FALSE_");
01132                                 break;
01133                         case TYINT1:
01134                         case TYSHORT:
01135                         case TYLONG:
01136 #ifdef TYQUAD
01137                         case TYQUAD:
01138 #endif
01139                                 nice_printf(outfile, "%ld", Const.ci);
01140                                 break;
01141                         case TYREAL:
01142                                 nice_printf(outfile, "%s",
01143                                         flconst(real_buf, Const.cds[0]));
01144                                 break;
01145                         case TYDREAL:
01146                                 nice_printf(outfile, "%s", Const.cds[0]);
01147                                 break;
01148                         case TYCOMPLEX:
01149                                 nice_printf(outfile, "%s, %s",
01150                                         flconst(real_buf, Const.cds[0]),
01151                                         flconst(imag_buf, Const.cds[1]));
01152                                 break;
01153                         case TYDCOMPLEX:
01154                                 nice_printf(outfile, "%s, %s",
01155                                         Const.cds[0], Const.cds[1]);
01156                                 break;
01157                         default:
01158                                 erri("unexpected type %d in wr_equiv_init",
01159                                         dtype);
01160                         }
01161                 loc += typesize[dtype];
01162                 }
01163         nice_printf(outfile, " };\n\n");
01164         prev_tab(outfile);
01165         frchain(&sentinel);
01166         }