contrib/gcc-3.4/gcc/f/equiv.c

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