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