gcc/f/equiv.c

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