gcc/fortran/trans-common.c

   1 /* Common block and equivalence list handling
   2    Copyright (C) 2000, 2003 Free Software Foundation, Inc.
   3    Contributed by Canqun Yang <canqun@nudt.edu.cn>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22 /* The core algorithm is based on Andy Vaught's g95 tree.  Also the
  23    way to build UNION_TYPE is borrowed from Richard Henderson.
  24
  25    Transform common blocks.  An integral part of this is processing
  26    equvalence variables.  Equivalenced variables that are not in a
  27    common block end up in a private block of their own.
  28
  29    Each common block or local equivalence list is declared as a union.
  30    Variables within the block are represented as a field within the
  31    block with the proper offset.
  32
  33    So if two variables are equivalenced, they just point to a common
  34    area in memory.
  35
  36    Mathematically, laying out an equivalence block is equivalent to
  37    solving a linear system of equations.  The matrix is usually a
  38    sparse matrix in which each row contains all zero elements except
  39    for a +1 and a -1, a sort of a generalized Vandermonde matrix.  The
  40    matrix is usually block diagonal.  The system can be
  41    overdetermined, underdetermined or have a unique solution.  If the
  42    system is inconsistent, the program is not standard conforming.
  43    The solution vector is integral, since all of the pivots are +1 or -1.
  44
  45    How we lay out an equivalence block is a little less complicated.
  46    In an equivalence list with n elements, there are n-1 conditions to
  47    be satisfied.  The conditions partition the variables into what we
  48    will call segments.  If A and B are equivalenced then A and B are
  49    in the same segment.  If B and C are equivalenced as well, then A,
  50    B and C are in a segment and so on.  Each segment is a block of
  51    memory that has one or more variables equivalenced in some way.  A
  52    common block is made up of a series of segments that are joined one
  53    after the other.  In the linear system, a segment is a block
  54    diagonal.
  55
  56    To lay out a segment we first start with some variable and
  57    determine its length.  The first variable is assumed to start at
  58    offset one and extends to however long it is.  We then traverse the
  59    list of equivalences to find an unused condition that involves at
  60    least one of the variables currently in the segment.
  61
  62    Each equivalence condition amounts to the condition B+b=C+c where B
  63    and C are the offsets of the B and C variables, and b and c are
  64    constants which are nonzero for array elements, substrings or
  65    structure components.  So for
  66
  67      EQUIVALENCE(B(2), C(3))
  68    we have
  69      B + 2*size of B's elements = C + 3*size of C's elements.
  70
  71    If B and C are known we check to see if the condition already
  72    holds.  If B is known we can solve for C.  Since we know the length
  73    of C, we can see if the minimum and maximum extents of the segment
  74    are affected.  Eventually, we make a full pass through the
  75    equivalence list without finding any new conditions and the segment
  76    is fully specified.
  77
  78    At this point, the segment is added to the current common block.
  79    Since we know the minimum extent of the segment, everything in the
  80    segment is translated to its position in the common block.  The
  81    usual case here is that there are no equivalence statements and the
  82    common block is series of segments with one variable each, which is
  83    a diagonal matrix in the matrix formulation.
  84
  85    Each segment is described by a chain of segment_info structures.  Each
  86    segment_info structure describes the extents of a single varible within
  87    the segment.  This list is maintained in the order the elements are
  88    positioned withing the segment.  If two elements have the same starting
  89    offset the smaller will come first.  If they also have the same size their
  90    ordering is undefined.
  91
  92    Once all common blocks have been created, the list of equivalences
  93    is examined for still-unused equivalence conditions.  We create a
  94    block for each merged equivalence list.  */
  95
  96 #include "config.h"
  97 #include "system.h"
  98 #include "coretypes.h"
  99 #include "tree.h"
 100 #include "toplev.h"
 101 #include "tm.h"
 102 #include "gfortran.h"
 103 #include "trans.h"
 104 #include "trans-types.h"
 105 #include "trans-const.h"
 106 #include <assert.h>
 107
 108
 109 typedef struct segment_info
 110 {
 111   gfc_symbol *sym;
 112   HOST_WIDE_INT offset;
 113   HOST_WIDE_INT length;
 114   tree field;
 115   struct segment_info *next;
 116 } segment_info;
 117
 118 static segment_info *current_segment, *current_common;
 119 static HOST_WIDE_INT current_offset;
 120 static gfc_namespace *gfc_common_ns = NULL;
 121
 122 #define get_segment_info() gfc_getmem (sizeof (segment_info))
 123
 124 #define BLANK_COMMON_NAME "__BLNK__"
 125
 126
 127 /* Add combine segment V and segement LIST.  */
 128
 129 static segment_info *
 130 add_segments (segment_info *list, segment_info *v)
 131 {
 132   segment_info *s;
 133   segment_info *p;
 134   segment_info *next;
 135
 136   p = NULL;
 137   s = list;
 138
 139   while (v)
 140     {
 141       /* Find the location of the new element.  */
 142       while (s)
 143         {
 144           if (v->offset < s->offset)
 145             break;
 146           if (v->offset == s->offset
 147               && v->length <= s->length)
 148             break;
 149
 150           p = s;
 151           s = s->next;
 152         }
 153
 154       /* Insert the new element in between p and s.  */
 155       next = v->next;
 156       v->next = s;
 157       if (p == NULL)
 158         list = v;
 159       else
 160         p->next = v;
 161
 162       p = v;
 163       v = next;
 164     }
 165   return list;
 166 }
 167
 168 /* Construct mangled common block name from symbol name.  */
 169
 170 static tree
 171 gfc_sym_mangled_common_id (gfc_symbol *sym)
 172 {
 173   int has_underscore;
 174   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 175
 176   if (strcmp (sym->name, BLANK_COMMON_NAME) == 0)
 177     return get_identifier (sym->name);
 178   if (gfc_option.flag_underscoring)
 179     {
 180       has_underscore = strchr (sym->name, '_') != 0;
 181       if (gfc_option.flag_second_underscore && has_underscore)
 182         snprintf (name, sizeof name, "%s__", sym->name);
 183       else
 184         snprintf (name, sizeof name, "%s_", sym->name);
 185       return get_identifier (name);
 186     }
 187   else
 188     return get_identifier (sym->name);
 189 }
 190
 191
 192 /* Build a filed declaration for a common variable or a local equivalence
 193    object.  */
 194
 195 static tree
 196 build_field (segment_info *h, tree union_type, record_layout_info rli)
 197 {
 198   tree type = gfc_sym_type (h->sym);
 199   tree name = get_identifier (h->sym->name);
 200   tree field = build_decl (FIELD_DECL, name, type);
 201   HOST_WIDE_INT offset = h->offset;
 202   unsigned HOST_WIDE_INT desired_align, known_align;
 203
 204   known_align = (offset & -offset) * BITS_PER_UNIT;
 205   if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
 206     known_align = BIGGEST_ALIGNMENT;
 207
 208   desired_align = update_alignment_for_field (rli, field, known_align);
 209   if (desired_align > known_align)
 210     DECL_PACKED (field) = 1;
 211
 212   DECL_FIELD_CONTEXT (field) = union_type;
 213   DECL_FIELD_OFFSET (field) = size_int (offset);
 214   DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
 215   SET_DECL_OFFSET_ALIGN (field, known_align);
 216
 217   rli->offset = size_binop (MAX_EXPR, rli->offset,
 218                             size_binop (PLUS_EXPR,
 219                                         DECL_FIELD_OFFSET (field),
 220                                         DECL_SIZE_UNIT (field)));
 221   return field;
 222 }
 223
 224
 225 /* Get storage for local equivalence.  */
 226
 227 static tree
 228 build_equiv_decl (tree union_type, bool is_init)
 229 {
 230   tree decl;
 231
 232   if (is_init)
 233     {
 234       decl = gfc_create_var (union_type, "equiv");
 235       TREE_STATIC (decl) = 1;
 236       return decl;
 237     }
 238
 239   decl = build_decl (VAR_DECL, NULL, union_type);
 240   DECL_ARTIFICIAL (decl) = 1;
 241
 242   DECL_COMMON (decl) = 1;
 243
 244   TREE_ADDRESSABLE (decl) = 1;
 245   TREE_USED (decl) = 1;
 246   gfc_add_decl_to_function (decl);
 247
 248   return decl;
 249 }
 250
 251
 252 /* Get storage for common block.  */
 253
 254 static tree
 255 build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
 256 {
 257   gfc_symbol *common_sym;
 258   tree decl;
 259
 260   /* Create a namespace to store symbols for common blocks.  */
 261   if (gfc_common_ns == NULL)
 262     gfc_common_ns = gfc_get_namespace (NULL);
 263
 264   gfc_get_symbol (sym->name, gfc_common_ns, &common_sym);
 265   decl = common_sym->backend_decl;
 266
 267   /* Update the size of this common block as needed.  */
 268   if (decl != NULL_TREE)
 269     {
 270       tree size = TYPE_SIZE_UNIT (union_type);
 271       if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
 272         {
 273           /* Named common blocks of the same name shall be of the same size
 274              in all scoping units of a program in which they appear, but
 275              blank common blocks may be of different sizes.  */
 276           if (strcmp (sym->name, BLANK_COMMON_NAME))
 277               gfc_warning ("Named COMMON block '%s' at %L shall be of the "
 278                            "same size", sym->name, &sym->declared_at);
 279           DECL_SIZE_UNIT (decl) = size;
 280         }
 281      }
 282
 283   /* If this common block has been declared in a previous program unit,
 284      and either it is already initialized or there is no new initialization
 285      for it, just return.  */
 286   if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
 287     return decl;
 288
 289   /* If there is no backend_decl for the common block, build it.  */
 290   if (decl == NULL_TREE)
 291     {
 292       decl = build_decl (VAR_DECL, get_identifier (sym->name), union_type);
 293       SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym));
 294       TREE_PUBLIC (decl) = 1;
 295       TREE_STATIC (decl) = 1;
 296       DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
 297       DECL_USER_ALIGN (decl) = 0;
 298
 299       /* Place the back end declaration for this common block in
 300          GLOBAL_BINDING_LEVEL.  */
 301       common_sym->backend_decl = pushdecl_top_level (decl);
 302     }
 303
 304   /* Has no initial values.  */
 305   if (!is_init)
 306     {
 307       DECL_INITIAL (decl) = NULL_TREE;
 308       DECL_COMMON (decl) = 1;
 309       DECL_DEFER_OUTPUT (decl) = 1;
 310
 311     }
 312   else
 313     {
 314       DECL_INITIAL (decl) = error_mark_node;
 315       DECL_COMMON (decl) = 0;
 316       DECL_DEFER_OUTPUT (decl) = 0;
 317     }
 318   return decl;
 319 }
 320
 321
 322 /* Declare memory for the common block or local equivalence, and create
 323    backend declarations for all of the elements.  */
 324
 325 static void
 326 create_common (gfc_symbol *sym)
 327 {
 328   segment_info *h, *next_s;
 329   tree union_type;
 330   tree *field_link;
 331   record_layout_info rli;
 332   tree decl;
 333   bool is_init = false;
 334
 335   /* Declare the variables inside the common block.  */
 336   union_type = make_node (UNION_TYPE);
 337   rli = start_record_layout (union_type);
 338   field_link = &TYPE_FIELDS (union_type);
 339
 340   for (h = current_common; h; h = next_s)
 341     {
 342       tree field;
 343       field = build_field (h, union_type, rli);
 344
 345       /* Link the field into the type.  */
 346       *field_link = field;
 347       field_link = &TREE_CHAIN (field);
 348       h->field = field;
 349       /* Has initial value.  */
 350       if (h->sym->value)
 351         is_init = true;
 352
 353       next_s = h->next;
 354     }
 355   finish_record_layout (rli, true);
 356
 357   if (sym)
 358     decl = build_common_decl (sym, union_type, is_init);
 359   else
 360     decl = build_equiv_decl (union_type, is_init);
 361
 362   if (is_init)
 363     {
 364       tree list, ctor, tmp;
 365       gfc_se se;
 366       HOST_WIDE_INT offset = 0;
 367
 368       list = NULL_TREE;
 369       for (h = current_common; h; h = h->next)
 370         {
 371           if (h->sym->value)
 372             {
 373               if (h->offset < offset)
 374                 {
 375                     /* We have overlapping initializers.  It could either be
 376                        partially initilalized arrays (lagal), or the user
 377                        specified multiple initial values (illegal).
 378                        We don't implement this yet, so bail out.  */
 379                   gfc_todo_error ("Initialization of overlapping variables");
 380                 }
 381               if (h->sym->attr.dimension)
 382                 {
 383                   tmp = gfc_conv_array_initializer (TREE_TYPE (h->field),
 384                                                   h->sym->value);
 385                   list = tree_cons (h->field, tmp, list);
 386                 }
 387               else
 388                 {
 389                   switch (h->sym->ts.type)
 390                     {
 391                     case BT_CHARACTER:
 392                       se.expr = gfc_conv_string_init
 393                         (h->sym->ts.cl->backend_decl, h->sym->value);
 394                       break;
 395
 396                     case BT_DERIVED:
 397                       gfc_init_se (&se, NULL);
 398                       gfc_conv_structure (&se, sym->value, 1);
 399                       break;
 400
 401                     default:
 402                       gfc_init_se (&se, NULL);
 403                       gfc_conv_expr (&se, h->sym->value);
 404                       break;
 405                     }
 406                   list = tree_cons (h->field, se.expr, list);
 407                 }
 408               offset = h->offset + h->length;
 409             }
 410         }
 411       assert (list);
 412       ctor = build1 (CONSTRUCTOR, union_type, nreverse(list));
 413       TREE_CONSTANT (ctor) = 1;
 414       TREE_INVARIANT (ctor) = 1;
 415       TREE_STATIC (ctor) = 1;
 416       DECL_INITIAL (decl) = ctor;
 417
 418 #ifdef ENABLE_CHECKING
 419       for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp))
 420         assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL);
 421 #endif
 422     }
 423
 424   /* Build component reference for each variable.  */
 425   for (h = current_common; h; h = next_s)
 426     {
 427       h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field),
 428                                     decl, h->field);
 429
 430       next_s = h->next;
 431       gfc_free (h);
 432     }
 433 }
 434
 435
 436 /* Given a symbol, find it in the current segment list. Returns NULL if
 437    not found.  */
 438
 439 static segment_info *
 440 find_segment_info (gfc_symbol *symbol)
 441 {
 442   segment_info *n;
 443
 444   for (n = current_segment; n; n = n->next)
 445     {
 446       if (n->sym == symbol)
 447         return n;
 448     }
 449
 450   return NULL;
 451 }
 452
 453
 454 /* Given a variable symbol, calculate the total length in bytes of the
 455    variable.  */
 456
 457 static HOST_WIDE_INT
 458 calculate_length (gfc_symbol *symbol)
 459 {
 460   HOST_WIDE_INT j, element_size;
 461   mpz_t elements;
 462
 463   if (symbol->ts.type == BT_CHARACTER)
 464     gfc_conv_const_charlen (symbol->ts.cl);
 465   element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts));
 466   if (symbol->as == NULL)
 467     return element_size;
 468
 469   /* Calculate the number of elements in the array */
 470   if (spec_size (symbol->as, &elements) == FAILURE)
 471     gfc_internal_error ("calculate_length(): Unable to determine array size");
 472   j = mpz_get_ui (elements);
 473   mpz_clear (elements);
 474
 475   return j*element_size;;
 476 }
 477
 478
 479 /* Given an expression node, make sure it is a constant integer and return
 480    the mpz_t value.  */
 481
 482 static mpz_t *
 483 get_mpz (gfc_expr *g)
 484 {
 485   if (g->expr_type != EXPR_CONSTANT)
 486     gfc_internal_error ("get_mpz(): Not an integer constant");
 487
 488   return &g->value.integer;
 489 }
 490
 491
 492 /* Given an array specification and an array reference, figure out the
 493    array element number (zero based). Bounds and elements are guaranteed
 494    to be constants.  If something goes wrong we generate an error and
 495    return zero.  */
 496
 497 static HOST_WIDE_INT
 498 element_number (gfc_array_ref *ar)
 499 {
 500   mpz_t multiplier, offset, extent, l;
 501   gfc_array_spec *as;
 502   HOST_WIDE_INT b, rank;
 503
 504   as = ar->as;
 505   rank = as->rank;
 506   mpz_init_set_ui (multiplier, 1);
 507   mpz_init_set_ui (offset, 0);
 508   mpz_init (extent);
 509   mpz_init (l);
 510
 511   for (b = 0; b < rank; b++)
 512     {
 513       if (ar->dimen_type[b] != DIMEN_ELEMENT)
 514         gfc_internal_error ("element_number(): Bad dimension type");
 515
 516       mpz_sub (l, *get_mpz (ar->start[b]), *get_mpz (as->lower[b]));
 517
 518       mpz_mul (l, l, multiplier);
 519       mpz_add (offset, offset, l);
 520
 521       mpz_sub (extent, *get_mpz (as->upper[b]), *get_mpz (as->lower[b]));
 522       mpz_add_ui (extent, extent, 1);
 523
 524       if (mpz_sgn (extent) < 0)
 525         mpz_set_ui (extent, 0);
 526
 527       mpz_mul (multiplier, multiplier, extent);
 528     }
 529
 530   b = mpz_get_ui (offset);
 531
 532   mpz_clear (multiplier);
 533   mpz_clear (offset);
 534   mpz_clear (extent);
 535   mpz_clear (l);
 536
 537   return b;
 538 }
 539
 540
 541 /* Given a single element of an equivalence list, figure out the offset
 542    from the base symbol.  For simple variables or full arrays, this is
 543    simply zero.  For an array element we have to calculate the array
 544    element number and multiply by the element size. For a substring we
 545    have to calculate the further reference.  */
 546
 547 static HOST_WIDE_INT
 548 calculate_offset (gfc_expr *s)
 549 {
 550   HOST_WIDE_INT a, element_size, offset;
 551   gfc_typespec *element_type;
 552   gfc_ref *reference;
 553
 554   offset = 0;
 555   element_type = &s->symtree->n.sym->ts;
 556
 557   for (reference = s->ref; reference; reference = reference->next)
 558     switch (reference->type)
 559       {
 560       case REF_ARRAY:
 561         switch (reference->u.ar.type)
 562           {
 563           case AR_FULL:
 564             break;
 565
 566           case AR_ELEMENT:
 567             a = element_number (&reference->u.ar);
 568             if (element_type->type == BT_CHARACTER)
 569               gfc_conv_const_charlen (element_type->cl);
 570             element_size =
 571               int_size_in_bytes (gfc_typenode_for_spec (element_type));
 572             offset += a * element_size;
 573             break;
 574
 575           default:
 576             gfc_error ("Bad array reference at %L", &s->where);
 577           }
 578         break;
 579       case REF_SUBSTRING:
 580         if (reference->u.ss.start != NULL)
 581           offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
 582         break;
 583       default:
 584         gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
 585                    &s->where);
 586     }
 587   return offset;
 588 }
 589
 590
 591 /* Add a new segment_info structure to the current segment.  eq1 is already
 592    in the list, eq2 is not.  */
 593
 594 static void
 595 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
 596 {
 597   HOST_WIDE_INT offset1, offset2;
 598   segment_info *a;
 599
 600   offset1 = calculate_offset (eq1->expr);
 601   offset2 = calculate_offset (eq2->expr);
 602
 603   a = get_segment_info ();
 604
 605   a->sym = eq2->expr->symtree->n.sym;
 606   a->offset = v->offset + offset1 - offset2;
 607   a->length = calculate_length (eq2->expr->symtree->n.sym);
 608
 609   current_segment = add_segments (current_segment, a);
 610 }
 611
 612
 613 /* Given two equivalence structures that are both already in the list, make
 614    sure that this new condition is not violated, generating an error if it
 615    is.  */
 616
 617 static void
 618 confirm_condition (segment_info *k, gfc_equiv *eq1, segment_info *e,
 619                    gfc_equiv *eq2)
 620 {
 621   HOST_WIDE_INT offset1, offset2;
 622
 623   offset1 = calculate_offset (eq1->expr);
 624   offset2 = calculate_offset (eq2->expr);
 625
 626   if (k->offset + offset1 != e->offset + offset2)
 627     gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
 628                "'%s' at %L", k->sym->name, &k->sym->declared_at,
 629                e->sym->name, &e->sym->declared_at);
 630 }
 631
 632
 633 /* Process a new equivalence condition. eq1 is know to be in segment f.
 634    If eq2 is also present then confirm that the condition holds.
 635    Otherwise add a new variable to the segment list.  */
 636
 637 static void
 638 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
 639 {
 640   segment_info *n;
 641
 642   n = find_segment_info (eq2->expr->symtree->n.sym);
 643
 644   if (n == NULL)
 645     new_condition (f, eq1, eq2);
 646   else
 647     confirm_condition (f, eq1, n, eq2);
 648 }
 649
 650
 651 /* Given a segment element, search through the equivalence lists for unused
 652    conditions that involve the symbol.  Add these rules to the segment.  Only
 653    checks for rules involving the first symbol in the equivalence set.  */
 654
 655 static bool
 656 find_equivalence (segment_info *f)
 657 {
 658   gfc_equiv *c, *l, *eq, *other;
 659   bool found;
 660
 661   found = FALSE;
 662   for (c = f->sym->ns->equiv; c; c = c->next)
 663     {
 664       other = NULL;
 665       for (l = c->eq; l; l = l->eq)
 666         {
 667           if (l->used)
 668             continue;
 669
 670           if (c->expr->symtree->n.sym == f-> sym)
 671             {
 672               eq = c;
 673               other = l;
 674             }
 675           else if (l->expr->symtree->n.sym == f->sym)
 676             {
 677               eq = l;
 678               other = c;
 679             }
 680           else
 681             eq = NULL;
 682
 683           if (eq)
 684             {
 685               add_condition (f, eq, other);
 686               eq->used = 1;
 687               found = TRUE;
 688               /* If this symbol is the fist in the chain we may find other
 689                  matches. Otherwise we can skip to the next equivalence.  */
 690               if (eq == l)
 691                 break;
 692             }
 693         }
 694     }
 695   return found;
 696 }
 697
 698
 699 /* Add all symbols equivalenced within a segment.  We need to scan the
 700    segment list multiple times to include indirect equivalences.  */
 701
 702 static void
 703 add_equivalences (void)
 704 {
 705   segment_info *f;
 706   bool more;
 707
 708   more = TRUE;
 709   while (more)
 710     {
 711       more = FALSE;
 712       for (f = current_segment; f; f = f->next)
 713         {
 714           if (!f->sym->equiv_built)
 715             {
 716               f->sym->equiv_built = 1;
 717               more = find_equivalence (f);
 718             }
 719         }
 720     }
 721 }
 722
 723
 724 /* Given a seed symbol, create a new segment consisting of that symbol
 725    and all of the symbols equivalenced with that symbol.  */
 726
 727 static void
 728 new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
 729 {
 730   HOST_WIDE_INT length;
 731
 732   current_segment = get_segment_info ();
 733   current_segment->sym = sym;
 734   current_segment->offset = current_offset;
 735   length = calculate_length (sym);
 736   current_segment->length = length;
 737
 738   /* Add all object directly or indirectly equivalenced with this common
 739      variable.  */
 740   add_equivalences ();
 741
 742   if (current_segment->offset < 0)
 743     gfc_error ("The equivalence set for '%s' cause an invalid extension "
 744                "to COMMON '%s' at %L",
 745                sym->name, common_sym->name, &common_sym->declared_at);
 746
 747   /* The offset of the next common variable.  */
 748   current_offset += length;
 749
 750   /* Add these to the common block.  */
 751   current_common = add_segments (current_common, current_segment);
 752 }
 753
 754
 755 /* Create a new block for each merged equivalence list.  */
 756
 757 static void
 758 finish_equivalences (gfc_namespace *ns)
 759 {
 760   gfc_equiv *z, *y;
 761   gfc_symbol *sym;
 762   segment_info *v;
 763   HOST_WIDE_INT min_offset;
 764
 765   for (z = ns->equiv; z; z = z->next)
 766     for (y= z->eq; y; y = y->eq)
 767       {
 768         if (y->used) continue;
 769         sym = z->expr->symtree->n.sym;
 770         current_segment = get_segment_info ();
 771         current_segment->sym = sym;
 772         current_segment->offset = 0;
 773         current_segment->length = calculate_length (sym);
 774
 775         /* All objects directly or indrectly equivalenced with this symbol.  */
 776         add_equivalences ();
 777
 778         /* Calculate the minimal offset.  */
 779         min_offset = current_segment->offset;
 780
 781         /* Adjust the offset of each equivalence object.  */
 782         for (v = current_segment; v; v = v->next)
 783           v->offset -= min_offset;
 784
 785         current_common = current_segment;
 786         create_common (NULL);
 787         break;
 788       }
 789 }
 790
 791
 792 /* Translate a single common block.  */
 793
 794 static void
 795 translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
 796 {
 797   gfc_symbol *sym;
 798
 799   current_common = NULL;
 800   current_offset = 0;
 801
 802   /* Add symbols to the segment.  */
 803   for (sym = var_list; sym; sym = sym->common_next)
 804     {
 805       if (! sym->equiv_built)
 806         new_segment (common_sym, sym);
 807     }
 808
 809   create_common (common_sym);
 810 }
 811
 812
 813 /* Work function for translating a named common block.  */
 814
 815 static void
 816 named_common (gfc_symbol *s)
 817 {
 818   if (s->attr.common)
 819     translate_common (s, s->common_head);
 820 }
 821
 822
 823 /* Translate the common blocks in a namespace. Unlike other variables,
 824    these have to be created before code, because the backend_decl depends
 825    on the rest of the common block.  */
 826
 827 void
 828 gfc_trans_common (gfc_namespace *ns)
 829 {
 830   gfc_symbol *sym;
 831
 832   /* Translate the blank common block.  */
 833   if (ns->blank_common != NULL)
 834     {
 835       gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym);
 836       translate_common (sym, ns->blank_common);
 837     }
 838
 839   /* Translate all named common blocks.  */
 840   gfc_traverse_ns (ns, named_common);
 841
 842   /* Commit the newly created symbols for common blocks.  */
 843   gfc_commit_symbols ();
 844
 845   /* Translate local equivalence.  */
 846   finish_equivalences (ns);
 847 }