gcc/f/equiv.c

   1 /* equiv.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley (burley@gnu.org).
   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             assert (ffebld_op (subscript) == FFEBLD_opCONTER);
 702             assert (ffeinfo_basictype (ffebld_info (subscript))
 703                     == FFEINFO_basictypeINTEGER);
 704             assert (ffeinfo_kindtype (ffebld_info (subscript))
 705                     == FFEINFO_kindtypeINTEGERDEFAULT);
 706             arrayval = ffebld_constant_integerdefault (ffebld_conter
 707                                                        (subscript));
 708
 709             assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
 710             low = ffebld_left (dim);
 711             high = ffebld_right (dim);
 712
 713             if (low == NULL)
 714               lowbound = 1;
 715             else
 716               {
 717                 assert (ffeinfo_basictype (ffebld_info (low))
 718                         == FFEINFO_basictypeINTEGER);
 719                 assert (ffeinfo_kindtype (ffebld_info (low))
 720                         == FFEINFO_kindtypeINTEGERDEFAULT);
 721                 lowbound
 722                   = ffebld_constant_integerdefault (ffebld_conter (low));
 723               }
 724
 725             assert (ffebld_op (high) == FFEBLD_opCONTER);
 726             assert (ffeinfo_basictype (ffebld_info (high))
 727                     == FFEINFO_basictypeINTEGER);
 728             assert (ffeinfo_kindtype (ffebld_info (high))
 729                     == FFEINFO_kindtypeINTEGER1);
 730             highbound
 731               = ffebld_constant_integerdefault (ffebld_conter (high));
 732
 733             if ((arrayval < lowbound) || (arrayval > highbound))
 734               {
 735                 char rankstr[10];
 736
 737                 sprintf (rankstr, "%d", rank);
 738                 ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
 739                 ffebad_string (ffesymbol_text (sym));
 740                 ffebad_string (rankstr);
 741                 ffebad_finish ();
 742               }
 743
 744             subscripts = ffebld_trail (subscripts);
 745             dims = ffebld_trail (dims);
 746
 747             value += width * (arrayval - lowbound);
 748             if (subscripts != NULL)
 749               width *= highbound - lowbound + 1;
 750           }
 751
 752         if (dims != NULL)
 753           {
 754             ffebad_start (FFEBAD_EQUIV_FEW);
 755             ffebad_string (ffesymbol_text (sym));
 756             ffebad_finish ();
 757             return FALSE;
 758           }
 759
 760         expr = symexp;
 761       }
 762       goto again;               /* :::::::::::::::::::: */
 763
 764     case FFEBLD_opSUBSTR:
 765       {
 766         ffebld begin = ffebld_head (ffebld_right (expr));
 767
 768         expr = ffebld_left (expr);
 769         if (ffebld_op (expr) == FFEBLD_opARRAYREF)
 770           sym = ffebld_symter (ffebld_left (expr));
 771         else if (ffebld_op (expr) == FFEBLD_opSYMTER)
 772           sym = ffebld_symter (expr);
 773         else
 774           sym = NULL;
 775
 776         if ((sym != NULL)
 777             && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
 778           return FALSE;
 779
 780         if (begin == NULL)
 781           value = 0;
 782         else
 783           {
 784             assert (ffebld_op (begin) == FFEBLD_opCONTER);
 785             assert (ffeinfo_basictype (ffebld_info (begin))
 786                     == FFEINFO_basictypeINTEGER);
 787             assert (ffeinfo_kindtype (ffebld_info (begin))
 788                     == FFEINFO_kindtypeINTEGERDEFAULT);
 789
 790             value = ffebld_constant_integerdefault (ffebld_conter (begin));
 791
 792             if ((value < 1)
 793                 || ((sym != NULL)
 794                     && (value > ffesymbol_size (sym))))
 795               {
 796                 ffebad_start (FFEBAD_EQUIV_RANGE);
 797                 ffebad_string (ffesymbol_text (sym));
 798                 ffebad_finish ();
 799               }
 800
 801             --value;
 802           }
 803         if ((sym != NULL)
 804             && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
 805           {
 806             ffebad_start (FFEBAD_EQUIV_SUBSTR);
 807             ffebad_string (ffesymbol_text (sym));
 808             ffebad_finish ();
 809             value = 0;
 810           }
 811       }
 812       goto again;               /* :::::::::::::::::::: */
 813
 814     default:
 815       assert ("bad op" == NULL);
 816       return FALSE;
 817     }
 818
 819 }
 820
 821 /* ffeequiv_add -- Add list of equivalences to list of lists for eq object
 822
 823    ffeequiv eq;
 824    ffebld list;
 825    ffelexToken t;  // points to first item in equivalence list
 826    ffeequiv_add(eq,list,t);
 827
 828    Check the list to make sure only one common symbol is involved (even
 829    if multiple times) and agrees with the common symbol for the equivalence
 830    object (or it has no common symbol until now).  Prepend (or append, it
 831    doesn't matter) the list to the list of lists for the equivalence object.
 832    Otherwise report an error and return.  */
 833
 834 void
 835 ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
 836 {
 837   ffebld item;
 838   ffesymbol symbol;
 839   ffesymbol common = ffeequiv_common (eq);
 840
 841   for (item = list; item != NULL; item = ffebld_trail (item))
 842     {
 843       symbol = ffeequiv_symbol (ffebld_head (item));
 844
 845       if (ffesymbol_common (symbol) != NULL)    /* Is symbol known in COMMON yet? */
 846         {
 847           if (common == NULL)
 848             common = ffesymbol_common (symbol);
 849           else if (common != ffesymbol_common (symbol))
 850             {
 851               /* Yes, and symbol disagrees with others on the COMMON area. */
 852               ffebad_start (FFEBAD_EQUIV_COMMON);
 853               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 854               ffebad_string (ffesymbol_text (common));
 855               ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
 856               ffebad_finish ();
 857               return;
 858             }
 859         }
 860     }
 861
 862   if ((common != NULL)
 863       && (ffeequiv_common (eq) == NULL))        /* Is COMMON involved already? */
 864     ffeequiv_set_common (eq, common);   /* No, but it is now. */
 865
 866   for (item = list; item != NULL; item = ffebld_trail (item))
 867     {
 868       symbol = ffeequiv_symbol (ffebld_head (item));
 869
 870       if (ffesymbol_equiv (symbol) == NULL)
 871         ffesymbol_set_equiv (symbol, eq);
 872       else
 873         assert (ffesymbol_equiv (symbol) == eq);
 874
 875       if (ffesymbol_common (symbol) == NULL)    /* Is symbol in a COMMON
 876                                                    area? */
 877         {                       /* No (at least not yet). */
 878           if (ffesymbol_is_save (symbol))
 879             ffeequiv_update_save (eq);  /* EQUIVALENCE has >=1 SAVEd entity. */
 880           if (ffesymbol_is_init (symbol))
 881             ffeequiv_update_init (eq);  /* EQUIVALENCE has >=1 init'd entity. */
 882           continue;             /* Nothing more to do here. */
 883         }
 884
 885 #if FFEGLOBAL_ENABLED
 886       if (ffesymbol_is_init (symbol))
 887         ffeglobal_init_common (ffesymbol_common (symbol), t);
 888 #endif
 889
 890       if (ffesymbol_is_save (ffesymbol_common (symbol)))
 891         ffeequiv_update_save (eq);      /* EQUIVALENCE is in a SAVEd COMMON block. */
 892       if (ffesymbol_is_init (ffesymbol_common (symbol)))
 893         ffeequiv_update_init (eq);      /* EQUIVALENCE is in a init'd COMMON block. */
 894     }
 895
 896   ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
 897 }
 898
 899 /* ffeequiv_dump -- Dump info on equivalence object
 900
 901    ffeequiv eq;
 902    ffeequiv_dump(eq);  */
 903
 904 #if FFECOM_targetCURRENT == FFECOM_targetFFE
 905 void
 906 ffeequiv_dump (ffeequiv eq)
 907 {
 908   if (ffeequiv_common (eq) != NULL)
 909     fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
 910   ffebld_dump (ffeequiv_list (eq));
 911 }
 912 #endif
 913
 914 /* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
 915
 916    ffeequiv_exec_transition();  */
 917
 918 void
 919 ffeequiv_exec_transition ()
 920 {
 921   while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
 922     ffeequiv_layout_local_ (ffeequiv_list_.first);
 923 }
 924
 925 /* ffeequiv_init_2 -- Initialize for new program unit
 926
 927    ffeequiv_init_2();
 928
 929    Initializes the list of equivalences.  */
 930
 931 void
 932 ffeequiv_init_2 ()
 933 {
 934   ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
 935   ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
 936 }
 937
 938 /* ffeequiv_kill -- Kill equivalence object after removing from list
 939
 940    ffeequiv eq;
 941    ffeequiv_kill(eq);
 942
 943    Removes equivalence object from master list, then kills it.  */
 944
 945 void
 946 ffeequiv_kill (ffeequiv victim)
 947 {
 948   victim->next->previous = victim->previous;
 949   victim->previous->next = victim->next;
 950   if (ffe_is_do_internal_checks ())
 951     {
 952       ffebld list;
 953       ffebld item;
 954       ffebld expr;
 955
 956       /* Assert that nobody our victim points to still points to it.  */
 957
 958       assert ((victim->common == NULL)
 959               || (ffesymbol_equiv (victim->common) == NULL));
 960
 961       for (list = victim->list; list != NULL; list = ffebld_trail (list))
 962         {
 963           for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
 964             {
 965               ffesymbol sym;
 966
 967               expr = ffebld_head (item);
 968               sym = ffeequiv_symbol (expr);
 969               if (sym == NULL)
 970                 continue;
 971               assert (ffesymbol_equiv (sym) != victim);
 972             }
 973         }
 974     }
 975   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
 976 }
 977
 978 /* ffeequiv_layout_cblock -- Lay out storage for common area
 979
 980    ffestorag st;
 981    if (ffeequiv_layout_cblock(st))
 982        // at least one equiv'd symbol has init/accretion expr.
 983
 984    Now that the explicitly COMMONed variables in the common area (whose
 985    ffestorag object is passed) have been laid out, lay out the storage
 986    for all variables equivalenced into the area by making subordinate
 987    ffestorag objects for them.  */
 988
 989 bool
 990 ffeequiv_layout_cblock (ffestorag st)
 991 {
 992   ffesymbol s = ffestorag_symbol (st);  /* CBLOCK symbol. */
 993   ffebld list;                  /* List of explicit common vars, in order, in
 994                                    s. */
 995   ffebld item;                  /* List of list of equivalences in a given
 996                                    explicit common var. */
 997   ffebld root;                  /* Expression for (1st) explicit common var
 998                                    in list of eqs. */
 999   ffestorag rst;                /* Storage for root. */
1000   ffetargetOffset root_offset;  /* Offset for root into common area. */
1001   ffesymbol sr;                 /* Root itself. */
1002   ffeequiv seq;                 /* Its equivalence object, if any. */
1003   ffebld var;                   /* Expression for equivalence. */
1004   ffestorag vst;                /* Storage for var. */
1005   ffetargetOffset var_offset;   /* Offset for var into common area. */
1006   ffesymbol sv;                 /* Var itself. */
1007   ffebld altroot;               /* Alternate root. */
1008   ffesymbol altrootsym;         /* Alternate root symbol. */
1009   ffetargetAlign alignment;
1010   ffetargetAlign modulo;
1011   ffetargetAlign pad;
1012   ffetargetOffset size;
1013   ffetargetOffset num_elements;
1014   bool new_storage;             /* Established new storage info. */
1015   bool need_storage;            /* Have need for more storage info. */
1016   bool ok;
1017   bool init = FALSE;
1018
1019   assert (st != NULL);
1020   assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
1021   assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
1022
1023   for (list = ffesymbol_commonlist (ffestorag_symbol (st));
1024        list != NULL;
1025        list = ffebld_trail (list))
1026     {                           /* For every variable in the common area */
1027       assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
1028       sr = ffebld_symter (ffebld_head (list));
1029       if ((seq = ffesymbol_equiv (sr)) == NULL)
1030         continue;               /* No equivalences to process. */
1031       rst = ffesymbol_storage (sr);
1032       if (rst == NULL)
1033         {
1034           assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
1035           continue;
1036         }
1037       ffesymbol_set_equiv (sr, NULL);   /* Cancel ref to equiv obj. */
1038       do
1039         {
1040           new_storage = FALSE;
1041           need_storage = FALSE;
1042           for (item = ffeequiv_list (seq);      /* Get list of equivs. */
1043                item != NULL;
1044                item = ffebld_trail (item))
1045             {                   /* For every eqv list in the list of equivs
1046                                    for the variable */
1047               altroot = NULL;
1048               altrootsym = NULL;
1049               for (root = ffebld_head (item);
1050                    root != NULL;
1051                    root = ffebld_trail (root))
1052                 {               /* For every equivalence item in the list */
1053                   sv = ffeequiv_symbol (ffebld_head (root));
1054                   if (sv == sr)
1055                     break;      /* Found first mention of "rooted" symbol. */
1056                   if (ffesymbol_storage (sv) != NULL)
1057                     {
1058                       altroot = root;   /* If no mention, use this guy
1059                                            instead. */
1060                       altrootsym = sv;
1061                     }
1062                 }
1063               if (root != NULL)
1064                 {
1065                   root = ffebld_head (root);    /* Lose its opITEM. */
1066                   ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
1067                                          ffestorag_offset (rst), TRUE);
1068                   /* Equiv point prior to start of common area? */
1069                 }
1070               else if (altroot != NULL)
1071                 {
1072                   /* Equiv point prior to start of common area? */
1073                   root = ffebld_head (altroot);
1074                   ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
1075                                          FALSE,
1076                          ffestorag_offset (ffesymbol_storage (altrootsym)),
1077                                          TRUE);
1078                   ffesymbol_set_equiv (altrootsym, NULL);
1079                 }
1080               else
1081                 /* No rooted symbol in list of equivalences! */
1082                 {               /* Assume this was due to opANY and ignore
1083                                    this list for now. */
1084                   need_storage = TRUE;
1085                   continue;
1086                 }
1087
1088               /* We now know the root symbol and the operating offset of that
1089                  root into the common area.  The other expressions in the
1090                  list all identify an initial storage unit that must have the
1091                  same offset. */
1092
1093               for (var = ffebld_head (item);
1094                    var != NULL;
1095                    var = ffebld_trail (var))
1096                 {               /* For every equivalence item in the list */
1097                   if (ffebld_head (var) == root)
1098                     continue;   /* Except root, of course. */
1099                   sv = ffeequiv_symbol (ffebld_head (var));
1100                   if (sv == NULL)
1101                     continue;   /* Except erroneous stuff (opANY). */
1102                   ffesymbol_set_equiv (sv, NULL);       /* Don't need this ref
1103                                                            anymore. */
1104                   if (!ok
1105                       || !ffeequiv_offset_ (&var_offset, sv,
1106                                             ffebld_head (var), TRUE,
1107                                             root_offset, TRUE))
1108                     continue;   /* Can't do negative offset wrt COMMON. */
1109
1110                   if (ffesymbol_rank (sv) == 0)
1111                     num_elements = 1;
1112                   else
1113                     num_elements = ffebld_constant_integerdefault
1114                       (ffebld_conter (ffesymbol_arraysize (sv)));
1115                   ffetarget_layout (ffesymbol_text (sv), &alignment,
1116                                     &modulo, &size,
1117                                     ffesymbol_basictype (sv),
1118                                     ffesymbol_kindtype (sv),
1119                                     ffesymbol_size (sv), num_elements);
1120                   pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
1121                                          ffestorag_ptr_to_modulo (st),
1122                                          var_offset, alignment, modulo);
1123                   if (pad != 0)
1124                     {
1125                       ffebad_start (FFEBAD_EQUIV_ALIGN);
1126                       ffebad_string (ffesymbol_text (sv));
1127                       ffebad_finish ();
1128                       continue;
1129                     }
1130
1131                   if ((vst = ffesymbol_storage (sv)) == NULL)
1132                     {           /* Create new ffestorag object, extend
1133                                    cblock. */
1134                       new_storage = TRUE;
1135                       vst = ffestorag_new (ffestorag_list_equivs (st));
1136                       ffestorag_set_parent (vst, st);   /* Initializations
1137                                                            happen there. */
1138                       ffestorag_set_init (vst, NULL);
1139                       ffestorag_set_accretion (vst, NULL);
1140                       ffestorag_set_symbol (vst, sv);
1141                       ffestorag_set_size (vst, size);
1142                       ffestorag_set_offset (vst, var_offset);
1143                       ffestorag_set_alignment (vst, alignment);
1144                       ffestorag_set_modulo (vst, modulo);
1145                       ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
1146                       ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
1147                       ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
1148                       ffestorag_set_typesymbol (vst, sv);
1149                       ffestorag_set_is_save (vst, FALSE);       /* Assume FALSE... */
1150                       if (ffestorag_is_save (st))       /* ...update TRUE */
1151                         ffestorag_update_save (vst);    /* if needed. */
1152                       ffestorag_set_is_init (vst, FALSE);       /* Assume FALSE... */
1153                       if (ffestorag_is_init (st))       /* ...update TRUE */
1154                         ffestorag_update_init (vst);    /* if needed. */
1155                       if (!ffetarget_offset_add (&size, var_offset, size))
1156                         /* Find one size of common block, complain if
1157                            overflow. */
1158                         ffetarget_offset_overflow (ffesymbol_text (s));
1159                       else if (size > ffestorag_size (st))
1160                         /* Extend common. */
1161                         ffestorag_set_size (st, size);
1162                       ffesymbol_set_storage (sv, vst);
1163                       ffesymbol_set_common (sv, s);
1164                       ffesymbol_signal_unreported (sv);
1165                       ffestorag_update (st, sv, ffesymbol_basictype (sv),
1166                                         ffesymbol_kindtype (sv));
1167                       if (ffesymbol_is_init (sv))
1168                         init = TRUE;
1169                     }
1170                   else
1171                     {
1172                       /* Make sure offset agrees with known offset. */
1173                       if (var_offset != ffestorag_offset (vst))
1174                         {
1175                           char io1[40];
1176                           char io2[40];
1177
1178                           sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset);
1179                           sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst));
1180                           ffebad_start (FFEBAD_EQUIV_MISMATCH);
1181                           ffebad_string (ffesymbol_text (sv));
1182                           ffebad_string (ffesymbol_text (s));
1183                           ffebad_string (io1);
1184                           ffebad_string (io2);
1185                           ffebad_finish ();
1186                         }
1187                     }
1188                 }               /* (For every equivalence item in the list) */
1189             }                   /* (For every eqv list in the list of equivs
1190                                    for the variable) */
1191         }
1192       while (new_storage && need_storage);
1193
1194       ffeequiv_kill (seq);      /* Kill equiv obj. */
1195     }                           /* (For every variable in the common area) */
1196
1197   return init;
1198 }
1199
1200 /* ffeequiv_merge -- Merge two equivalence objects, return the merged result
1201
1202    ffeequiv eq1;
1203    ffeequiv eq2;
1204    ffelexToken t;  // points to current equivalence item forcing the merge.
1205    eq1 = ffeequiv_merge(eq1,eq2,t);
1206
1207    If the two equivalence objects can be merged, they are, all the
1208    ffesymbols in their lists of lists are adjusted to point to the merged
1209    equivalence object, and the merged object is returned.
1210
1211    Otherwise, the two equivalence objects have different non-NULL common
1212    symbols, so the merge cannot take place.  An error message is issued and
1213    NULL is returned.  */
1214
1215 ffeequiv
1216 ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
1217 {
1218   ffebld list;
1219   ffebld eqs;
1220   ffesymbol symbol;
1221   ffebld last = NULL;
1222
1223   /* If both equivalence objects point to different common-based symbols,
1224      complain.  Of course, one or both might have NULL common symbols now,
1225      and get COMMONed later, but the COMMON statement handler checks for
1226      this. */
1227
1228   if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
1229       && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
1230     {
1231       ffebad_start (FFEBAD_EQUIV_COMMON);
1232       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1233       ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
1234       ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
1235       ffebad_finish ();
1236       return NULL;
1237     }
1238
1239   /* Make eq1 the new, merged object (arbitrarily). */
1240
1241   if (ffeequiv_common (eq1) == NULL)
1242     ffeequiv_set_common (eq1, ffeequiv_common (eq2));
1243
1244   /* If the victim object has any init'ed entities, so does the new object. */
1245
1246   if (eq2->is_init)
1247     eq1->is_init = TRUE;
1248
1249 #if FFEGLOBAL_ENABLED
1250   if (eq1->is_init && (ffeequiv_common (eq1) != NULL))
1251     ffeglobal_init_common (ffeequiv_common (eq1), t);
1252 #endif
1253
1254   /* If the victim object has any SAVEd entities, then the new object has
1255      some. */
1256
1257   if (ffeequiv_is_save (eq2))
1258     ffeequiv_update_save (eq1);
1259
1260   /* If the victim object has any init'd entities, then the new object has
1261      some. */
1262
1263   if (ffeequiv_is_init (eq2))
1264     ffeequiv_update_init (eq1);
1265
1266   /* Adjust all the symbols in the list of lists of equivalences for the
1267      victim equivalence object so they point to the new merged object
1268      instead. */
1269
1270   for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
1271     {
1272       for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
1273         {
1274           symbol = ffeequiv_symbol (ffebld_head (eqs));
1275           if (ffesymbol_equiv (symbol) == eq2)
1276             ffesymbol_set_equiv (symbol, eq1);
1277           else
1278             assert (ffesymbol_equiv (symbol) == eq1);   /* Can see a sym > once. */
1279         }
1280
1281       /* For convenience, remember where the last ITEM in the outer list is. */
1282
1283       if (ffebld_trail (list) == NULL)
1284         {
1285           last = list;
1286           break;
1287         }
1288     }
1289
1290   /* Append the list of lists in the new, merged object to the list of lists
1291      in the victim object, then use the new combined list in the new merged
1292      object. */
1293
1294   ffebld_set_trail (last, ffeequiv_list (eq1));
1295   ffeequiv_set_list (eq1, ffeequiv_list (eq2));
1296
1297   /* Unlink and kill the victim object. */
1298
1299   ffeequiv_kill (eq2);
1300
1301   return eq1;                   /* Return the new merged object. */
1302 }
1303
1304 /* ffeequiv_new -- Create new equivalence object, put in list
1305
1306    ffeequiv eq;
1307    eq = ffeequiv_new();
1308
1309    Creates a new equivalence object and adds it to the list of equivalence
1310    objects.  */
1311
1312 ffeequiv
1313 ffeequiv_new ()
1314 {
1315   ffeequiv eq;
1316
1317   eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
1318   eq->next = (ffeequiv) &ffeequiv_list_.first;
1319   eq->previous = ffeequiv_list_.last;
1320   ffeequiv_set_common (eq, NULL);       /* No COMMON area yet. */
1321   ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */
1322   ffeequiv_set_is_save (eq, FALSE);
1323   ffeequiv_set_is_init (eq, FALSE);
1324   eq->next->previous = eq;
1325   eq->previous->next = eq;
1326
1327   return eq;
1328 }
1329
1330 /* ffeequiv_symbol -- Return symbol for equivalence expression
1331
1332    ffesymbol symbol;
1333    ffebld expr;
1334    symbol = ffeequiv_symbol(expr);
1335
1336    Finds the terminal SYMTER in an equivalence expression and returns the
1337    ffesymbol for it.  */
1338
1339 ffesymbol
1340 ffeequiv_symbol (ffebld expr)
1341 {
1342   assert (expr != NULL);
1343
1344 again:                          /* :::::::::::::::::::: */
1345
1346   switch (ffebld_op (expr))
1347     {
1348     case FFEBLD_opARRAYREF:
1349     case FFEBLD_opSUBSTR:
1350       expr = ffebld_left (expr);
1351       goto again;               /* :::::::::::::::::::: */
1352
1353     case FFEBLD_opSYMTER:
1354       return ffebld_symter (expr);
1355
1356     case FFEBLD_opANY:
1357       return NULL;
1358
1359     default:
1360       assert ("bad eq expr" == NULL);
1361       return NULL;
1362     }
1363 }
1364
1365 /* ffeequiv_update_init -- Update the INIT flag for the area to TRUE
1366
1367    ffeequiv eq;
1368    ffeequiv_update_init(eq);
1369
1370    If the INIT flag for the <eq> object is already set, return.  Else,
1371    set it TRUE and call ffe*_update_init for all objects contained in
1372    this one.  */
1373
1374 void
1375 ffeequiv_update_init (ffeequiv eq)
1376 {
1377   ffebld list;                  /* Current list in list of lists. */
1378   ffebld item;                  /* Current item in current list. */
1379   ffebld expr;                  /* Expression in head of current item. */
1380
1381   if (eq->is_init)
1382     return;
1383
1384   eq->is_init = TRUE;
1385
1386   if ((eq->common != NULL)
1387       && !ffesymbol_is_init (eq->common))
1388     ffesymbol_update_init (eq->common); /* Shouldn't be needed. */
1389
1390   for (list = eq->list; list != NULL; list = ffebld_trail (list))
1391     {
1392       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1393         {
1394           expr = ffebld_head (item);
1395
1396         again:                  /* :::::::::::::::::::: */
1397
1398           switch (ffebld_op (expr))
1399             {
1400             case FFEBLD_opANY:
1401               break;
1402
1403             case FFEBLD_opSYMTER:
1404               if (!ffesymbol_is_init (ffebld_symter (expr)))
1405                 ffesymbol_update_init (ffebld_symter (expr));
1406               break;
1407
1408             case FFEBLD_opARRAYREF:
1409               expr = ffebld_left (expr);
1410               goto again;       /* :::::::::::::::::::: */
1411
1412             case FFEBLD_opSUBSTR:
1413               expr = ffebld_left (expr);
1414               goto again;       /* :::::::::::::::::::: */
1415
1416             default:
1417               assert ("bad op for ffeequiv_update_init" == NULL);
1418               break;
1419             }
1420         }
1421     }
1422 }
1423
1424 /* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
1425
1426    ffeequiv eq;
1427    ffeequiv_update_save(eq);
1428
1429    If the SAVE flag for the <eq> object is already set, return.  Else,
1430    set it TRUE and call ffe*_update_save for all objects contained in
1431    this one.  */
1432
1433 void
1434 ffeequiv_update_save (ffeequiv eq)
1435 {
1436   ffebld list;                  /* Current list in list of lists. */
1437   ffebld item;                  /* Current item in current list. */
1438   ffebld expr;                  /* Expression in head of current item. */
1439
1440   if (eq->is_save)
1441     return;
1442
1443   eq->is_save = TRUE;
1444
1445   if ((eq->common != NULL)
1446       && !ffesymbol_is_save (eq->common))
1447     ffesymbol_update_save (eq->common); /* Shouldn't be needed. */
1448
1449   for (list = eq->list; list != NULL; list = ffebld_trail (list))
1450     {
1451       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
1452         {
1453           expr = ffebld_head (item);
1454
1455         again:                  /* :::::::::::::::::::: */
1456
1457           switch (ffebld_op (expr))
1458             {
1459             case FFEBLD_opANY:
1460               break;
1461
1462             case FFEBLD_opSYMTER:
1463               if (!ffesymbol_is_save (ffebld_symter (expr)))
1464                 ffesymbol_update_save (ffebld_symter (expr));
1465               break;
1466
1467             case FFEBLD_opARRAYREF:
1468               expr = ffebld_left (expr);
1469               goto again;       /* :::::::::::::::::::: */
1470
1471             case FFEBLD_opSUBSTR:
1472               expr = ffebld_left (expr);
1473               goto again;       /* :::::::::::::::::::: */
1474
1475             default:
1476               assert ("bad op for ffeequiv_update_save" == NULL);
1477               break;
1478             }
1479         }
1480     }
1481 }