gcc/fortran/trans-common.c

   1 /* Common block and equivalence list handling
   2    Copyright (C) 2000, 2003, 2004 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 /* Holds a single variable in a equivalence set.  */
 110 typedef struct segment_info
 111 {
 112   gfc_symbol *sym;
 113   HOST_WIDE_INT offset;
 114   HOST_WIDE_INT length;
 115   /* This will contain the field type until the field is created.  */
 116   tree field;
 117   struct segment_info *next;
 118 } segment_info;
 119
 120 static segment_info *current_segment, *current_common;
 121 static HOST_WIDE_INT current_offset;
 122 static gfc_namespace *gfc_common_ns = NULL;
 123
 124 #define BLANK_COMMON_NAME "__BLNK__"
 125
 126 /* Make a segment_info based on a symbol.  */
 127
 128 static segment_info *
 129 get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
 130 {
 131   segment_info *s;
 132
 133   /* Make sure we've got the character length.  */
 134   if (sym->ts.type == BT_CHARACTER)
 135     gfc_conv_const_charlen (sym->ts.cl);
 136
 137   /* Create the segment_info and fill it in.  */
 138   s = (segment_info *) gfc_getmem (sizeof (segment_info));
 139   s->sym = sym;
 140   /* We will use this type when building the segment aggreagate type.  */
 141   s->field = gfc_sym_type (sym);
 142   s->length = int_size_in_bytes (s->field);
 143   s->offset = offset;
 144
 145   return s;
 146 }
 147
 148 /* Add combine segment V and segment LIST.  */
 149
 150 static segment_info *
 151 add_segments (segment_info *list, segment_info *v)
 152 {
 153   segment_info *s;
 154   segment_info *p;
 155   segment_info *next;
 156
 157   p = NULL;
 158   s = list;
 159
 160   while (v)
 161     {
 162       /* Find the location of the new element.  */
 163       while (s)
 164         {
 165           if (v->offset < s->offset)
 166             break;
 167           if (v->offset == s->offset
 168               && v->length <= s->length)
 169             break;
 170
 171           p = s;
 172           s = s->next;
 173         }
 174
 175       /* Insert the new element in between p and s.  */
 176       next = v->next;
 177       v->next = s;
 178       if (p == NULL)
 179         list = v;
 180       else
 181         p->next = v;
 182
 183       p = v;
 184       v = next;
 185     }
 186
 187   return list;
 188 }
 189
 190 /* Construct mangled common block name from symbol name.  */
 191
 192 static tree
 193 gfc_sym_mangled_common_id (const char  *name)
 194 {
 195   int has_underscore;
 196   char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 197
 198   if (strcmp (name, BLANK_COMMON_NAME) == 0)
 199     return get_identifier (name);
 200
 201   if (gfc_option.flag_underscoring)
 202     {
 203       has_underscore = strchr (name, '_') != 0;
 204       if (gfc_option.flag_second_underscore && has_underscore)
 205         snprintf (mangled_name, sizeof mangled_name, "%s__", name);
 206       else
 207         snprintf (mangled_name, sizeof mangled_name, "%s_", name);
 208
 209       return get_identifier (mangled_name);
 210     }
 211   else
 212     return get_identifier (name);
 213 }
 214
 215
 216 /* Build a field declaration for a common variable or a local equivalence
 217    object.  */
 218
 219 static void
 220 build_field (segment_info *h, tree union_type, record_layout_info rli)
 221 {
 222   tree field;
 223   tree name;
 224   HOST_WIDE_INT offset = h->offset;
 225   unsigned HOST_WIDE_INT desired_align, known_align;
 226
 227   name = get_identifier (h->sym->name);
 228   field = build_decl (FIELD_DECL, name, h->field);
 229   gfc_set_decl_location (field, &h->sym->declared_at);
 230   known_align = (offset & -offset) * BITS_PER_UNIT;
 231   if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
 232     known_align = BIGGEST_ALIGNMENT;
 233
 234   desired_align = update_alignment_for_field (rli, field, known_align);
 235   if (desired_align > known_align)
 236     DECL_PACKED (field) = 1;
 237
 238   DECL_FIELD_CONTEXT (field) = union_type;
 239   DECL_FIELD_OFFSET (field) = size_int (offset);
 240   DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
 241   SET_DECL_OFFSET_ALIGN (field, known_align);
 242
 243   rli->offset = size_binop (MAX_EXPR, rli->offset,
 244                             size_binop (PLUS_EXPR,
 245                                         DECL_FIELD_OFFSET (field),
 246                                         DECL_SIZE_UNIT (field)));
 247   h->field = field;
 248 }
 249
 250
 251 /* Get storage for local equivalence.  */
 252
 253 static tree
 254 build_equiv_decl (tree union_type, bool is_init)
 255 {
 256   tree decl;
 257
 258   if (is_init)
 259     {
 260       decl = gfc_create_var (union_type, "equiv");
 261       TREE_STATIC (decl) = 1;
 262       return decl;
 263     }
 264
 265   decl = build_decl (VAR_DECL, NULL, union_type);
 266   DECL_ARTIFICIAL (decl) = 1;
 267
 268   DECL_COMMON (decl) = 1;
 269
 270   TREE_ADDRESSABLE (decl) = 1;
 271   TREE_USED (decl) = 1;
 272
 273   /* The source location has been lost, and doesn't really matter.
 274      We need to set it to something though.  */
 275   gfc_set_decl_location (decl, &gfc_current_locus);
 276
 277   gfc_add_decl_to_function (decl);
 278
 279   return decl;
 280 }
 281
 282
 283 /* Get storage for common block.  */
 284
 285 static tree
 286 build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 287 {
 288   gfc_symbol *common_sym;
 289   tree decl;
 290
 291   /* Create a namespace to store symbols for common blocks.  */
 292   if (gfc_common_ns == NULL)
 293     gfc_common_ns = gfc_get_namespace (NULL);
 294
 295   gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
 296   decl = common_sym->backend_decl;
 297
 298   /* Update the size of this common block as needed.  */
 299   if (decl != NULL_TREE)
 300     {
 301       tree size = TYPE_SIZE_UNIT (union_type);
 302       if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
 303         {
 304           /* Named common blocks of the same name shall be of the same size
 305              in all scoping units of a program in which they appear, but
 306              blank common blocks may be of different sizes.  */
 307           if (strcmp (com->name, BLANK_COMMON_NAME))
 308             gfc_warning ("Named COMMON block '%s' at %L shall be of the "
 309                          "same size", com->name, &com->where);
 310           DECL_SIZE_UNIT (decl) = size;
 311         }
 312      }
 313
 314   /* If this common block has been declared in a previous program unit,
 315      and either it is already initialized or there is no new initialization
 316      for it, just return.  */
 317   if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
 318     return decl;
 319
 320   /* If there is no backend_decl for the common block, build it.  */
 321   if (decl == NULL_TREE)
 322     {
 323       decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
 324       SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
 325       TREE_PUBLIC (decl) = 1;
 326       TREE_STATIC (decl) = 1;
 327       DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
 328       DECL_USER_ALIGN (decl) = 0;
 329
 330       gfc_set_decl_location (decl, &com->where);
 331
 332       /* Place the back end declaration for this common block in
 333          GLOBAL_BINDING_LEVEL.  */
 334       common_sym->backend_decl = pushdecl_top_level (decl);
 335     }
 336
 337   /* Has no initial values.  */
 338   if (!is_init)
 339     {
 340       DECL_INITIAL (decl) = NULL_TREE;
 341       DECL_COMMON (decl) = 1;
 342       DECL_DEFER_OUTPUT (decl) = 1;
 343     }
 344   else
 345     {
 346       DECL_INITIAL (decl) = error_mark_node;
 347       DECL_COMMON (decl) = 0;
 348       DECL_DEFER_OUTPUT (decl) = 0;
 349     }
 350   return decl;
 351 }
 352
 353
 354 /* Declare memory for the common block or local equivalence, and create
 355    backend declarations for all of the elements.  */
 356
 357 static void
 358 create_common (gfc_common_head *com)
 359 {
 360   segment_info *s, *next_s;
 361   tree union_type;
 362   tree *field_link;
 363   record_layout_info rli;
 364   tree decl;
 365   bool is_init = false;
 366
 367   /* Declare the variables inside the common block.  */
 368   union_type = make_node (UNION_TYPE);
 369   rli = start_record_layout (union_type);
 370   field_link = &TYPE_FIELDS (union_type);
 371
 372   for (s = current_common; s; s = s->next)
 373     {
 374       build_field (s, union_type, rli);
 375
 376       /* Link the field into the type.  */
 377       *field_link = s->field;
 378       field_link = &TREE_CHAIN (s->field);
 379
 380       /* Has initial value.  */
 381       if (s->sym->value)
 382         is_init = true;
 383     }
 384   finish_record_layout (rli, true);
 385
 386   if (com)
 387     decl = build_common_decl (com, union_type, is_init);
 388   else
 389     decl = build_equiv_decl (union_type, is_init);
 390
 391   if (is_init)
 392     {
 393       tree list, ctor, tmp;
 394       HOST_WIDE_INT offset = 0;
 395
 396       list = NULL_TREE;
 397       for (s = current_common; s; s = s->next)
 398         {
 399           if (s->sym->value)
 400             {
 401               if (s->offset < offset)
 402                 {
 403                     /* We have overlapping initializers.  It could either be
 404                        partially initilalized arrays (legal), or the user
 405                        specified multiple initial values (illegal).
 406                        We don't implement this yet, so bail out.  */
 407                   gfc_todo_error ("Initialization of overlapping variables");
 408                 }
 409               /* Add the initializer for this field.  */
 410               tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
 411                   TREE_TYPE (s->field), s->sym->attr.dimension,
 412                   s->sym->attr.pointer || s->sym->attr.allocatable);
 413               list = tree_cons (s->field, tmp, list);
 414               offset = s->offset + s->length;
 415             }
 416         }
 417       assert (list);
 418       ctor = build1 (CONSTRUCTOR, union_type, nreverse(list));
 419       TREE_CONSTANT (ctor) = 1;
 420       TREE_INVARIANT (ctor) = 1;
 421       TREE_STATIC (ctor) = 1;
 422       DECL_INITIAL (decl) = ctor;
 423
 424 #ifdef ENABLE_CHECKING
 425       for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp))
 426         assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL);
 427 #endif
 428     }
 429
 430   /* Build component reference for each variable.  */
 431   for (s = current_common; s; s = next_s)
 432     {
 433       s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
 434                                      decl, s->field, NULL_TREE);
 435
 436       next_s = s->next;
 437       gfc_free (s);
 438     }
 439 }
 440
 441
 442 /* Given a symbol, find it in the current segment list. Returns NULL if
 443    not found.  */
 444
 445 static segment_info *
 446 find_segment_info (gfc_symbol *symbol)
 447 {
 448   segment_info *n;
 449
 450   for (n = current_segment; n; n = n->next)
 451     {
 452       if (n->sym == symbol)
 453         return n;
 454     }
 455
 456   return NULL;
 457 }
 458
 459
 460 /* Given an expression node, make sure it is a constant integer and return
 461    the mpz_t value.  */
 462
 463 static mpz_t *
 464 get_mpz (gfc_expr *e)
 465 {
 466
 467   if (e->expr_type != EXPR_CONSTANT)
 468     gfc_internal_error ("get_mpz(): Not an integer constant");
 469
 470   return &e->value.integer;
 471 }
 472
 473
 474 /* Given an array specification and an array reference, figure out the
 475    array element number (zero based). Bounds and elements are guaranteed
 476    to be constants.  If something goes wrong we generate an error and
 477    return zero.  */
 478
 479 static HOST_WIDE_INT
 480 element_number (gfc_array_ref *ar)
 481 {
 482   mpz_t multiplier, offset, extent, n;
 483   gfc_array_spec *as;
 484   HOST_WIDE_INT i, rank;
 485
 486   as = ar->as;
 487   rank = as->rank;
 488   mpz_init_set_ui (multiplier, 1);
 489   mpz_init_set_ui (offset, 0);
 490   mpz_init (extent);
 491   mpz_init (n);
 492
 493   for (i = 0; i < rank; i++)
 494     {
 495       if (ar->dimen_type[i] != DIMEN_ELEMENT)
 496         gfc_internal_error ("element_number(): Bad dimension type");
 497
 498       mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
 499
 500       mpz_mul (n, n, multiplier);
 501       mpz_add (offset, offset, n);
 502
 503       mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
 504       mpz_add_ui (extent, extent, 1);
 505
 506       if (mpz_sgn (extent) < 0)
 507         mpz_set_ui (extent, 0);
 508
 509       mpz_mul (multiplier, multiplier, extent);
 510     }
 511
 512   i = mpz_get_ui (offset);
 513
 514   mpz_clear (multiplier);
 515   mpz_clear (offset);
 516   mpz_clear (extent);
 517   mpz_clear (n);
 518
 519   return i;
 520 }
 521
 522
 523 /* Given a single element of an equivalence list, figure out the offset
 524    from the base symbol.  For simple variables or full arrays, this is
 525    simply zero.  For an array element we have to calculate the array
 526    element number and multiply by the element size. For a substring we
 527    have to calculate the further reference.  */
 528
 529 static HOST_WIDE_INT
 530 calculate_offset (gfc_expr *e)
 531 {
 532   HOST_WIDE_INT n, element_size, offset;
 533   gfc_typespec *element_type;
 534   gfc_ref *reference;
 535
 536   offset = 0;
 537   element_type = &e->symtree->n.sym->ts;
 538
 539   for (reference = e->ref; reference; reference = reference->next)
 540     switch (reference->type)
 541       {
 542       case REF_ARRAY:
 543         switch (reference->u.ar.type)
 544           {
 545           case AR_FULL:
 546             break;
 547
 548           case AR_ELEMENT:
 549             n = element_number (&reference->u.ar);
 550             if (element_type->type == BT_CHARACTER)
 551               gfc_conv_const_charlen (element_type->cl);
 552             element_size =
 553               int_size_in_bytes (gfc_typenode_for_spec (element_type));
 554             offset += n * element_size;
 555             break;
 556
 557           default:
 558             gfc_error ("Bad array reference at %L", &e->where);
 559           }
 560         break;
 561       case REF_SUBSTRING:
 562         if (reference->u.ss.start != NULL)
 563           offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
 564         break;
 565       default:
 566         gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
 567                    &e->where);
 568     }
 569   return offset;
 570 }
 571
 572
 573 /* Add a new segment_info structure to the current segment.  eq1 is already
 574    in the list, eq2 is not.  */
 575
 576 static void
 577 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
 578 {
 579   HOST_WIDE_INT offset1, offset2;
 580   segment_info *a;
 581
 582   offset1 = calculate_offset (eq1->expr);
 583   offset2 = calculate_offset (eq2->expr);
 584
 585   a = get_segment_info (eq2->expr->symtree->n.sym,
 586                         v->offset + offset1 - offset2);
 587
 588   current_segment = add_segments (current_segment, a);
 589 }
 590
 591
 592 /* Given two equivalence structures that are both already in the list, make
 593    sure that this new condition is not violated, generating an error if it
 594    is.  */
 595
 596 static void
 597 confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
 598                    gfc_equiv *eq2)
 599 {
 600   HOST_WIDE_INT offset1, offset2;
 601
 602   offset1 = calculate_offset (eq1->expr);
 603   offset2 = calculate_offset (eq2->expr);
 604
 605   if (s1->offset + offset1 != s2->offset + offset2)
 606     gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
 607                "'%s' at %L", s1->sym->name, &s1->sym->declared_at,
 608                s2->sym->name, &s2->sym->declared_at);
 609 }
 610
 611
 612 /* Process a new equivalence condition. eq1 is know to be in segment f.
 613    If eq2 is also present then confirm that the condition holds.
 614    Otherwise add a new variable to the segment list.  */
 615
 616 static void
 617 add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
 618 {
 619   segment_info *n;
 620
 621   n = find_segment_info (eq2->expr->symtree->n.sym);
 622
 623   if (n == NULL)
 624     new_condition (f, eq1, eq2);
 625   else
 626     confirm_condition (f, eq1, n, eq2);
 627 }
 628
 629
 630 /* Given a segment element, search through the equivalence lists for unused
 631    conditions that involve the symbol.  Add these rules to the segment.  Only
 632    checks for rules involving the first symbol in the equivalence set.  */
 633
 634 static bool
 635 find_equivalence (segment_info *n)
 636 {
 637   gfc_equiv *e1, *e2, *eq, *other;
 638   bool found;
 639
 640   found = FALSE;
 641   for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
 642     {
 643       other = NULL;
 644       for (e2 = e1->eq; e2; e2 = e2->eq)
 645         {
 646           if (e2->used)
 647             continue;
 648
 649           if (e1->expr->symtree->n.sym == n->sym)
 650             {
 651               eq = e1;
 652               other = e2;
 653             }
 654           else if (e2->expr->symtree->n.sym == n->sym)
 655             {
 656               eq = e2;
 657               other = e1;
 658             }
 659           else
 660             eq = NULL;
 661
 662           if (eq)
 663             {
 664               add_condition (n, eq, other);
 665               eq->used = 1;
 666               found = TRUE;
 667               /* If this symbol is the first in the chain we may find other
 668                  matches. Otherwise we can skip to the next equivalence.  */
 669               if (eq == e2)
 670                 break;
 671             }
 672         }
 673     }
 674   return found;
 675 }
 676
 677
 678 /* Add all symbols equivalenced within a segment.  We need to scan the
 679    segment list multiple times to include indirect equivalences.  */
 680
 681 static void
 682 add_equivalences (void)
 683 {
 684   segment_info *f;
 685   bool more;
 686
 687   more = TRUE;
 688   while (more)
 689     {
 690       more = FALSE;
 691       for (f = current_segment; f; f = f->next)
 692         {
 693           if (!f->sym->equiv_built)
 694             {
 695               f->sym->equiv_built = 1;
 696               more = find_equivalence (f);
 697             }
 698         }
 699     }
 700 }
 701
 702
 703 /* Given a seed symbol, create a new segment consisting of that symbol
 704    and all of the symbols equivalenced with that symbol.  */
 705
 706 static void
 707 new_segment (gfc_common_head *common, gfc_symbol *sym)
 708 {
 709
 710   current_segment = get_segment_info (sym, current_offset);
 711
 712   /* The offset of the next common variable.  */
 713   current_offset += current_segment->length;
 714
 715   /* Add all object directly or indirectly equivalenced with this common
 716      variable.  */
 717   add_equivalences ();
 718
 719   if (current_segment->offset < 0)
 720     gfc_error ("The equivalence set for '%s' cause an invalid "
 721                "extension to COMMON '%s' at %L", sym->name,
 722                common->name, &common->where);
 723
 724   /* Add these to the common block.  */
 725   current_common = add_segments (current_common, current_segment);
 726 }
 727
 728
 729 /* Create a new block for each merged equivalence list.  */
 730
 731 static void
 732 finish_equivalences (gfc_namespace *ns)
 733 {
 734   gfc_equiv *z, *y;
 735   gfc_symbol *sym;
 736   segment_info *v;
 737   HOST_WIDE_INT min_offset;
 738
 739   for (z = ns->equiv; z; z = z->next)
 740     for (y = z->eq; y; y = y->eq)
 741       {
 742         if (y->used)
 743           continue;
 744         sym = z->expr->symtree->n.sym;
 745         current_segment = get_segment_info (sym, 0);
 746
 747         /* All objects directly or indrectly equivalenced with this symbol.  */
 748         add_equivalences ();
 749
 750         /* Calculate the minimal offset.  */
 751         min_offset = current_segment->offset;
 752
 753         /* Adjust the offset of each equivalence object.  */
 754         for (v = current_segment; v; v = v->next)
 755           v->offset -= min_offset;
 756
 757         current_common = current_segment;
 758         create_common (NULL);
 759         break;
 760       }
 761 }
 762
 763
 764 /* Translate a single common block.  */
 765
 766 static void
 767 translate_common (gfc_common_head *common, gfc_symbol *var_list)
 768 {
 769   gfc_symbol *sym;
 770
 771   current_common = NULL;
 772   current_offset = 0;
 773
 774   /* Add symbols to the segment.  */
 775   for (sym = var_list; sym; sym = sym->common_next)
 776     {
 777       if (! sym->equiv_built)
 778         new_segment (common, sym);
 779     }
 780
 781   create_common (common);
 782 }
 783
 784
 785 /* Work function for translating a named common block.  */
 786
 787 static void
 788 named_common (gfc_symtree *st)
 789 {
 790
 791   translate_common (st->n.common, st->n.common->head);
 792 }
 793
 794
 795 /* Translate the common blocks in a namespace. Unlike other variables,
 796    these have to be created before code, because the backend_decl depends
 797    on the rest of the common block.  */
 798
 799 void
 800 gfc_trans_common (gfc_namespace *ns)
 801 {
 802   gfc_common_head *c;
 803
 804   /* Translate the blank common block.  */
 805   if (ns->blank_common.head != NULL)
 806     {
 807       c = gfc_get_common_head ();
 808       /* We've lost the real location, so use the location of the
 809          enclosing procedure.  */
 810       c->where = ns->proc_name->declared_at;
 811       strcpy (c->name, BLANK_COMMON_NAME);
 812       translate_common (c, ns->blank_common.head);
 813     }
 814
 815   /* Translate all named common blocks.  */
 816   gfc_traverse_symtree (ns->common_root, named_common);
 817
 818   /* Commit the newly created symbols for common blocks.  */
 819   gfc_commit_symbols ();
 820
 821   /* Translate local equivalence.  */
 822   finish_equivalences (ns);
 823 }