lang/fortran/comp/formatdata.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25 #include "output.h"
  26 #include "names.h"
  27 #include "format.h"
  28
  29 #define MAX_INIT_LINE 100
  30 #define NAME_MAX 64
  31
  32 static int memno2info();
  33
  34 extern char *initbname;
  35 extern void def_start();
  36
  37 void list_init_data(Infile, Inname, outfile)
  38  FILE **Infile, *outfile;
  39  char *Inname;
  40 {
  41     FILE *sortfp;
  42     int status;
  43
  44     fclose(*Infile);
  45     *Infile = 0;
  46
  47     if (status = dsort(Inname, sortfname))
  48         fatali ("sort failed, status %d", status);
  49
  50     scrub(Inname); /* optionally unlink Inname */
  51
  52     if ((sortfp = fopen(sortfname, textread)) == NULL)
  53         Fatal("Couldn't open sorted initialization data");
  54
  55     do_init_data(outfile, sortfp);
  56     fclose(sortfp);
  57     scrub(sortfname);
  58
  59 /* Insert a blank line after any initialized data */
  60
  61         nice_printf (outfile, "\n");
  62
  63     if (debugflag && infname)
  64          /* don't back block data file up -- it won't be overwritten */
  65         backup(initfname, initbname);
  66 } /* list_init_data */
  67
  68
  69
  70 /* do_init_data -- returns YES when at least one declaration has been
  71    written */
  72
  73 int do_init_data(outfile, infile)
  74 FILE *outfile, *infile;
  75 {
  76     char varname[NAME_MAX], ovarname[NAME_MAX];
  77     ftnint offset;
  78     ftnint type;
  79     int vargroup;       /* 0 --> init, 1 --> equiv, 2 --> common */
  80     int did_one = 0;            /* True when one has been output */
  81     chainp values = CHNULL;     /* Actual data values */
  82     int keepit = 0;
  83     Namep np;
  84
  85     ovarname[0] = '\0';
  86
  87     while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
  88             && rdlong (infile, &type)) {
  89         if (strcmp (varname, ovarname)) {
  90
  91         /* If this is a new variable name, the old initialization has been
  92            completed */
  93
  94                 wr_one_init(outfile, ovarname, &values, keepit);
  95
  96                 strcpy (ovarname, varname);
  97                 values = CHNULL;
  98                 if (vargroup == 0) {
  99                         if (memno2info(atoi(varname+2), &np)) {
 100                                 if (((Addrp)np)->uname_tag != UNAM_NAME) {
 101                                         err("do_init_data: expected NAME");
 102                                         goto Keep;
 103                                         }
 104                                 np = ((Addrp)np)->user.name;
 105                                 }
 106                         if (!(keepit = np->visused) && !np->vimpldovar)
 107                                 warn1("local variable %s never used",
 108                                         np->fvarname);
 109                         }
 110                 else {
 111  Keep:
 112                         keepit = 1;
 113                         }
 114                 if (keepit && !did_one) {
 115                         nice_printf (outfile, "/* Initialized data */\n\n");
 116                         did_one = YES;
 117                         }
 118         } /* if strcmp */
 119
 120         values = mkchain((char *)data_value(infile, offset, (int)type), values);
 121     } /* while */
 122
 123 /* Write out the last declaration */
 124
 125     wr_one_init (outfile, ovarname, &values, keepit);
 126
 127     return did_one;
 128 } /* do_init_data */
 129
 130
 131  ftnint
 132 wr_char_len(outfile, dimp, n, extra1)
 133  FILE *outfile;
 134  int n;
 135  struct Dimblock *dimp;
 136  int extra1;
 137 {
 138         int i, nd;
 139         expptr e;
 140         ftnint rv;
 141
 142         if (!dimp) {
 143                 nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
 144                 return n + extra1;
 145                 }
 146         nice_printf(outfile, "[%d", n);
 147         nd = dimp->ndim;
 148         rv = n;
 149         for(i = 0; i < nd; i++) {
 150                 e = dimp->dims[i].dimsize;
 151                 if (!ISICON (e))
 152                         err ("wr_char_len:  nonconstant array size");
 153                 else {
 154                         nice_printf(outfile, "*%ld", e->constblock.Const.ci);
 155                         rv *= e->constblock.Const.ci;
 156                         }
 157                 }
 158         /* extra1 allows for stupid C compilers that complain about
 159          * too many initializers in
 160          *      char x[2] = "ab";
 161          */
 162         nice_printf(outfile, extra1 ? "+1]" : "]");
 163         return extra1 ? rv+1 : rv;
 164         }
 165
 166  static int ch_ar_dim = -1; /* length of each element of char string array */
 167  static int eqvmemno;   /* kludge */
 168
 169  static void
 170 write_char_init(outfile, Values, namep)
 171  FILE *outfile;
 172  chainp *Values;
 173  Namep namep;
 174 {
 175         struct Equivblock *eqv;
 176         long size;
 177         struct Dimblock *dimp;
 178         int i, nd, type;
 179         expptr ds;
 180
 181         if (!namep)
 182                 return;
 183         if(nequiv >= maxequiv)
 184                 many("equivalences", 'q', maxequiv);
 185         eqv = &eqvclass[nequiv];
 186         eqv->eqvbottom = 0;
 187         type = namep->vtype;
 188         size = type == TYCHAR
 189                 ? namep->vleng->constblock.Const.ci
 190                 : typesize[type];
 191         if (dimp = namep->vdim)
 192                 for(i = 0, nd = dimp->ndim; i < nd; i++) {
 193                         ds = dimp->dims[i].dimsize;
 194                         if (!ISICON(ds))
 195                                 err("write_char_values: nonconstant array size");
 196                         else
 197                                 size *= ds->constblock.Const.ci;
 198                         }
 199         *Values = revchain(*Values);
 200         eqv->eqvtop = size;
 201         eqvmemno = ++lastvarno;
 202         eqv->eqvtype = type;
 203         wr_equiv_init(outfile, nequiv, Values, 0);
 204         def_start(outfile, namep->cvarname, CNULL, "");
 205         if (type == TYCHAR)
 206                 ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
 207         else
 208                 ind_printf(0, outfile, dimp
 209                         ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
 210                         c_type_decl(type,0), eqvmemno);
 211         }
 212
 213 /* wr_one_init -- outputs the initialization of the variable pointed to
 214    by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
 215    treat it as a Namep */
 216
 217 void wr_one_init (outfile, varname, Values, keepit)
 218 FILE *outfile;
 219 char *varname;
 220 chainp *Values;
 221 int keepit;
 222 {
 223     static int memno;
 224     static union {
 225         Namep name;
 226         Addrp addr;
 227     } info;
 228     Namep namep;
 229     int is_addr, size, type;
 230     ftnint last, loc;
 231     int is_scalar = 0;
 232     char *array_comment = NULL, *name;
 233     chainp cp, values;
 234     extern char datachar[];
 235     static int e1[3] = {1, 0, 1};
 236     ftnint x;
 237     extern int hsize;
 238
 239     if (!keepit)
 240         goto done;
 241     if (varname == NULL || varname[1] != '.')
 242         goto badvar;
 243
 244 /* Get back to a meaningful representation; find the given   memno in one
 245    of the appropriate tables (user-generated variables in the hash table,
 246    system-generated variables in a separate list */
 247
 248     memno = atoi(varname + 2);
 249     switch(varname[0]) {
 250         case 'q':
 251                 /* Must subtract eqvstart when the source file
 252                  * contains more than one procedure.
 253                  */
 254                 wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
 255                 goto done;
 256         case 'Q':
 257                 /* COMMON initialization (BLOCK DATA) */
 258                 wr_equiv_init(outfile, memno, Values, 1);
 259                 goto done;
 260         case 'v':
 261                 break;
 262         default:
 263  badvar:
 264                 errstr("wr_one_init:  unknown variable name '%s'", varname);
 265                 goto done;
 266         }
 267
 268     is_addr = memno2info (memno, &info.name);
 269     if (info.name == (Namep) NULL) {
 270         err ("wr_one_init -- unknown variable");
 271         return;
 272         }
 273     if (is_addr) {
 274         if (info.addr -> uname_tag != UNAM_NAME) {
 275             erri ("wr_one_init -- couldn't get name pointer; tag is %d",
 276                     info.addr -> uname_tag);
 277             namep = (Namep) NULL;
 278             nice_printf (outfile, " /* bad init data */");
 279         } else
 280             namep = info.addr -> user.name;
 281     } else
 282         namep = info.name;
 283
 284         /* check for character initialization */
 285
 286     *Values = values = revchain(*Values);
 287     type = info.name->vtype;
 288     if (type == TYCHAR) {
 289         for(last = 0; values; values = values->nextp) {
 290                 cp = (chainp)values->datap;
 291                 loc = (ftnint)cp->datap;
 292                 if (loc > last) {
 293                         write_char_init(outfile, Values, namep);
 294                         goto done;
 295                         }
 296                 last = (int)cp->nextp->datap == TYBLANK
 297                         ? loc + (int)cp->nextp->nextp->datap
 298                         : loc + 1;
 299                 }
 300         if (halign && info.name->tag == TNAME) {
 301                 nice_printf(outfile, "static struct { %s fill; char val",
 302                         halign);
 303                 x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
 304                         info.name -> vleng -> constblock.Const.ci, 1);
 305                 if (x %= hsize)
 306                         nice_printf(outfile, "; char fill2[%ld]", hsize - x);
 307                 name = info.name->cvarname;
 308                 nice_printf(outfile, "; } %s_st = { 0,", name);
 309                 wr_output_values(outfile, namep, *Values);
 310                 nice_printf(outfile, " };\n");
 311                 ch_ar_dim = -1;
 312                 def_start(outfile, name, CNULL, name);
 313                 ind_printf(0, outfile, "_st.val\n");
 314                 goto done;
 315                 }
 316         }
 317     else {
 318         size = typesize[type];
 319         loc = 0;
 320         for(; values; values = values->nextp) {
 321                 if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
 322                         write_char_init(outfile, Values, namep);
 323                         goto done;
 324                         }
 325                 last = ((long) ((chainp) values->datap)->datap) / size;
 326                 if (last - loc > 4) {
 327                         write_char_init(outfile, Values, namep);
 328                         goto done;
 329                         }
 330                 loc = last;
 331                 }
 332         }
 333     values = *Values;
 334
 335     nice_printf (outfile, "static %s ", c_type_decl (type, 0));
 336
 337     if (is_addr)
 338         write_nv_ident (outfile, info.addr);
 339     else
 340         out_name (outfile, info.name);
 341
 342     if (namep)
 343         is_scalar = namep -> vdim == (struct Dimblock *) NULL;
 344
 345     if (namep && !is_scalar)
 346         array_comment = type == TYCHAR
 347                 ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
 348
 349     if (type == TYCHAR)
 350         if (ISICON (info.name -> vleng))
 351
 352 /* We'll make single strings one character longer, so that we can use the
 353    standard C initialization.  All this does is pad an extra zero onto the
 354    end of the string */
 355                 wr_char_len(outfile, namep->vdim, ch_ar_dim =
 356                         info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
 357         else
 358                 err ("variable length character initialization");
 359
 360     if (array_comment)
 361         nice_printf (outfile, "%s", array_comment);
 362
 363     nice_printf (outfile, " = ");
 364     wr_output_values (outfile, namep, values);
 365     ch_ar_dim = -1;
 366     nice_printf (outfile, ";\n");
 367  done:
 368     frchain(Values);
 369 } /* wr_one_init */
 370
 371
 372
 373
 374 chainp data_value (infile, offset, type)
 375 FILE *infile;
 376 ftnint offset;
 377 int type;
 378 {
 379     char line[MAX_INIT_LINE + 1], *pointer;
 380     chainp vals, prev_val;
 381     long atol();
 382     char *newval;
 383
 384     if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
 385         err ("data_value:  error reading from intermediate file");
 386         return CHNULL;
 387     } /* if fgets */
 388
 389 /* Get rid of the trailing newline */
 390
 391     if (line[0])
 392         line[strlen (line) - 1] = '\0';
 393
 394 #define iswhite(x) (isspace (x) || (x) == ',')
 395
 396     pointer = line;
 397     prev_val = vals = CHNULL;
 398
 399     while (*pointer) {
 400         register char *end_ptr, old_val;
 401
 402 /* Move   pointer   to the start of the next word */
 403
 404         while (*pointer && iswhite (*pointer))
 405             pointer++;
 406         if (*pointer == '\0')
 407             break;
 408
 409 /* Move   end_ptr   to the end of the current word */
 410
 411         for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
 412                 end_ptr++)
 413             ;
 414
 415         old_val = *end_ptr;
 416         *end_ptr = '\0';
 417
 418 /* Add this value to the end of the list */
 419
 420         if (ONEOF(type, MSKREAL|MSKCOMPLEX))
 421                 newval = cpstring(pointer);
 422         else
 423                 newval = (char *)atol(pointer);
 424         if (vals) {
 425             prev_val->nextp = mkchain(newval, CHNULL);
 426             prev_val = prev_val -> nextp;
 427         } else
 428             prev_val = vals = mkchain(newval, CHNULL);
 429         *end_ptr = old_val;
 430         pointer = end_ptr;
 431     } /* while *pointer */
 432
 433     return mkchain((char *)offset, mkchain((char *)type, vals));
 434 } /* data_value */
 435
 436  static void
 437 overlapping()
 438 {
 439         extern char *filename0;
 440         static int warned = 0;
 441
 442         if (warned)
 443                 return;
 444         warned = 1;
 445
 446         fprintf(stderr, "Error");
 447         if (filename0)
 448                 fprintf(stderr, " in file %s", filename0);
 449         fprintf(stderr, ": overlapping initializations\n");
 450         nerr++;
 451         }
 452
 453  static void make_one_const();
 454  static long charlen;
 455
 456 void wr_output_values (outfile, namep, values)
 457 FILE *outfile;
 458 Namep namep;
 459 chainp values;
 460 {
 461         int type = TYUNKNOWN;
 462         struct Constblock Const;
 463         static expptr Vlen;
 464
 465         if (namep)
 466                 type = namep -> vtype;
 467
 468 /* Handle array initializations away from scalars */
 469
 470         if (namep && namep -> vdim)
 471                 wr_array_init (outfile, namep -> vtype, values);
 472
 473         else if (values->nextp && type != TYCHAR)
 474                 overlapping();
 475
 476         else {
 477                 make_one_const(type, &Const.Const, values);
 478                 Const.vtype = type;
 479                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
 480                 if (type== TYCHAR) {
 481                         if (!Vlen)
 482                                 Vlen = ICON(0);
 483                         Const.vleng = Vlen;
 484                         Vlen->constblock.Const.ci = charlen;
 485                         out_const (outfile, &Const);
 486                         free (Const.Const.ccp);
 487                         }
 488                 else
 489                         out_const (outfile, &Const);
 490                 }
 491         }
 492
 493
 494 wr_array_init (outfile, type, values)
 495 FILE *outfile;
 496 int type;
 497 chainp values;
 498 {
 499     int size = typesize[type];
 500     long index, main_index = 0;
 501     int k;
 502
 503     if (type == TYCHAR) {
 504         nice_printf(outfile, "\"");
 505         k = 0;
 506         if (Ansi != 1)
 507                 ch_ar_dim = -1;
 508         }
 509     else
 510         nice_printf (outfile, "{ ");
 511     while (values) {
 512         struct Constblock Const;
 513
 514         index = ((long) ((chainp) values->datap)->datap) / size;
 515         while (index > main_index) {
 516
 517 /* Fill with zeros.  The structure shorthand works because the compiler
 518    will expand the "0" in braces to fill the size of the entire structure
 519    */
 520
 521             switch (type) {
 522                 case TYREAL:
 523                 case TYDREAL:
 524                     nice_printf (outfile, "0.0,");
 525                     break;
 526                 case TYCOMPLEX:
 527                 case TYDCOMPLEX:
 528                     nice_printf (outfile, "{0},");
 529                     break;
 530                 case TYCHAR:
 531                         nice_printf(outfile, " ");
 532                         break;
 533                 default:
 534                     nice_printf (outfile, "0,");
 535                     break;
 536             } /* switch */
 537             main_index++;
 538         } /* while index > main_index */
 539
 540         if (index < main_index)
 541                 overlapping();
 542         else switch (type) {
 543             case TYCHAR:
 544                 { int this_char;
 545
 546                 if (k == ch_ar_dim) {
 547                         nice_printf(outfile, "\" \"");
 548                         k = 0;
 549                         }
 550                 this_char = (int) ((chainp) values->datap)->
 551                                 nextp->nextp->datap;
 552                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
 553                         main_index += this_char;
 554                         k += this_char;
 555                         while(--this_char >= 0)
 556                                 nice_printf(outfile, " ");
 557                         values = values -> nextp;
 558                         continue;
 559                         }
 560                 nice_printf(outfile, str_fmt[this_char], this_char);
 561                 k++;
 562                 } /* case TYCHAR */
 563                 break;
 564
 565             case TYSHORT:
 566             case TYLONG:
 567             case TYREAL:
 568             case TYDREAL:
 569             case TYLOGICAL:
 570             case TYCOMPLEX:
 571             case TYDCOMPLEX:
 572                 make_one_const(type, &Const.Const, values);
 573                 Const.vtype = type;
 574                 Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
 575                 out_const(outfile, &Const);
 576                 break;
 577             default:
 578                 erri("wr_array_init: bad type '%d'", type);
 579                 break;
 580         } /* switch */
 581         values = values->nextp;
 582
 583         main_index++;
 584         if (values && type != TYCHAR)
 585             nice_printf (outfile, ",");
 586     } /* while values */
 587
 588     if (type == TYCHAR) {
 589         nice_printf(outfile, "\"");
 590         }
 591     else
 592         nice_printf (outfile, " }");
 593 } /* wr_array_init */
 594
 595
 596  static void
 597 make_one_const(type, storage, values)
 598  int type;
 599  union Constant *storage;
 600  chainp values;
 601 {
 602     union Constant *Const;
 603     register char **L;
 604
 605     if (type == TYCHAR) {
 606         char *str, *str_ptr;
 607         chainp v, prev;
 608         int b = 0, k, main_index = 0;
 609
 610 /* Find the max length of init string, by finding the highest offset
 611    value stored in the list of initial values */
 612
 613         for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
 614             ;
 615         if (prev != CHNULL)
 616             k = ((int) (((chainp) prev->datap)->datap)) + 2;
 617                 /* + 2 above for null char at end */
 618         str = Alloc (k);
 619         for (str_ptr = str; values; str_ptr++) {
 620             int index = (int) (((chainp) values->datap)->datap);
 621
 622             if (index < main_index)
 623                 overlapping();
 624             while (index > main_index++)
 625                 *str_ptr++ = ' ';
 626
 627                 k = (int) (((chainp) values->datap)->nextp->nextp->datap);
 628                 if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
 629                         b = k;
 630                         break;
 631                         }
 632                 *str_ptr = k;
 633                 values = values -> nextp;
 634         } /* for str_ptr */
 635         *str_ptr = '\0';
 636         Const = storage;
 637         Const -> ccp = str;
 638         Const -> ccp1.blanks = b;
 639         charlen = str_ptr - str;
 640     } else {
 641         int i = 0;
 642         chainp vals;
 643
 644         vals = ((chainp)values->datap)->nextp->nextp;
 645         if (vals) {
 646                 L = (char **)storage;
 647                 do L[i++] = vals->datap;
 648                         while(vals = vals->nextp);
 649                 }
 650
 651     } /* else */
 652
 653 } /* make_one_const */
 654
 655
 656
 657 rdname (infile, vargroupp, name)
 658 FILE *infile;
 659 int *vargroupp;
 660 char *name;
 661 {
 662     register int i, c;
 663
 664     c = getc (infile);
 665
 666     if (feof (infile))
 667         return NO;
 668
 669     *vargroupp = c - '0';
 670     for (i = 1;; i++) {
 671         if (i >= NAME_MAX)
 672                 Fatal("rdname: oversize name");
 673         c = getc (infile);
 674         if (feof (infile))
 675             return NO;
 676         if (c == '\t')
 677                 break;
 678         *name++ = c;
 679     }
 680     *name = 0;
 681     return YES;
 682 } /* rdname */
 683
 684 rdlong (infile, n)
 685 FILE *infile;
 686 ftnint *n;
 687 {
 688     register int c;
 689
 690     for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
 691         ;
 692
 693     if (feof (infile))
 694         return NO;
 695
 696     for (*n = 0; isdigit (c); c = getc (infile))
 697         *n = 10 * (*n) + c - '0';
 698     return YES;
 699 } /* rdlong */
 700
 701
 702  static int
 703 memno2info (memno, info)
 704  int memno;
 705  Namep *info;
 706 {
 707     chainp this_var;
 708     extern chainp new_vars;
 709     extern struct Hashentry *hashtab, *lasthash;
 710     struct Hashentry *entry;
 711
 712     for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
 713         Addrp var = (Addrp) this_var->datap;
 714
 715         if (var == (Addrp) NULL)
 716             Fatal("memno2info:  null variable");
 717         else if (var -> tag != TADDR)
 718             Fatal("memno2info:  bad tag");
 719         if (memno == var -> memno) {
 720             *info = (Namep) var;
 721             return 1;
 722         } /* if memno == var -> memno */
 723     } /* for this_var = new_vars */
 724
 725     for (entry = hashtab; entry < lasthash; ++entry) {
 726         Namep var = entry -> varp;
 727
 728         if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
 729             *info = (Namep) var;
 730             return 0;
 731         } /* if entry -> vardesc.varno == memno */
 732     } /* for entry = hashtab */
 733
 734     Fatal("memno2info:  couldn't find memno");
 735     return 0;
 736 } /* memno2info */
 737
 738  static chainp
 739 do_string(outfile, v, nloc)
 740  FILEP outfile;
 741  register chainp v;
 742  ftnint *nloc;
 743 {
 744         register chainp cp, v0;
 745         ftnint dloc, k, loc;
 746         unsigned long uk;
 747         char buf[8], *comma;
 748
 749         nice_printf(outfile, "{");
 750         cp = (chainp)v->datap;
 751         loc = (ftnint)cp->datap;
 752         comma = "";
 753         for(v0 = v;;) {
 754                 switch((int)cp->nextp->datap) {
 755                         case TYBLANK:
 756                                 k = (ftnint)cp->nextp->nextp->datap;
 757                                 loc += k;
 758                                 while(--k >= 0) {
 759                                         nice_printf(outfile, "%s' '", comma);
 760                                         comma = ", ";
 761                                         }
 762                                 break;
 763                         case TYCHAR:
 764                                 uk = (ftnint)cp->nextp->nextp->datap;
 765                                 sprintf(buf, chr_fmt[uk], uk);
 766                                 nice_printf(outfile, "%s'%s'", comma, buf);
 767                                 comma = ", ";
 768                                 loc++;
 769                                 break;
 770                         default:
 771                                 goto done;
 772                         }
 773                 v0 = v;
 774                 if (!(v = v->nextp))
 775                         break;
 776                 cp = (chainp)v->datap;
 777                 dloc = (ftnint)cp->datap;
 778                 if (loc != dloc)
 779                         break;
 780                 }
 781  done:
 782         nice_printf(outfile, "}");
 783         *nloc = loc;
 784         return v0;
 785         }
 786
 787  static chainp
 788 Ado_string(outfile, v, nloc)
 789  FILEP outfile;
 790  register chainp v;
 791  ftnint *nloc;
 792 {
 793         register chainp cp, v0;
 794         ftnint dloc, k, loc;
 795
 796         nice_printf(outfile, "\"");
 797         cp = (chainp)v->datap;
 798         loc = (ftnint)cp->datap;
 799         for(v0 = v;;) {
 800                 switch((int)cp->nextp->datap) {
 801                         case TYBLANK:
 802                                 k = (ftnint)cp->nextp->nextp->datap;
 803                                 loc += k;
 804                                 while(--k >= 0)
 805                                         nice_printf(outfile, " ");
 806                                 break;
 807                         case TYCHAR:
 808                                 k = (ftnint)cp->nextp->nextp->datap;
 809                                 nice_printf(outfile, str_fmt[k], k);
 810                                 loc++;
 811                                 break;
 812                         default:
 813                                 goto done;
 814                         }
 815                 v0 = v;
 816                 if (!(v = v->nextp))
 817                         break;
 818                 cp = (chainp)v->datap;
 819                 dloc = (ftnint)cp->datap;
 820                 if (loc != dloc)
 821                         break;
 822                 }
 823  done:
 824         nice_printf(outfile, "\"");
 825         *nloc = loc;
 826         return v0;
 827         }
 828
 829  static char *
 830 Len(L,type)
 831  long L;
 832  int type;
 833 {
 834         static char buf[24];
 835         if (L == 1 && type != TYCHAR)
 836                 return "";
 837         sprintf(buf, "[%ld]", L);
 838         return buf;
 839         }
 840
 841 wr_equiv_init(outfile, memno, Values, iscomm)
 842  FILE *outfile;
 843  int memno;
 844  chainp *Values;
 845  int iscomm;
 846 {
 847         struct Equivblock *eqv;
 848         char *equiv_name ();
 849         int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
 850         static char Blank[] = "";
 851         register char *comma = Blank;
 852         register chainp cp, v;
 853         chainp sentinel, values, v1;
 854         ftnint L, L1, dL, dloc, loc, loc0;
 855         union Constant Const;
 856         char imag_buf[50], real_buf[50];
 857         int szshort = typesize[TYSHORT];
 858         static char typepref[] = {0, 0, TYSHORT, TYLONG, TYREAL, TYDREAL,
 859                                   TYREAL, TYDREAL, TYLOGICAL, TYCHAR};
 860         extern int htype;
 861         char *z;
 862
 863         /* add sentinel */
 864         if (iscomm) {
 865                 L = extsymtab[memno].maxleng;
 866                 xtype = extsymtab[memno].extype;
 867                 }
 868         else {
 869                 eqv = &eqvclass[memno];
 870                 L = eqv->eqvtop - eqv->eqvbottom;
 871                 xtype = eqv->eqvtype;
 872                 }
 873
 874         if (halign && typealign[typepref[xtype]] < typealign[htype])
 875                 xtype = htype;
 876
 877         if (xtype != TYCHAR) {
 878
 879                 /* unless the data include a value of the appropriate
 880                  * type, we add an extra element in an attempt
 881                  * to force correct alignment */
 882
 883                 for(v = *Values;;v = v->nextp) {
 884                         if (!v) {
 885                                 dtype = typepref[xtype];
 886                                 z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
 887                                 k = typesize[dtype];
 888                                 if (j = L % k)
 889                                         L += k - j;
 890                                 v = mkchain((char *)L,
 891                                         mkchain((char *)dtype,
 892                                                 mkchain(z, CHNULL)));
 893                                 *Values = mkchain((char *)v, *Values);
 894                                 L += k;
 895                                 break;
 896                                 }
 897                         if ((int)((chainp)v->datap)->nextp->datap == xtype)
 898                                 break;
 899                         }
 900                 }
 901
 902         sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
 903         *Values = values = revchain(mkchain((char *)sentinel, *Values));
 904
 905         /* use doublereal fillers only if there are doublereal values */
 906
 907         k = TYLONG;
 908         for(v = values; v; v = v->nextp)
 909                 if (ONEOF((int)((chainp)v->datap)->nextp->datap,
 910                                 M(TYDREAL)|M(TYDCOMPLEX))) {
 911                         k = TYDREAL;
 912                         break;
 913                         }
 914         type_choice[0] = k;
 915
 916         nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
 917         next_tab(outfile);
 918         loc = loc0 = k = 0;
 919         curtype = -1;
 920         for(v = values; v; v = v->nextp) {
 921                 cp = (chainp)v->datap;
 922                 dloc = (ftnint)cp->datap;
 923                 L = dloc - loc;
 924                 if (L < 0) {
 925                         overlapping();
 926                         v1 = cp;
 927                         frchain(&v1);
 928                         v->datap = 0;
 929                         continue;
 930                         }
 931                 dtype = (int)cp->nextp->datap;
 932                 if (dtype == TYBLANK) {
 933                         dtype = TYCHAR;
 934                         wasblank = 1;
 935                         }
 936                 else
 937                         wasblank = 0;
 938                 if (curtype != dtype || L > 0) {
 939                         if (curtype != -1) {
 940                                 L1 = (loc - loc0)/dL;
 941                                 nice_printf(outfile, "%s e_%d%s;\n",
 942                                         typename[curtype], ++k,
 943                                         Len(L1,curtype));
 944                                 }
 945                         curtype = dtype;
 946                         loc0 = dloc;
 947                         }
 948                 if (L > 0) {
 949                         if (xtype == TYCHAR)
 950                                 filltype = TYCHAR;
 951                         else {
 952                                 filltype = L % szshort ? TYCHAR
 953                                                 : type_choice[L/szshort % 4];
 954                                 filltype1 = loc % szshort ? TYCHAR
 955                                                 : type_choice[loc/szshort % 4];
 956                                 if (typesize[filltype] > typesize[filltype1])
 957                                         filltype = filltype1;
 958                                 }
 959                         L1 = L / typesize[filltype];
 960                         nice_printf(outfile, "%s fill_%d[%ld];\n",
 961                                 typename[filltype], ++k, L1);
 962                         loc = dloc;
 963                         }
 964                 if (wasblank) {
 965                         loc += (ftnint)cp->nextp->nextp->datap;
 966                         dL = 1;
 967                         }
 968                 else {
 969                         dL = typesize[dtype];
 970                         loc += dL;
 971                         }
 972                 }
 973         nice_printf(outfile, "} %s = { ", iscomm
 974                 ? extsymtab[memno].cextname
 975                 : equiv_name(eqvmemno, CNULL));
 976         loc = 0;
 977         for(v = values; ; v = v->nextp) {
 978                 cp = (chainp)v->datap;
 979                 if (!cp)
 980                         continue;
 981                 dtype = (int)cp->nextp->datap;
 982                 if (dtype == TYERROR)
 983                         break;
 984                 dloc = (ftnint)cp->datap;
 985                 if (dloc > loc) {
 986                         nice_printf(outfile, "%s{0}", comma);
 987                         comma = ", ";
 988                         loc = dloc;
 989                         }
 990                 if (comma != Blank)
 991                         nice_printf(outfile, ", ");
 992                 comma = ", ";
 993                 if (dtype == TYCHAR || dtype == TYBLANK) {
 994                         v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
 995                                         :  do_string(outfile, v, &loc);
 996                         continue;
 997                         }
 998                 make_one_const(dtype, &Const, v);
 999                 switch(dtype) {
1000                         case TYLOGICAL:
1001                                 if (Const.ci < 0 || Const.ci > 1)
1002                                         errl(
1003                           "wr_equiv_init: unexpected logical value %ld",
1004                                                 Const.ci);
1005                                 nice_printf(outfile,
1006                                         Const.ci ? "TRUE_" : "FALSE_");
1007                                 break;
1008                         case TYSHORT:
1009                         case TYLONG:
1010                                 nice_printf(outfile, "%ld", Const.ci);
1011                                 break;
1012                         case TYREAL:
1013                                 nice_printf(outfile, "%s",
1014                                         flconst(real_buf, Const.cds[0]));
1015                                 break;
1016                         case TYDREAL:
1017                                 nice_printf(outfile, "%s", Const.cds[0]);
1018                                 break;
1019                         case TYCOMPLEX:
1020                                 nice_printf(outfile, "%s, %s",
1021                                         flconst(real_buf, Const.cds[0]),
1022                                         flconst(imag_buf, Const.cds[1]));
1023                                 break;
1024                         case TYDCOMPLEX:
1025                                 nice_printf(outfile, "%s, %s",
1026                                         Const.cds[0], Const.cds[1]);
1027                                 break;
1028                         default:
1029                                 erri("unexpected type %d in wr_equiv_init",
1030                                         dtype);
1031                         }
1032                 loc += typesize[dtype];
1033                 }
1034         nice_printf(outfile, " };\n\n");
1035         prev_tab(outfile);
1036         frchain(&sentinel);
1037         }