contrib/gcc/f/equiv.c

   1 /* equiv.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1998 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       Handles the EQUIVALENCE relationships in a program unit.
  27
  28    Modifications:
  29 */
  30
  31 #define FFEEQUIV_DEBUG 0
  32
  33 /* Include files. */
  34
  35 #include "proj.h"
  36 #include "equiv.h"
  37 #include "bad.h"
  38 #include "bld.h"
  39 #include "com.h"
  40 #include "data.h"
  41 #include "global.h"
  42 #include "lex.h"
  43 #include "malloc.h"
  44 #include "symbol.h"
  45
  46 /* Externals defined here. */
  47
  48
  49 /* Simple definitions and enumerations. */
  50
  51
  52 /* Internal typedefs. */
  53
  54
  55 /* Private include files. */
  56
  57
  58 /* Internal structure definitions. */
  59
  60 struct _ffeequiv_list_
  61   {
  62     ffeequiv first;
  63     ffeequiv last;
  64   };
  65
  66 /* Static objects accessed by functions in this module. */
  67
  68 static struct _ffeequiv_list_ ffeequiv_list_;
  69
  70 /* Static functions (internal). */
  71
  72 static void ffeequiv_destroy_ (ffeequiv eq);
  73 static void ffeequiv_layout_local_ (ffeequiv eq);
  74 static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s,
  75                               ffebld expr, bool subtract,
  76                               ffetargetOffset adjust, bool no_precede);
  77
  78 /* Internal macros. */
  79 \f
  80
  81 static void
  82 ffeequiv_destroy_ (ffeequiv victim)
  83 {
  84   ffebld list;
  85   ffebld item;
  86   ffebld expr;
  87
  88   for (list = victim->list; list != NULL; list = ffebld_trail (list))
  89     {
  90       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
  91         {
  92           ffesymbol sym;
  93
  94           expr = ffebld_head (item);
  95           sym = ffeequiv_symbol (expr);
  96           if (sym == NULL)
  97             continue;
  98           if (ffesymbol_equiv (sym) != NULL)
  99             ffesymbol_set_equiv (sym, NULL);
 100         }
 101     }
 102   ffeequiv_kill (victim);
 103 }
 104
 105 /* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars
 106
 107    ffeequiv eq;
 108    ffeequiv_layout_local_(eq);
 109
 110    Makes a single master ffestorag object that contains all the vars
 111    in the equivalence, and makes subordinate ffestorag objects for the
 112    vars with the correct offsets.
 113
 114    The resulting var offsets are relative not necessarily to 0 -- the
 115    are relative to the offset of the master area, which might be 0 or
 116    negative, but should never be positive.  */
 117
 118 static void
 119 ffeequiv_layout_local_ (ffeequiv eq)
 120 {
 121   ffestorag st;                 /* Equivalence storage area. */
 122   ffebld list;                  /* List of list of equivalences. */
 123   ffebld item;                  /* List of equivalences. */
 124   ffebld root_exp;              /* Expression for root sym. */
 125   ffestorag root_st;            /* Storage for root. */
 126   ffesymbol root_sym;           /* Root itself. */
 127   ffebld rooted_exp;            /* Expression for rooted sym in an eqlist. */
 128   ffestorag rooted_st;          /* Storage for rooted. */
 129   ffesymbol rooted_sym;         /* Rooted symbol itself. */
 130   ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */
 131   ffetargetAlign alignment;
 132   ffetargetAlign modulo;
 133   ffetargetAlign pad;
 134   ffetargetOffset size;
 135   ffetargetOffset num_elements;
 136   bool new_storage;             /* Established new storage info. */
 137   bool need_storage;            /* Have need for more storage info. */
 138   bool init;
 139
 140   assert (eq != NULL);
 141
 142   if (ffeequiv_common (eq) != NULL)
 143     {                           /* Put in common due to programmer error. */
 144       ffeequiv_destroy_ (eq);
 145       return;
 146     }
 147
 148   /* Find the symbol for the first valid item in the list of lists, use that
 149      as the root symbol.  Doesn't matter if it won't end up at the beginning
 150      of the list, though.  */
 151
 152 #if FFEEQUIV_DEBUG
 153   fprintf (stderr, "Equiv1:\n");
 154 #endif
 155
 156   root_sym = NULL;
 157   root_exp = NULL;
 158
 159   for (list = ffeequiv_list (eq);
 160        list != NULL;
 161        list = ffebld_trail (list))
 162     {                           /* For every equivalence list in the list of
 163                                    equivs */
 164       for (item = ffebld_head (list);
 165            item != NULL;
 166            item = ffebld_trail (item))
 167         {                       /* For every equivalence item in the list */
 168           ffetargetOffset ign;  /* Ignored. */
 169
 170           root_exp = ffebld_head (item);
 171           root_sym = ffeequiv_symbol (root_exp);
 172           if (root_sym == NULL)
 173             continue;           /* Ignore me. */
 174
 175           assert (ffesymbol_storage (root_sym) == NULL);        /* No storage yet. */
 176
 177           if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE))
 178             {
 179               /* We can't just eliminate this one symbol from the list
 180                  of candidates, because it might be the only one that
 181                  ties all these equivs together.  So just destroy the
 182                  whole list.  */
 183
 184               ffeequiv_destroy_ (eq);
 185               return;
 186             }
 187
 188           break;        /* Use first valid eqv expr for root exp/sym. */
 189         }
 190       if (root_sym != NULL)
 191         break;
 192     }
 193
 194   if (root_sym == NULL)
 195     {
 196       ffeequiv_destroy_ (eq);
 197       return;
 198     }
 199
 200
 201 #if FFEEQUIV_DEBUG
 202   fprintf (stderr, "  Root: `%s'\n", ffesymbol_text (root_sym));
 203 #endif
 204
 205   /* We've got work to do, so make the LOCAL storage object that'll hold all
 206      the equivalenced vars inside it. */
 207
 208   st = ffestorag_new (ffestorag_list_master ());
 209   ffestorag_set_parent (st, NULL);      /* Initializations happen here. */
 210   ffestorag_set_init (st, NULL);
 211   ffestorag_set_accretion (st, NULL);
 212   ffestorag_set_offset (st, 0);         /* Assume equiv will be at root offset 0 for now. */
 213   ffestorag_set_alignment (st, 1);
 214   ffestorag_set_modulo (st, 0);
 215   ffestorag_set_type (st, FFESTORAG_typeLOCAL);
 216   ffestorag_set_basictype (st, ffesymbol_basictype (root_sym));
 217   ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym));
 218   ffestorag_set_typesymbol (st, root_sym);
 219   ffestorag_set_is_save (st, ffeequiv_is_save (eq));
 220   if (ffesymbol_is_save (root_sym))
 221     ffestorag_update_save (st);
 222   ffestorag_set_is_init (st, ffeequiv_is_init (eq));
 223   if (ffesymbol_is_init (root_sym))
 224     ffestorag_update_init (st);
 225   ffestorag_set_symbol (st, root_sym);  /* Assume this will be the root until
 226                                            we know better (used only to generate
 227                                            the internal name for the aggregate area,
 228                                            e.g. for debugging). */
 229
 230   /* Make the EQUIV storage object for the root symbol. */
 231
 232   if (ffesymbol_rank (root_sym) == 0)
 233     num_elements = 1;
 234   else
 235     num_elements = ffebld_constant_integerdefault (ffebld_conter
 236                                                 (ffesymbol_arraysize (root_sym)));
 237   ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size,
 238                     ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym),
 239                     ffesymbol_size (root_sym), num_elements);
 240   ffestorag_set_size (st, size);        /* Set initial size of aggregate area. */
 241
 242   pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
 243                          ffestorag_ptr_to_modulo (st), 0, alignment,
 244                          modulo);
 245   assert (pad == 0);
 246
 247   root_st = ffestorag_new (ffestorag_list_equivs (st));
 248   ffestorag_set_parent (root_st, st);   /* Initializations happen there. */
 249   ffestorag_set_init (root_st, NULL);
 250   ffestorag_set_accretion (root_st, NULL);
 251   ffestorag_set_symbol (root_st, root_sym);
 252   ffestorag_set_size (root_st, size);
 253   ffestorag_set_offset (root_st, 0);    /* Will not change; always 0 relative to itself! */
 254   ffestorag_set_alignment (root_st, alignment);
 255   ffestorag_set_modulo (root_st, modulo);
 256   ffestorag_set_type (root_st, FFESTORAG_typeEQUIV);
 257   ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym));
 258   ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym));
 259   ffestorag_set_typesymbol (root_st, root_sym);
 260   ffestorag_set_is_save (root_st, FALSE);       /* Assume FALSE, then... */
 261   if (ffestorag_is_save (st))   /* ...update to TRUE if needed. */
 262     ffestorag_update_save (root_st);
 263   ffestorag_set_is_init (root_st, FALSE);       /* Assume FALSE, then... */
 264   if (ffestorag_is_init (st))   /* ...update to TRUE if needed. */
 265     ffestorag_update_init (root_st);
 266   ffesymbol_set_storage (root_sym, root_st);
 267   ffesymbol_signal_unreported (root_sym);
 268   init = ffesymbol_is_init (root_sym);
 269
 270   /* Now that we know the root (offset=0) symbol, revisit all the lists and
 271      do the actual storage allocation.  Keep doing this until we've gone
 272      through them all without making any new storage objects. */
 273
 274   do
 275     {
 276       new_storage = FALSE;
 277       need_storage = FALSE;
 278       for (list = ffeequiv_list (eq);
 279            list != NULL;
 280            list = ffebld_trail (list))
 281         {                       /* For every equivalence list in the list of
 282                                    equivs */
 283           /* Now find a "rooted" symbol in this list.  That is, find the
 284              first item we can that is valid and whose symbol already
 285              has a storage area, because that means we know where it
 286              belongs in the equivalence area and can then allocate the
 287              rest of the items in the list accordingly.  */
 288
 289           rooted_sym = NULL;
 290           rooted_exp = NULL;
 291           eqlist_offset = 0;
 292
 293           for (item = ffebld_head (list);
 294                item != NULL;
 295                item = ffebld_trail (item))
 296             {                   /* For every equivalence item in the list */
 297               rooted_exp = ffebld_head (item);
 298               rooted_sym = ffeequiv_symbol (rooted_exp);
 299               if ((rooted_sym == NULL)
 300                   || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL))
 301                 {
 302                   rooted_sym = NULL;
 303                   continue;     /* Ignore me. */
 304                 }
 305
 306               need_storage = TRUE;      /* Somebody is likely to need
 307                                            storage. */
 308
 309 #if FFEEQUIV_DEBUG
 310               fprintf (stderr, "  Rooted: `%s' at %" ffetargetOffset_f "d\n",
 311                        ffesymbol_text (rooted_sym),
 312                        ffestorag_offset (rooted_st));
 313 #endif
 314
 315               /* The offset of this symbol from the equiv's root symbol
 316                  is already known, and the size of this symbol is already
 317                  incorporated in the size of the equiv's aggregate area.
 318                  What we now determine is the offset of this equivalence
 319                  _list_ from the equiv's root symbol.
 320
 321                  For example, if we know that A is at offset 16 from the
 322                  root symbol, given EQUIVALENCE (B(24),A(2)), we're looking
 323                  at A(2), meaning that the offset for this equivalence list
 324                  is 20 (4 bytes beyond the beginning of A, assuming typical
 325                  array types, dimensions, and type info).  */
 326
 327               if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE,
 328                                      ffestorag_offset (rooted_st), FALSE))
 329
 330                 {       /* Can't use this one. */
 331                   ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for
 332                                                             death. */
 333                   rooted_sym = NULL;
 334                   continue;             /* Something's wrong with eqv expr, try another. */
 335                 }
 336
 337 #if FFEEQUIV_DEBUG
 338               fprintf (stderr, "  Eqlist offset: %" ffetargetOffset_f "d\n",
 339                        eqlist_offset);
 340 #endif
 341
 342               break;
 343             }
 344
 345           /* If no rooted symbol, it means this list has no roots -- yet.
 346              So, forget this list this time around, but we'll get back
 347              to it after the outer loop iterates at least one more time,
 348              and, ultimately, it will have a root.  */
 349
 350           if (rooted_sym == NULL)
 351             {
 352 #if FFEEQUIV_DEBUG
 353               fprintf (stderr, "No roots.\n");
 354 #endif
 355               continue;
 356             }
 357
 358           /* We now have a rooted symbol/expr and the offset of this equivalence
 359              list from the root symbol.  The other expressions in this
 360              list all identify an initial storage unit that must have the
 361              same offset. */
 362
 363           for (item = ffebld_head (list);
 364                item != NULL;
 365                item = ffebld_trail (item))
 366             {                   /* For every equivalence item in the list */
 367               ffebld item_exp;                  /* Expression for equivalence. */
 368               ffestorag item_st;                /* Storage for var. */
 369               ffesymbol item_sym;               /* Var itself. */
 370               ffetargetOffset item_offset;      /* Offset for var from root. */
 371               ffetargetOffset new_size;
 372
 373               item_exp = ffebld_head (item);
 374               item_sym = ffeequiv_symbol (item_exp);
 375               if ((item_sym == NULL)
 376                   || (ffesymbol_equiv (item_sym) == NULL))
 377                 continue;       /* Ignore me. */
 378
 379               if (item_sym == rooted_sym)
 380                 continue;       /* Rooted sym already set up. */
 381
 382               if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE,
 383                                      eqlist_offset, FALSE))
 384                 {
 385                   ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
 386                   continue;
 387                 }
 388
 389 #if FFEEQUIV_DEBUG
 390               fprintf (stderr, "  Item `%s' at %" ffetargetOffset_f "d",
 391                        ffesymbol_text (item_sym), item_offset);
 392 #endif
 393
 394               if (ffesymbol_rank (item_sym) == 0)
 395                 num_elements = 1;
 396               else
 397                 num_elements = ffebld_constant_integerdefault (ffebld_conter
 398                                                 (ffesymbol_arraysize (item_sym)));
 399               ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo,
 400                                 &size, ffesymbol_basictype (item_sym),
 401                                 ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym),
 402                                 num_elements);
 403               pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
 404                                      ffestorag_ptr_to_modulo (st),
 405                                      item_offset, alignment, modulo);
 406               if (pad != 0)
 407                 {
 408                   ffebad_start (FFEBAD_EQUIV_ALIGN);
 409                   ffebad_string (ffesymbol_text (item_sym));
 410                   ffebad_finish ();
 411                   ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */
 412                   continue;
 413                 }
 414
 415               /* If the variable's offset is less than the offset for the
 416                  aggregate storage area, it means it has to expand backwards
 417                  -- i.e. the new known starting point of the area precedes the
 418                  old one.  This can't happen with COMMON areas (the standard,
 419                  and common sense, disallow it), but it is normal for local
 420                  EQUIVALENCE areas.
 421
 422                  Also handle choosing the "documented" rooted symbol for this
 423                  area here.  It's the symbol at the bottom (lowest offset)
 424                  of the aggregate area, with ties going to the name that would
 425                  sort to the top of the list of ties.  */
 426
 427               if (item_offset == ffestorag_offset (st))
 428                 {
 429                   if ((item_sym != ffestorag_symbol (st))
 430                       && (strcmp (ffesymbol_text (item_sym),
 431                                   ffesymbol_text (ffestorag_symbol (st)))
 432                           < 0))
 433                     ffestorag_set_symbol (st, item_sym);
 434                 }
 435               else if (item_offset < ffestorag_offset (st))
 436                 {
 437                   /* Increase size of equiv area to start for lower offset
 438                      relative to root symbol.  */
 439                   if (! ffetarget_offset_add (&new_size,
 440                                               ffestorag_offset (st)
 441                                               - item_offset,
 442                                               ffestorag_size (st)))
 443                     ffetarget_offset_overflow (ffesymbol_text (s));
 444                   else
 445                     ffestorag_set_size (st, new_size);
 446
 447                   ffestorag_set_symbol (st, item_sym);
 448                   ffestorag_set_offset (st, item_offset);
 449
 450 #if FFEEQUIV_DEBUG
 451                   fprintf (stderr, " [eq offset=%" ffetargetOffset_f
 452                            "d, size=%" ffetargetOffset_f "d]",
 453                            item_offset, new_size);
 454 #endif
 455                 }
 456
 457               if ((item_st = ffesymbol_storage (item_sym)) == NULL)
 458                 {               /* Create new ffestorag object, extend equiv
 459                                    area. */
 460 #if FFEEQUIV_DEBUG
 461                   fprintf (stderr, ".\n");
 462 #endif
 463                   new_storage = TRUE;
 464                   item_st = ffestorag_new (ffestorag_list_equivs (st));
 465                   ffestorag_set_parent (item_st, st);   /* Initializations
 466                                                            happen there. */
 467                   ffestorag_set_init (item_st, NULL);
 468                   ffestorag_set_accretion (item_st, NULL);
 469                   ffestorag_set_symbol (item_st, item_sym);
 470                   ffestorag_set_size (item_st, size);
 471                   ffestorag_set_offset (item_st, item_offset);
 472                   ffestorag_set_alignment (item_st, alignment);
 473                   ffestorag_set_modulo (item_st, modulo);
 474                   ffestorag_set_type (item_st, FFESTORAG_typeEQUIV);
 475                   ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym));
 476                   ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym));
 477                   ffestorag_set_typesymbol (item_st, item_sym);
 478                   ffestorag_set_is_save (item_st, FALSE);       /* Assume FALSE... */
 479                   if (ffestorag_is_save (st))   /* ...update TRUE */
 480                     ffestorag_update_save (item_st);    /* if needed. */
 481                   ffestorag_set_is_init (item_st, FALSE);       /* Assume FALSE... */
 482                   if (ffestorag_is_init (st))   /* ...update TRUE */
 483                     ffestorag_update_init (item_st);    /* if needed. */
 484                   ffesymbol_set_storage (item_sym, item_st);
 485                   ffesymbol_signal_unreported (item_sym);
 486                   if (ffesymbol_is_init (item_sym))
 487                     init = TRUE;
 488
 489                   /* Determine new size of equiv area, complain if overflow.  */
 490
 491                   if (!ffetarget_offset_add (&size, item_offset, size)
 492                       || !ffetarget_offset_add (&size, -ffestorag_offset (st), size))
 493                     ffetarget_offset_overflow (ffesymbol_text (s));
 494                   else if (size > ffestorag_size (st))
 495                     ffestorag_set_size (st, size);
 496                   ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym),
 497                                     ffesymbol_kindtype (item_sym));
 498                 }
 499               else
 500                 {
 501 #if FFEEQUIV_DEBUG
 502                   fprintf (stderr, " (was %" ffetargetOffset_f "d).\n",
 503                            ffestorag_offset (item_st));
 504 #endif
 505                   /* Make sure offset agrees with known offset. */
 506                   if (item_offset != ffestorag_offset (item_st))
 507                     {
 508                       char io1[40];
 509                       char io2[40];
 510
 511                       sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset);
 512                       sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st));
 513                       ffebad_start (FFEBAD_EQUIV_MISMATCH);
 514                       ffebad_string (ffesymbol_text (item_sym));
 515                       ffebad_string (ffesymbol_text (root_sym));
 516                       ffebad_string (io1);
 517                       ffebad_string (io2);
 518                       ffebad_finish ();
 519                     }
 520                 }
 521               ffesymbol_set_equiv (item_sym, NULL);     /* Don't bother with me anymore. */
 522             }                   /* (For every equivalence item in the list) */
 523           ffebld_set_head (list, NULL); /* Don't do this list again. */
 524         }                       /* (For every equivalence list in the list of
 525                                    equivs) */
 526     } while (new_storage && need_storage);
 527
 528   ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */
 529
 530   ffeequiv_kill (eq);           /* Fully processed, no longer needed. */
 531
 532   /* If the offset for this storage area is zero (it cannot be positive),
 533      that means the alignment/modulo info is already correct.  Otherwise,
 534      the alignment info is correct, but the modulo info reflects a
 535      zero offset, so fix it.  */
 536
 537   if (ffestorag_offset (st) < 0)
 538     {
 539       /* Calculate the initial padding necessary to preserve
 540          the alignment/modulo requirements for the storage area.
 541          These requirements are themselves kept track of in the
 542          record for the storage area as a whole, but really pertain
 543          to offset 0 of that area, which is where the root symbol
 544          was originally placed.
 545
 546          The goal here is to have the offset and size for the area
 547          faithfully reflect the area itself, not extra requirements
 548          like alignment.  So to meet the alignment requirements,
 549          the modulo for the area should be set as if the area had an
 550          alignment requirement of alignment/0 and was aligned/padded
 551          downward to meet the alignment requirements of the area at
 552          offset zero, the amount of padding needed being the desired
 553          value for the modulo of the area.  */
 554
 555       alignment = ffestorag_alignment (st);
 556       modulo = ffestorag_modulo (st);
 557
 558       /* Since we want to move the whole area *down* (lower memory
 559          addresses) as required by the alignment/modulo paid, negate
 560          the offset to ffetarget_align, which assumes aligning *up*
 561          is desired.  */
 562       pad = ffetarget_align (&alignment, &modulo,
 563                              - ffestorag_offset (st),
 564                              alignment, 0);
 565       ffestorag_set_modulo (st, pad);
 566     }
 567
 568   if (init)
 569     ffedata_gather (st);        /* Gather subordinate inits into one init. */
 570 }
 571
 572 /* ffeequiv_offset_ -- Determine offset from start of symbol
 573
 574    ffetargetOffset offset;
 575    ffesymbol s;  // Symbol for error reporting.
 576    ffebld expr;  // opSUBSTR, opARRAYREF, opSYMTER, opANY.
 577    bool subtract;  // FALSE means add to adjust, TRUE means subtract from it.
 578    ffetargetOffset adjust;  // Helps keep answer in pos range (unsigned).
 579    if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust))
 580        // error doing the calculation, message already printed
 581
 582    Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF
 583    combination added-to/subtracted-from the adjustment specified.  If there
 584    is an error of some kind, returns FALSE, else returns TRUE.  Note that
 585    only the first storage unit specified is considered; A(1:1) and A(1:2000)
 586    have the same first storage unit and so return the same offset.  */
 587
 588 static bool
 589 ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
 590                   ffebld expr, bool subtract, ffetargetOffset adjust,
 591                   bool no_precede)
 592 {
 593   ffetargetIntegerDefault value = 0;
 594   ffetargetOffset cval;         /* Converted value. */
 595   ffesymbol sym;
 596
 597   if (expr == NULL)
 598     return FALSE;
 599
 600 again:                          /* :::::::::::::::::::: */
 601
 602   switch (ffebld_op (expr))
 603     {
 604     case FFEBLD_opANY:
 605       return FALSE;
 606
 607     case FFEBLD_opSYMTER:
 608       {
 609         ffetargetOffset size;   /* Size of a single unit. */
 610         ffetargetAlign a;       /* Ignored. */
 611         ffetargetAlign m;       /* Ignored. */
 612
 613         sym = ffebld_symter (expr);
 614         if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
 615           return FALSE;
 616
 617         ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
 618                           ffesymbol_basictype (sym),
 619                           ffesymbol_kindtype (sym), 1, 1);
 620
 621         if (value < 0)
 622           {                     /* Really invalid, as in A(-2:5), but in case
 623                                    it's wanted.... */
 624             if (!ffetarget_offset (&cval, -value))
 625               return FALSE;
 626
 627             if (!ffetarget_offset_multiply (&cval, cval, size))
 628               return FALSE;
 629
 630             if (subtract)
 631               return ffetarget_offset_add (offset, cval, adjust);
 632
 633             if (no_precede && (cval > adjust))
 634               {
 635               neg:              /* :::::::::::::::::::: */
 636                 ffebad_start (FFEBAD_COMMON_NEG);
 637                 ffebad_string (ffesymbol_text (sym));
 638                 ffebad_finish ();
 639                 return FALSE;
 640               }
 641             return ffetarget_offset_add (offset, -cval, adjust);
 642           }
 643
 644         if (!ffetarget_offset (&cval, value))
 645           return FALSE;
 646
 647         if (!ffetarget_offset_multiply (&cval, cval, size))
 648           return FALSE;
 649
 650         if (!subtract)
 651           return ffetarget_offset_add (offset, cval, adjust);
 652
 653         if (no_precede && (cval > adjust))
 654           goto neg;             /* :::::::::::::::::::: */
 655
 656         return ffetarget_offset_add (offset, -cval, adjust);
 657       }
 658
 659     case FFEBLD_opARRAYREF:
 660       {
 661         ffebld symexp = ffebld_left (expr);
 662         ffebld subscripts = ffebld_right (expr);
 663         ffebld dims;
 664         ffetargetIntegerDefault width;
 665         ffetargetIntegerDefault arrayval;
 666         ffetargetIntegerDefault lowbound;
 667         ffetargetIntegerDefault highbound;
 668         ffebld subscript;
 669         ffebld dim;
 670         ffebld low;
 671         ffebld high;
 672         int rank = 0;
 673
 674         if (ffebld_op (symexp) != FFEBLD_opSYMTER)
 675           return FALSE;
 676
 677         sym = ffebld_symter (symexp);
 678         if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
 679           return FALSE;
 680
 681         if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
 682           width = 1;
 683         else
 684           width = ffesymbol_size (sym);
 685         dims = ffesymbol_dims (sym);
 686
 687         while (subscripts != NULL)
 688           {
 689             ++rank;
 690             if (dims == NULL)
 691               {
 692                 ffebad_start (FFEBAD_EQUIV_MANY);
 693                 ffebad_string (ffesymbol_text (sym));
 694                 ffebad_finish ();
 695                 return FALSE;
 696               }
 697
 698             subscript = ffebld_head (subscripts);
 699             dim = ffebld_head (dims);
 700
 701             if (ffebld_op (subscript) == FFEBLD_opANY)
 702               return FALSE;
 703
 704             assert (ffebld_op (subscript) == FFEBLD_opCONTER);
 705             assert (ffeinfo_basictype (ffebld_info (subscript))
 706                     == FFEINFO_basictypeINTEGER);
 707             assert (ffeinfo_kindtype (ffebld_info (subscript))
 708                     == FFEINFO_kindtypeINTEGERDEFAULT);
 709             arrayval = ffebld_constant_integerdefault (ffebld_conter
 710                                                        (subscript));
 711
 712             if (ffebld_op (dim) == FFEBLD_opANY)
 713               return FALSE;
 714
 715             assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
 716             low = ffebld_left (dim);
 717             high = ffebld_right (dim);
 718
 719             if (low == NULL)
 720               lowbound = 1;
 721             else
 722               {
 723                 if (ffebld_op (low) == FFEBLD_opANY)
 724                   return FALSE;
 725
 726                 assert (ffebld_op (low) == FFEBLD_opCONTER);
 727                 assert (ffeinfo_basictype (ffebld_info (low))
 728                         == FFEINFO_basictypeINTEGER);
 729                 assert (ffeinfo_kindtype (ffebld_info (low))
 730                         == FFEINFO_kindtypeINTEGERDEFAULT);
 731                 lowbound
 732                   = ffebld_constant_integerdefault (ffebld_conter (low));
 733               }
 734
 735             if (ffebld_op (high) == FFEBLD_opANY)
 736               return FALSE;
 737
 738             assert (ffebld_op (high) == FFEBLD_opCONTER);
 739             assert (ffeinfo_basictype (ffebld_info (high))
 740                     == FFEINFO_basictypeINTEGER);
 741             assert (ffeinfo_kindtype (ffebld_info (high))
 742                     == FFEINFO_kindtypeINTEGER1);
 743             highbound
 744               = ffebld_constant_integerdefault (ffebld_conter (high));
 745
 746             if ((arrayval < lowbound) || (arrayval > highbound))
 747               {
 748                 char rankstr[10];
 749
 750                 sprintf (rankstr, "%d", rank);
 751                 ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
 752                 ffebad_string (ffesymbol_text (sym));
 753                 ffebad_string (rankstr);
 754                 ffebad_finish ();
 755               }
 756
 757             subscripts = ffebld_trail (subscripts);
 758             dims = ffebld_trail (dims);
 759
 760             value += width * (arrayval - lowbound);
 761             if (subscripts != NULL)
 762               width *= highbound - lowbound + 1;
 763           }
 764
 765         if (dims != NULL)
 766           {
 767             ffebad_start (FFEBAD_EQUIV_FEW);
 768             ffebad_string (ffesymbol_text (sym));
 769             ffebad_finish ();
 770             return FALSE;
 771           }
 772
 773         expr = symexp;
 774       }
 775       goto again;               /* :::::::::::::::::::: */
 776
 777     case FFEBLD_opSUBSTR:
 778       {
 779         ffebld begin = ffebld_head (ffebld_right (expr));
 780
 781         expr = ffebld_left (expr);
 782         if (ffebld_op (expr) == FFEBLD_opANY)
 783           return FALSE;
 784         if (ffebld_op (expr) == FFEBLD_opARRAYREF)
 785           sym = ffebld_symter (ffebld_left (expr));
 786         else if (ffebld_op (expr) == FFEBLD_opSYMTER)
 787           sym = ffebld_symter (expr);
 788         else
 789           sym = NULL;
 790
 791         if ((sym != NULL)
 792             && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
 793           return FALSE;
 794
 795         if (begin == NULL)
 796           value = 0;
 797         else
 798           {
 799             if (ffebld_op (begin) == FFEBLD_opANY)
 800               return FALSE;
 801             assert (ffebld_op (begin) == FFEBLD_opCONTER);
 802             assert (ffeinfo_basictype (ffebld_info (begin))
 803                     == FFEINFO_basictypeINTEGER);
 804             assert (ffeinfo_kindtype (ffebld_info (begin))
 805                     == FFEINFO_kindtypeINTEGERDEFAULT);
 806
 807             value = ffebld_constant_integerdefault (ffebld_conter (begin));
 808
 809             if ((value < 1)
 810                 || ((sym != NULL)
 811                     && (value > ffesymbol_size (sym))))
 812               {
 813                 ffebad_start (FFEBAD_EQUIV_RANGE);
 814                 ffebad_string (ffesymbol_text (sym));
 815                 ffebad_finish ();
 816               }
 817
 818             --value;
 819           }
 820         if ((sym != NULL)
 821             && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
 822           {
 823             ffebad_start (FFEBAD_EQUIV_SUBSTR);
 824             ffebad_string (ffesymbol_text (sym));
 825             ffebad_finish ();
 826             value = 0;
 827           }
 828       }
 829       goto again;               /* :::::::::::::::::::: */
 830
 831     default:
 832       assert ("bad op" == NULL);
 833       return FALSE;
 834     }
 835
 836 }
 837
 838 /* ffeequiv_add -- Add list of equivalences to list of lists for eq object
 839
 840    ffeequiv eq;
 841    ffebld list;
 842    ffelexToken t;  // points to first item in equivalence list
 843    ffeequiv_add(eq,list,t);
 844
 845    Check the list to make sure only one common symbol is involved (even
 846    if multiple times) and agrees with the common symbol for the equivalence
 847    object (or it has no common symbol until now).  Prepend (or append, it
 848    doesn't matter) the list to the list of lists for the equivalence object.
 849    Otherwise report an error and return.  */
 850
 851 void
 852 ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
 853 {
 854   ffebld item;
 855   ffesymbol symbol;
 856   ffesymbol common = ffeequiv_common (eq);
 857
 858   for (item = list; item != NULL; item = ffebld_trail (item))
 859     {
 860       symbol = ffeequiv_symbol (ffebld_head (item));
 861
 862       if (ffesymbol_common (symbol) != NULL)    /* Is symbol known in COMMON yet? */
 863         {
 864           if (common == NULL)
 865             common = ffesymbol_common (symbol);
 866           else if (common != ffesymbol_common (symbol))
 867             {
 868               /* Yes, and symbol disagrees with others on the COMMON area. */
 869               ffebad_start (FFEBAD_EQUIV_COMMON);
 870               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 871               ffebad_string (ffesymbol_text (common));
 872               ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
 873               ffebad_finish ();
 874               return;
 875             }
 876         }
 877     }
 878
 879   if ((common != NULL)
 880       && (ffeequiv_common (eq) == NULL))        /* Is COMMON involved already? */
 881     ffeequiv_set_common (eq, common);   /* No, but it is now. */
 882
 883   for (item = list; item != NULL; item = ffebld_trail (item))
 884     {
 885       symbol = ffeequiv_symbol (ffebld_head (item));
 886
 887       if (ffesymbol_equiv (symbol) == NULL)
 888         ffesymbol_set_equiv (symbol, eq);
 889       else
 890         assert (ffesymbol_equiv (symbol) == eq);
 891
 892       if (ffesymbol_common (symbol) == NULL)    /* Is symbol in a COMMON
 893                                                    area? */
 894         {                       /* No (at least not yet). */
 895           if (ffesymbol_is_save (symbol))
 896             ffeequiv_update_save (eq);  /* EQUIVALENCE has >=1 SAVEd entity. */
 897           if (ffesymbol_is_init (symbol))
 898             ffeequiv_update_init (eq);  /* EQUIVALENCE has >=1 init'd entity. */
 899           continue;             /* Nothing more to do here. */
 900         }
 901
 902 #if FFEGLOBAL_ENABLED
 903       if (ffesymbol_is_init (symbol))
 904         ffeglobal_init_common (ffesymbol_common (symbol), t);
 905 #endif
 906
 907       if (ffesymbol_is_save (ffesymbol_common (symbol)))
 908         ffeequiv_update_save (eq);      /* EQUIVALENCE is in a SAVEd COMMON block. */
 909       if (ffesymbol_is_init (ffesymbol_common (symbol)))
 910         ffeequiv_update_init (eq);      /* EQUIVALENCE is in a init'd COMMON block. */
 911     }
 912
 913   ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
 914 }
 915
 916 /* ffeequiv_dump -- Dump info on equivalence object
 917
 918    ffeequiv eq;
 919    ffeequiv_dump(eq);  */
 920
 921 #if FFECOM_targetCURRENT == FFECOM_targetFFE
 922 void
 923 ffeequiv_dump (ffeequiv eq)
 924 {
 925   if (ffeequiv_common (eq) != NULL)
 926     fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
 927   ffebld_dump (ffeequiv_list (eq));
 928 }
 929 #endif
 930
 931 /* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
 932
 933    ffeequiv_exec_transition();  */
 934
 935 void
 936 ffeequiv_exec_transition ()
 937 {
 938   while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
 939     ffeequiv_layout_local_ (ffeequiv_list_.first);
 940 }
 941
 942 /* ffeequiv_init_2 -- Initialize for new program unit
 943
 944    ffeequiv_init_2();
 945
 946    Initializes the list of equivalences.  */
 947
 948 void
 949 ffeequiv_init_2 ()
 950 {
 951   ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
 952   ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
 953 }
 954
 955 /* ffeequiv_kill -- Kill equivalence object after removing from list
 956
 957    ffeequiv eq;
 958    ffeequiv_kill(eq);
 959
 960    Removes equivalence object from master list, then kills it.  */
 961
 962 void
 963 ffeequiv_kill (ffeequiv victim)
 964 {
 965   victim->next->previous = victim->previous;
 966   victim->previous->next = victim->next;
 967   if (ffe_is_do_internal_checks ())
 968     {
 969       ffebld list;
 970       ffebld item;
 971       ffebld expr;
 972
 973       /* Assert that nobody our victim points to still points to it.  */
 974
 975       assert ((victim->common == NULL)
 976               || (ffesymbol_equiv (victim->common) == NULL));
 977
 978       for (list = victim->list; list != NULL; list = ffebld_trail (list))
 979         {
 980           for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
 981             {
 982               ffesymbol sym;
 983
 984               expr = ffebld_head (item);
 985               sym = ffeequiv_symbol (expr);
 986               if (sym == NULL)
 987                 continue;
 988               assert (ffesymbol_equiv (sym) != victim);
 989             }
 990         }
 991     }
 992   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
 993 }
 994
 995 /* ffeequiv_layout_cblock -- Lay out storage for common area
 996
 997    ffestorag st;
 998    if (ffeequiv_layout_cblock(st))
 999        // at least one equiv'd symbol has init/accretion expr.
1000
1001    Now that the explicitly COMMONed variables in the common area (whose
1002    ffestorag object is passed) have been laid out, lay out the storage
1003    for all variables equivalenced into the area by making subordinate
1004    ffestorag objects for them.  */
1005
1006 bool
1007 ffeequiv_layout_cblock (ffestorag st)
1008 {
1009   ffesymbol s = ffestorag_symbol (st);  /* CBLOCK symbol. */
1010   ffebld list;                  /* List of explicit common vars, in order, in
1011                                    s. */
1012   ffebld item;                  /* List of list of equivalences in a given
1013                                    explicit common var. */
1014   ffebld root;                  /* Expression for (1st) explicit common var
1015                                    in list of eqs. */
1016   ffestorag rst;                /* Storage for root. */
1017   ffetargetOffset root_offset;  /* Offset for root into common area. */
1018   ffesymbol sr;                 /* Root itself. */
1019   ffeequiv seq;                 /* Its equivalence object, if any. */
1020   ffebld var;                   /* Expression for equivalence. */
1021   ffestorag vst;                /* Storage for var. */
1022   ffetargetOffset var_offset;   /* Offset for var into common area. */
1023   ffesymbol sv;                 /* Var itself. */
1024   ffebld altroot;               /* Alternate root. */
1025   ffesymbol altrootsym;         /* Alternate root symbol. */
1026   ffetargetAlign alignment;
1027   ffetargetAlign modulo;
1028   ffetargetAlign pad;
1029   ffetargetOffset size;
1030   ffetargetOffset num_elements;
1031   bool new_storage;             /* Established new storage info. */
1032   bool need_storage;            /* Have need for more storage info. */
1033   bool ok;
1034   bool init = FALSE;
1035
1036   assert (st != NULL);
1037   assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
1038   assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
1039
1040   for (list = ffesymbol_commonlist (ffestorag_symbol (st));
1041        list != NULL;
1042        list = ffebld_trail (list))
1043     {                           /* For every variable in the common area */
1044       assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
1045       sr = ffebld_symter (ffebld_head (list));
1046       if ((seq = ffesymbol_equiv (sr)) == NULL)
1047         continue;               /* No equivalences to process. */
1048       rst = ffesymbol_storage (sr);
1049       if (rst == NULL)
1050         {
1051           assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
1052           continue;
1053         }
1054       ffesymbol_set_equiv (sr, NULL);   /* Cancel ref to equiv obj. */
1055       do
1056         {
1057           new_storage = FALSE;
1058           need_storage = FALSE;
1059           for (item = ffeequiv_list (seq);      /* Get list of equivs. */
1060                item != NULL;
1061                item = ffebld_trail (item))
1062             {                   /* For every eqv list in the list of equivs
1063                                    for the variable */
1064               altroot = NULL;
1065               altrootsym = NULL;
1066               for (root = ffebld_head (item);
1067                    root != NULL;
1068                    root = ffebld_trail (root))
1069                 {               /* For every equivalence item in the list */
1070                   sv = ffeequiv_symbol (ffebld_head (root));
1071                   if (sv == sr)
1072                     break;      /* Found first mention of "rooted" symbol. */
1073                   if (ffesymbol_storage (sv) != NULL)
1074                     {
1075                       altroot = root;   /* If no mention, use this guy
1076                                            instead. */
1077                       altrootsym = sv;
1078                     }
1079                 }
1080               if (root != NULL)
1081                 {
1082                   root = ffebld_head (root);    /* Lose its opITEM. */
1083                   ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
1084                                          ffestorag_offset (rst), TRUE);
1085                   /* Equiv point prior to start of common area? */
1086                 }
1087               else if (altroot != NULL)
1088                 {
1089                   /* Equiv point prior to start of common area? */
1090                   root = ffebld_head (altroot);
1091                   ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
1092                                          FALSE,
1093                          ffestorag_offset (ffesymbol_storage (altrootsym)),
1094                                          TRUE);
1095                   ffesymbol_set_equiv (altrootsym, NULL);
1096                 }
1097               else
1098                 /* No rooted symbol in list of equivalences! */
1099                 {               /* Assume this was due to opANY and ignore
1100                                    this list for now. */
1101                   need_storage = TRUE;
1102                   continue;
1103                 }
1104
1105               /* We now know the root symbol and the operating offset of that
1106                  root into the common area.  The other expressions in the
1107                  list all identify an initial storage unit that must have the
1108                  same offset. */
1109
1110               for (var = ffebld_head (item);
1111                    var != NULL;
1112                    var = ffebld_trail (var))
1113                 {               /* For every equivalence item in the list */
1114                   if (ffebld_head (var) == root)
1115                     continue;   /* Except root, of course. */
1116                   sv = ffeequiv_symbol (ffebld_head (var));
1117                   if (sv == NULL)
1118                     continue;   /* Except erroneous stuff (opANY). */
1119                   ffesymbol_set_equiv (sv, NULL);       /* Don't need this ref
1120                                                            anymore. */
1121                   if (!ok
1122                       || !ffeequiv_offset_ (&var_offset, sv,
1123                                             ffebld_head (var), TRUE,
1124                                             root_offset, TRUE))
1125                     continue;   /* Can't do negative offset wrt COMMON. */
1126
1127                   if (ffesymbol_rank (sv) == 0)
1128                     num_elements = 1;
1129                   else
1130                     num_elements = ffebld_constant_integerdefault
1131                       (ffebld_conter (ffesymbol_arraysize (sv)));
1132                   ffetarget_layout (ffesymbol_text (sv), &alignment,
1133                                     &modulo, &size,
1134                                     ffesymbol_basictype (sv),
1135                                     ffesymbol_kindtype (sv),
1136                                     ffesymbol_size (sv), num_elements);
1137                   pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
1138                                          ffestorag_ptr_to_modulo (st),
1139                                          var_offset, alignment, modulo);
1140                   if (pad != 0)
1141                     {
1142                       ffebad_start (FFEBAD_EQUIV_ALIGN);
1143                       ffebad_string (ffesymbol_text (sv));
1144                       ffebad_finish ();
1145                       continue;
1146                     }
1147
1148                   if ((vst = ffesymbol_storage (sv)) == NULL)
1149                     {           /* Create new ffestorag object, extend
1150                                    cblock. */
1151                       new_storage = TRUE;
1152                       vst = ffestorag_new (ffestorag_list_equivs (st));
1153                       ffestorag_set_parent (vst, st);   /* Initializations
1154                                                            happen there. */
1155                       ffestorag_set_init (vst, NULL);
1156                       ffestorag_set_accretion (vst, NULL);
1157                       ffestorag_set_symbol (vst, sv);
1158                       ffestorag_set_size (vst, size);
1159                       ffestorag_set_offset (vst, var_offset);
1160                       ffestorag_set_alignment (vst, alignment);
1161                       ffestorag_set_modulo (vst, modulo);
1162                       ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
1163                       ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
1164                       ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
1165                       ffestorag_set_typesymbol (vst, sv);
1166                       ffestorag_set_is_save (vst, FALSE);       /* Assume FALSE... */
1167                       if (ffestorag_is_save (st))       /* ...update TRUE */
1168                         ffestorag_update_save (vst);    /* if needed. */
1169                       ffestorag_set_is_init (vst, FALSE);       /* Assume FALSE... */
1170                       if (ffestorag_is_init (st))       /* ...update TRUE */
1171                         ffestorag_update_init (vst);    /* if needed. */
1172                       if (!ffetarget_offset_add (&size, var_offset, size))
1173                         /* Find one size of common block, complain if
1174                            overflow. */
1175                         ffetarget_offset_overflow (ffesymbol_text (s));
1176                       else if (size > ffestorag_size (st))
1177                         /* Extend common. */
1178                         ffestorag_set_size (st, size);
1179                       ffesymbol_set_storage (sv, vst);
1180                       ffesymbol_set_common (sv, s);
1181                       ffesymbol_signal_unreported (sv);
1182                       ffestorag_update (st, sv, ffesymbol_basictype (sv),
1183                                         ffesymbol_kindtype (sv));
1184                       if (ffesymbol_is_init (sv))
1185                         init = TRUE;
1186                     }
1187                   else
1188                     {
1189                       /* Make sure offset agrees with known offset. */
1190                       if (var_offset != ffestorag_offset (vst))
1191                         {
1192                           char io1[40];
1193                           char io2[40];
1194
1195                           sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
1196                           sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
1197                           ffebad_start (FFEBAD_EQUIV_MISMATCH);
1198                           ffebad_string (ffesymbol_text (sv));
1199                           ffebad_string (ffesymbol_text (s));
1200                           ffebad_string (io1);
1201                           ffebad_string (io2);
1202                           ffebad_finish ();
1203                         }
1204                     }
1205                 }               /* (For every equivalence item in the list) */
1206             }                   /* (For every eqv list in the list of equivs
1207                                    for the variable) */
1208         }
1209       while (new_storage && need_storage);
1210
1211       ffeequiv_kill (seq);      /* Kill equiv obj. */
1212     }                           /* (For every variable in the common area) */
1213
1214   return init;
1215 }
1216
1217 /* ffeequiv_merge -- Merge two equivalence objects, return the merged result
1218
1219    ffeequiv eq1;
1220    ffeequiv eq2;
1221    ffelexToken t;  // points to current equivalence item forcing the merge.
1222    eq1 = ffeequiv_merge(eq1,eq2,t);
1223
1224    If the two equivalence objects can be merged, they are, all the
1225    ffesymbols in their lists of lists are adjusted to point to the merged
1226    equivalence object, and the merged object is returned.
1227
1228    Otherwise, the two equivalence objects have different non-NULL common
1229    symbols, so the merge cannot take place.  An error message is issued and
1230    NULL is returned.  */
1231
1232 ffeequiv
1233 ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
1234 {
1235   ffebld list;
1236   ffebld eqs;
1237   ffesymbol symbol;
1238   ffebld last = NULL;
1239
1240   /* If both equivalence objects point to different common-based symbols,
1241      complain.  Of course, one or both might have NULL common symbols now,
1242      and get COMMONed later, but the COMMON statement handler checks for
1243      this. */
1244
1245   if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
1246       && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
1247     {
1248       ffebad_start (FFEBAD_EQUIV_COMMON);
1249       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1250       ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
1251       ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
1252       ffebad_finish ();
1253       return NULL;
1254     }
1255
1256   /* Make eq1 the new, merged object (arbitrarily). */
1257
1258   if (ffeequiv_common (eq1) == NULL)
1259     ffeequiv_set_common (eq1, ffeequiv_common (eq2));
1260
1261   /* If the victim object has any init'ed entities, so does the new object. */
1262
1263   if (eq2->is_init)
1264     eq1->is_init = TRUE;
1265
1266 #if FFEGLOBAL_ENABLED
1267   if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
1268     ffeglobal_init_common (ffeequiv_common (eq1), t);
1269 #endif
1270
1271   /* If the victim object has any SAVEd entities, then the new object has
1272      some. */
1273
1274   if (ffeequiv_is_save (eq2))
1275     ffeequiv_update_save (eq1);
1276
1277   /* If the victim object has any init'd entities, then the new object has
1278      some. */
1279
1280   if (ffeequiv_is_init (eq2))
1281     ffeequiv_update_init (eq1);
1282
1283   /* Adjust all the symbols in the list of lists of equivalences for the
1284      victim equivalence object so they point to the new merged object
1285      instead. */
1286
1287   for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
1288     {
1289       for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
1290         {
1291           symbol = ffeequiv_symbol (ffebld_head (eqs));
1292           if (ffesymbol_equiv (symbol) == eq2)
1293             ffesymbol_set_equiv (symbol, eq1);
1294           else
1295             assert (ffesymbol_equiv (symbol) == eq1);   /* Can see a sym > once. */
1296         }
1297
1298       /* For convenience, remember where the last ITEM in the outer list is. */
1299
1300       if (ffebld_trail (list) == NULL)
1301         {
1302           last = list;
1303           break;
1304         }
1305     }
1306
1307   /* Append the list of lists in the new, merged object to the list of lists
1308      in the victim object, then use the new combined list in the new merged
1309      object. */
1310
1311   ffebld_set_trail (last, ffeequiv_list (eq1));
1312   ffeequiv_set_list (eq1, ffeequiv_list (eq2));
1313
1314   /* Unlink and kill the victim object. */
1315
1316   ffeequiv_kill (eq2);
1317
1318   return eq1;                   /* Return the new merged object. */
1319 }
1320
1321 /* ffeequiv_new -- Create new equivalence object, put in list
1322
1323    ffeequiv eq;
1324    eq = ffeequiv_new();
1325
1326    Creates a new equivalence object and adds it to the list of equivalence
1327    objects.  */
1328
1329 ffeequiv
1330 ffeequiv_new ()
1331 {
1332   ffeequiv eq;
1333
1334   eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
1335   eq->next = (ffeequiv) &ffeequiv_list_.first;
1336   eq->previous = ffeequiv_list_.last;
1337   ffeequiv_set_common (eq, NULL);       /* No COMMON area yet. */
1338   ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */
1339   ffeequiv_set_is_save (eq, FALSE);
1340   ffeequiv_set_is_init (eq, FALSE);
1341   eq->next->previous = eq;
1342   eq->previous->next = eq;
1343
1344   return eq;
1345 }
1346
1347 /* ffeequiv_symbol -- Return symbol for equivalence expression
1348
1349    ffesymbol symbol;
1350    ffebld expr;
1351    symbol = ffeequiv_symbol(expr);
1352
1353    Finds the terminal SYMTER in an equivalence expression and returns the
1354    ffesymbol for it.  */
1355
1356 ffesymbol
1357 ffeequiv_symbol (ffebld expr)
1358 {
1359   assert (expr != NULL);
1360
1361 again:                          /* :::::::::::::::::::: */
1362
1363   switch (ffebld_op (expr))
1364     {
1365     case FFEBLD_opARRAYREF:
1366     case FFEBLD_opSUBSTR:
1367       expr = ffebld_left (expr);
1368       goto again;               /* :::::::::::::::::::: */
1369
1370     case FFEBLD_opSYMTER:
1371       return ffebld_symter (expr);
1372
1373     case FFEBLD_opANY:
1374       return NULL;
1375
1376     default:
1377       assert ("bad eq expr" == NULL);
1378       return NULL;
1379     }
1380 }
1381
1382 /* ffeequiv_update_init -- Update the INIT flag for the area to TRUE
1383
1384    ffeequiv eq;
1385    ffeequiv_update_init(eq);
1386
1387    If the INIT flag for the <eq> object is already set, return.  Else,
1388    set it TRUE and call ffe*_update_init for all objects contained in
1389    this one.  */
1390
1391 void
1392 ffeequiv_update_init (ffeequiv eq)
1393 {
1394   ffebld list;                  /* Current list in list of lists. */
1395   ffebld item;                  /* Current item in current list. */
1396   ffebld expr;                  /* Expression in head of current item. */
1397
1398   if (eq->is_init)
1399     return;
1400
1401   eq->is_init = TRUE;
1402
1403   if ((eq->common != NULL)
1404       && !ffesymbol_is_init (eq->common))
1405     ffesymbol_update_init (eq->common); /* Shouldn't be needed. */
1406
1407   for (list = eq->list; list != NULL; list = ffebld_trail (list))
1408     {
1409       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1410         {
1411           expr = ffebld_head (item);
1412
1413         again:                  /* :::::::::::::::::::: */
1414
1415           switch (ffebld_op (expr))
1416             {
1417             case FFEBLD_opANY:
1418               break;
1419
1420             case FFEBLD_opSYMTER:
1421               if (!ffesymbol_is_init (ffebld_symter (expr)))
1422                 ffesymbol_update_init (ffebld_symter (expr));
1423               break;
1424
1425             case FFEBLD_opARRAYREF:
1426               expr = ffebld_left (expr);
1427               goto again;       /* :::::::::::::::::::: */
1428
1429             case FFEBLD_opSUBSTR:
1430               expr = ffebld_left (expr);
1431               goto again;       /* :::::::::::::::::::: */
1432
1433             default:
1434               assert ("bad op for ffeequiv_update_init" == NULL);
1435               break;
1436             }
1437         }
1438     }
1439 }
1440
1441 /* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
1442
1443    ffeequiv eq;
1444    ffeequiv_update_save(eq);
1445
1446    If the SAVE flag for the <eq> object is already set, return.  Else,
1447    set it TRUE and call ffe*_update_save for all objects contained in
1448    this one.  */
1449
1450 void
1451 ffeequiv_update_save (ffeequiv eq)
1452 {
1453   ffebld list;                  /* Current list in list of lists. */
1454   ffebld item;                  /* Current item in current list. */
1455   ffebld expr;                  /* Expression in head of current item. */
1456
1457   if (eq->is_save)
1458     return;
1459
1460   eq->is_save = TRUE;
1461
1462   if ((eq->common != NULL)
1463       && !ffesymbol_is_save (eq->common))
1464     ffesymbol_update_save (eq->common); /* Shouldn't be needed. */
1465
1466   for (list = eq->list; list != NULL; list = ffebld_trail (list))
1467     {
1468       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1469         {
1470           expr = ffebld_head (item);
1471
1472         again:                  /* :::::::::::::::::::: */
1473
1474           switch (ffebld_op (expr))
1475             {
1476             case FFEBLD_opANY:
1477               break;
1478
1479             case FFEBLD_opSYMTER:
1480               if (!ffesymbol_is_save (ffebld_symter (expr)))
1481                 ffesymbol_update_save (ffebld_symter (expr));
1482               break;
1483
1484             case FFEBLD_opARRAYREF:
1485               expr = ffebld_left (expr);
1486               goto again;       /* :::::::::::::::::::: */
1487
1488             case FFEBLD_opSUBSTR:
1489               expr = ffebld_left (expr);
1490               goto again;       /* :::::::::::::::::::: */
1491
1492             default:
1493               assert ("bad op for ffeequiv_update_save" == NULL);
1494               break;
1495             }
1496         }
1497     }
1498 }