LCOV - code coverage report
Current view: top level - gcc/fortran - trans-common.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 580 604 96.0 %
Date: 2020-03-28 11:57:23 Functions: 22 25 88.0 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Common block and equivalence list handling
       2                 :            :    Copyright (C) 2000-2020 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 3, 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 COPYING3.  If not see
      19                 :            : <http://www.gnu.org/licenses/>.  */     
      20                 :            : 
      21                 :            : /* The core algorithm is based on Andy Vaught's g95 tree.  Also the
      22                 :            :    way to build UNION_TYPE is borrowed from Richard Henderson.
      23                 :            :  
      24                 :            :    Transform common blocks.  An integral part of this is processing
      25                 :            :    equivalence variables.  Equivalenced variables that are not in a
      26                 :            :    common block end up in a private block of their own.
      27                 :            : 
      28                 :            :    Each common block or local equivalence list is declared as a union.
      29                 :            :    Variables within the block are represented as a field within the
      30                 :            :    block with the proper offset. 
      31                 :            :  
      32                 :            :    So if two variables are equivalenced, they just point to a common
      33                 :            :    area in memory.
      34                 :            :  
      35                 :            :    Mathematically, laying out an equivalence block is equivalent to
      36                 :            :    solving a linear system of equations.  The matrix is usually a
      37                 :            :    sparse matrix in which each row contains all zero elements except
      38                 :            :    for a +1 and a -1, a sort of a generalized Vandermonde matrix.  The
      39                 :            :    matrix is usually block diagonal.  The system can be
      40                 :            :    overdetermined, underdetermined or have a unique solution.  If the
      41                 :            :    system is inconsistent, the program is not standard conforming.
      42                 :            :    The solution vector is integral, since all of the pivots are +1 or -1.
      43                 :            :  
      44                 :            :    How we lay out an equivalence block is a little less complicated.
      45                 :            :    In an equivalence list with n elements, there are n-1 conditions to
      46                 :            :    be satisfied.  The conditions partition the variables into what we
      47                 :            :    will call segments.  If A and B are equivalenced then A and B are
      48                 :            :    in the same segment.  If B and C are equivalenced as well, then A,
      49                 :            :    B and C are in a segment and so on.  Each segment is a block of
      50                 :            :    memory that has one or more variables equivalenced in some way.  A
      51                 :            :    common block is made up of a series of segments that are joined one
      52                 :            :    after the other.  In the linear system, a segment is a block
      53                 :            :    diagonal.
      54                 :            :  
      55                 :            :    To lay out a segment we first start with some variable and
      56                 :            :    determine its length.  The first variable is assumed to start at
      57                 :            :    offset one and extends to however long it is.  We then traverse the
      58                 :            :    list of equivalences to find an unused condition that involves at
      59                 :            :    least one of the variables currently in the segment.
      60                 :            :  
      61                 :            :    Each equivalence condition amounts to the condition B+b=C+c where B
      62                 :            :    and C are the offsets of the B and C variables, and b and c are
      63                 :            :    constants which are nonzero for array elements, substrings or
      64                 :            :    structure components.  So for
      65                 :            :  
      66                 :            :      EQUIVALENCE(B(2), C(3))
      67                 :            :    we have
      68                 :            :      B + 2*size of B's elements = C + 3*size of C's elements.
      69                 :            :  
      70                 :            :    If B and C are known we check to see if the condition already
      71                 :            :    holds.  If B is known we can solve for C.  Since we know the length
      72                 :            :    of C, we can see if the minimum and maximum extents of the segment
      73                 :            :    are affected.  Eventually, we make a full pass through the
      74                 :            :    equivalence list without finding any new conditions and the segment
      75                 :            :    is fully specified.
      76                 :            :  
      77                 :            :    At this point, the segment is added to the current common block.
      78                 :            :    Since we know the minimum extent of the segment, everything in the
      79                 :            :    segment is translated to its position in the common block.  The
      80                 :            :    usual case here is that there are no equivalence statements and the
      81                 :            :    common block is series of segments with one variable each, which is
      82                 :            :    a diagonal matrix in the matrix formulation.
      83                 :            :  
      84                 :            :    Each segment is described by a chain of segment_info structures.  Each
      85                 :            :    segment_info structure describes the extents of a single variable within
      86                 :            :    the segment.  This list is maintained in the order the elements are
      87                 :            :    positioned within the segment.  If two elements have the same starting
      88                 :            :    offset the smaller will come first.  If they also have the same size their
      89                 :            :    ordering is undefined. 
      90                 :            :    
      91                 :            :    Once all common blocks have been created, the list of equivalences
      92                 :            :    is examined for still-unused equivalence conditions.  We create a
      93                 :            :    block for each merged equivalence list.  */
      94                 :            : 
      95                 :            : #include "config.h"
      96                 :            : #define INCLUDE_MAP
      97                 :            : #include "system.h"
      98                 :            : #include "coretypes.h"
      99                 :            : #include "tm.h"
     100                 :            : #include "tree.h"
     101                 :            : #include "gfortran.h"
     102                 :            : #include "trans.h"
     103                 :            : #include "stringpool.h"
     104                 :            : #include "fold-const.h"
     105                 :            : #include "stor-layout.h"
     106                 :            : #include "varasm.h"
     107                 :            : #include "trans-types.h"
     108                 :            : #include "trans-const.h"
     109                 :            : #include "target-memory.h"
     110                 :            : 
     111                 :            : 
     112                 :            : /* Holds a single variable in an equivalence set.  */
     113                 :            : typedef struct segment_info
     114                 :            : {
     115                 :            :   gfc_symbol *sym;
     116                 :            :   HOST_WIDE_INT offset;
     117                 :            :   HOST_WIDE_INT length;
     118                 :            :   /* This will contain the field type until the field is created.  */
     119                 :            :   tree field;
     120                 :            :   struct segment_info *next;
     121                 :            : } segment_info;
     122                 :            : 
     123                 :            : static segment_info * current_segment;
     124                 :            : 
     125                 :            : /* Store decl of all common blocks in this translation unit; the first
     126                 :            :    tree is the identifier.  */
     127                 :            : static std::map<tree, tree> gfc_map_of_all_commons;
     128                 :            : 
     129                 :            : 
     130                 :            : /* Make a segment_info based on a symbol.  */
     131                 :            : 
     132                 :            : static segment_info *
     133                 :       8152 : get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
     134                 :            : {
     135                 :       8152 :   segment_info *s;
     136                 :            : 
     137                 :            :   /* Make sure we've got the character length.  */
     138                 :       8152 :   if (sym->ts.type == BT_CHARACTER)
     139                 :        641 :     gfc_conv_const_charlen (sym->ts.u.cl);
     140                 :            : 
     141                 :            :   /* Create the segment_info and fill it in.  */
     142                 :       8152 :   s = XCNEW (segment_info);
     143                 :       8152 :   s->sym = sym;
     144                 :            :   /* We will use this type when building the segment aggregate type.  */
     145                 :       8152 :   s->field = gfc_sym_type (sym);
     146                 :       8152 :   s->length = int_size_in_bytes (s->field);
     147                 :       8152 :   s->offset = offset;
     148                 :            : 
     149                 :       8152 :   return s;
     150                 :            : }
     151                 :            : 
     152                 :            : 
     153                 :            : /* Add a copy of a segment list to the namespace.  This is specifically for
     154                 :            :    equivalence segments, so that dependency checking can be done on
     155                 :            :    equivalence group members.  */
     156                 :            : 
     157                 :            : static void
     158                 :       6581 : copy_equiv_list_to_ns (segment_info *c)
     159                 :            : {
     160                 :       6581 :   segment_info *f;
     161                 :       6581 :   gfc_equiv_info *s;
     162                 :       6581 :   gfc_equiv_list *l;
     163                 :            : 
     164                 :       6581 :   l = XCNEW (gfc_equiv_list);
     165                 :            : 
     166                 :       6581 :   l->next = c->sym->ns->equiv_lists;
     167                 :       6581 :   c->sym->ns->equiv_lists = l;
     168                 :            : 
     169                 :      14733 :   for (f = c; f; f = f->next)
     170                 :            :     {
     171                 :       8152 :       s = XCNEW (gfc_equiv_info);
     172                 :       8152 :       s->next = l->equiv;
     173                 :       8152 :       l->equiv = s;
     174                 :       8152 :       s->sym = f->sym;
     175                 :       8152 :       s->offset = f->offset;
     176                 :       8152 :       s->length = f->length;
     177                 :            :     }
     178                 :       6581 : }
     179                 :            : 
     180                 :            : 
     181                 :            : /* Add combine segment V and segment LIST.  */
     182                 :            : 
     183                 :            : static segment_info *
     184                 :       7353 : add_segments (segment_info *list, segment_info *v)
     185                 :            : {
     186                 :       7353 :   segment_info *s;
     187                 :       7353 :   segment_info *p;
     188                 :       7353 :   segment_info *next;
     189                 :            : 
     190                 :       7353 :   p = NULL;
     191                 :       7353 :   s = list;
     192                 :            : 
     193                 :      15052 :   while (v)
     194                 :            :     {
     195                 :            :       /* Find the location of the new element.  */
     196                 :      42109 :       while (s)
     197                 :            :         {
     198                 :      35532 :           if (v->offset < s->offset)
     199                 :            :             break;
     200                 :      35100 :           if (v->offset == s->offset
     201                 :        732 :               && v->length <= s->length)
     202                 :            :             break;
     203                 :            : 
     204                 :      34410 :           p = s;
     205                 :      34410 :           s = s->next;
     206                 :            :         }
     207                 :            : 
     208                 :            :       /* Insert the new element in between p and s.  */
     209                 :       7699 :       next = v->next;
     210                 :       7699 :       v->next = s;
     211                 :       7699 :       if (p == NULL)
     212                 :            :         list = v;
     213                 :            :       else
     214                 :       4763 :         p->next = v;
     215                 :            : 
     216                 :            :       p = v;
     217                 :            :       v = next;
     218                 :            :     }
     219                 :            : 
     220                 :       7353 :   return list;
     221                 :            : }
     222                 :            : 
     223                 :            : 
     224                 :            : /* Construct mangled common block name from symbol name.  */
     225                 :            : 
     226                 :            : /* We need the bind(c) flag to tell us how/if we should mangle the symbol
     227                 :            :    name.  There are few calls to this function, so few places that this
     228                 :            :    would need to be added.  At the moment, there is only one call, in
     229                 :            :    build_common_decl().  We can't attempt to look up the common block
     230                 :            :    because we may be building it for the first time and therefore, it won't
     231                 :            :    be in the common_root.  We also need the binding label, if it's bind(c).
     232                 :            :    Therefore, send in the pointer to the common block, so whatever info we
     233                 :            :    have so far can be used.  All of the necessary info should be available
     234                 :            :    in the gfc_common_head by now, so it should be accurate to test the
     235                 :            :    isBindC flag and use the binding label given if it is bind(c).
     236                 :            : 
     237                 :            :    We may NOT know yet if it's bind(c) or not, but we can try at least.
     238                 :            :    Will have to figure out what to do later if it's labeled bind(c)
     239                 :            :    after this is called.  */
     240                 :            : 
     241                 :            : static tree
     242                 :       2080 : gfc_sym_mangled_common_id (gfc_common_head *com)
     243                 :            : {
     244                 :       2080 :   int has_underscore;
     245                 :       2080 :   char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
     246                 :       2080 :   char name[GFC_MAX_SYMBOL_LEN + 1];
     247                 :            : 
     248                 :            :   /* Get the name out of the common block pointer.  */
     249                 :       2080 :   strcpy (name, com->name);
     250                 :            : 
     251                 :            :   /* If we're suppose to do a bind(c).  */
     252                 :       2080 :   if (com->is_bind_c == 1 && com->binding_label)
     253                 :         69 :     return get_identifier (com->binding_label);
     254                 :            : 
     255                 :       2011 :   if (strcmp (name, BLANK_COMMON_NAME) == 0)
     256                 :        224 :     return get_identifier (name);
     257                 :            : 
     258                 :       1787 :   if (flag_underscoring)
     259                 :            :     {
     260                 :       1787 :       has_underscore = strchr (name, '_') != 0;
     261                 :       1787 :       if (flag_second_underscore && has_underscore)
     262                 :          0 :         snprintf (mangled_name, sizeof mangled_name, "%s__", name);
     263                 :            :       else
     264                 :       1787 :         snprintf (mangled_name, sizeof mangled_name, "%s_", name);
     265                 :            : 
     266                 :       1787 :       return get_identifier (mangled_name);
     267                 :            :     }
     268                 :            :   else
     269                 :          0 :     return get_identifier (name);
     270                 :            : }
     271                 :            : 
     272                 :            : 
     273                 :            : /* Build a field declaration for a common variable or a local equivalence
     274                 :            :    object.  */
     275                 :            : 
     276                 :            : static void
     277                 :       8152 : build_field (segment_info *h, tree union_type, record_layout_info rli)
     278                 :            : {
     279                 :       8152 :   tree field;
     280                 :       8152 :   tree name;
     281                 :       8152 :   HOST_WIDE_INT offset = h->offset;
     282                 :       8152 :   unsigned HOST_WIDE_INT desired_align, known_align;
     283                 :            : 
     284                 :       8152 :   name = get_identifier (h->sym->name);
     285                 :       8152 :   field = build_decl (gfc_get_location (&h->sym->declared_at),
     286                 :            :                       FIELD_DECL, name, h->field);
     287                 :       8152 :   known_align = (offset & -offset) * BITS_PER_UNIT;
     288                 :      12943 :   if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
     289                 :       4962 :     known_align = BIGGEST_ALIGNMENT;
     290                 :            : 
     291                 :       8152 :   desired_align = update_alignment_for_field (rli, field, known_align);
     292                 :       8152 :   if (desired_align > known_align)
     293                 :          7 :     DECL_PACKED (field) = 1;
     294                 :            : 
     295                 :       8152 :   DECL_FIELD_CONTEXT (field) = union_type;
     296                 :       8152 :   DECL_FIELD_OFFSET (field) = size_int (offset);
     297                 :       8152 :   DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
     298                 :       8152 :   SET_DECL_OFFSET_ALIGN (field, known_align);
     299                 :            : 
     300                 :       8152 :   rli->offset = size_binop (MAX_EXPR, rli->offset,
     301                 :            :                             size_binop (PLUS_EXPR,
     302                 :            :                                         DECL_FIELD_OFFSET (field),
     303                 :            :                                         DECL_SIZE_UNIT (field)));
     304                 :            :   /* If this field is assigned to a label, we create another two variables.
     305                 :            :      One will hold the address of target label or format label. The other will
     306                 :            :      hold the length of format label string.  */
     307                 :       8152 :   if (h->sym->attr.assign)
     308                 :            :     {
     309                 :         14 :       tree len;
     310                 :         14 :       tree addr;
     311                 :            : 
     312                 :         14 :       gfc_allocate_lang_decl (field);
     313                 :         14 :       GFC_DECL_ASSIGN (field) = 1;
     314                 :         14 :       len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
     315                 :         14 :       addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
     316                 :         14 :       TREE_STATIC (len) = 1;
     317                 :         14 :       TREE_STATIC (addr) = 1;
     318                 :         14 :       DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
     319                 :         14 :       gfc_set_decl_location (len, &h->sym->declared_at);
     320                 :         14 :       gfc_set_decl_location (addr, &h->sym->declared_at);
     321                 :         14 :       GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
     322                 :         14 :       GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
     323                 :            :     }
     324                 :            : 
     325                 :            :   /* If this field is volatile, mark it.  */
     326                 :       8152 :   if (h->sym->attr.volatile_)
     327                 :            :     {
     328                 :          3 :       tree new_type;
     329                 :          3 :       TREE_THIS_VOLATILE (field) = 1;
     330                 :          3 :       TREE_SIDE_EFFECTS (field) = 1;
     331                 :          3 :       new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
     332                 :          3 :       TREE_TYPE (field) = new_type;
     333                 :            :     }
     334                 :            : 
     335                 :       8152 :   h->field = field;
     336                 :       8152 : }
     337                 :            : 
     338                 :            : 
     339                 :            : /* Get storage for local equivalence.  */
     340                 :            : 
     341                 :            : static tree
     342                 :        698 : build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)
     343                 :            : {
     344                 :        698 :   tree decl;
     345                 :        698 :   char name[18];
     346                 :        698 :   static int serial = 0;
     347                 :            : 
     348                 :        698 :   if (is_init)
     349                 :            :     {
     350                 :        146 :       decl = gfc_create_var (union_type, "equiv");
     351                 :        146 :       TREE_STATIC (decl) = 1;
     352                 :        146 :       GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
     353                 :        146 :       return decl;
     354                 :            :     }
     355                 :            : 
     356                 :        552 :   snprintf (name, sizeof (name), "equiv.%d", serial++);
     357                 :        552 :   decl = build_decl (input_location,
     358                 :            :                      VAR_DECL, get_identifier (name), union_type);
     359                 :        552 :   DECL_ARTIFICIAL (decl) = 1;
     360                 :        552 :   DECL_IGNORED_P (decl) = 1;
     361                 :            : 
     362                 :       1090 :   if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
     363                 :        531 :       || is_saved))
     364                 :         27 :     TREE_STATIC (decl) = 1;
     365                 :            : 
     366                 :        552 :   TREE_ADDRESSABLE (decl) = 1;
     367                 :        552 :   TREE_USED (decl) = 1;
     368                 :        552 :   GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
     369                 :            : 
     370                 :            :   /* The source location has been lost, and doesn't really matter.
     371                 :            :      We need to set it to something though.  */
     372                 :        552 :   gfc_set_decl_location (decl, &gfc_current_locus);
     373                 :            : 
     374                 :        552 :   gfc_add_decl_to_function (decl);
     375                 :            : 
     376                 :        552 :   return decl;
     377                 :            : }
     378                 :            : 
     379                 :            : 
     380                 :            : /* Get storage for common block.  */
     381                 :            : 
     382                 :            : static tree
     383                 :       2080 : build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
     384                 :            : {
     385                 :       2080 :   tree decl, identifier;
     386                 :            : 
     387                 :       2080 :   identifier = gfc_sym_mangled_common_id (com);
     388                 :       2080 :   decl = gfc_map_of_all_commons.count(identifier)
     389                 :        985 :          ? gfc_map_of_all_commons[identifier] : NULL_TREE;
     390                 :            : 
     391                 :            :   /* Update the size of this common block as needed.  */
     392                 :       2080 :   if (decl != NULL_TREE)
     393                 :            :     {
     394                 :        985 :       tree size = TYPE_SIZE_UNIT (union_type);
     395                 :            : 
     396                 :            :       /* Named common blocks of the same name shall be of the same size
     397                 :            :          in all scoping units of a program in which they appear, but
     398                 :            :          blank common blocks may be of different sizes.  */
     399                 :        985 :       if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
     400                 :        985 :           && strcmp (com->name, BLANK_COMMON_NAME))
     401                 :         15 :         gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
     402                 :            :                      "same size as elsewhere (%lu vs %lu bytes)", com->name,
     403                 :            :                      &com->where,
     404                 :         15 :                      (unsigned long) TREE_INT_CST_LOW (size),
     405                 :         15 :                      (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
     406                 :            : 
     407                 :        985 :       if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
     408                 :            :         {
     409                 :         17 :           DECL_SIZE (decl) = TYPE_SIZE (union_type);
     410                 :         17 :           DECL_SIZE_UNIT (decl) = size;
     411                 :         17 :           SET_DECL_MODE (decl, TYPE_MODE (union_type));
     412                 :         17 :           TREE_TYPE (decl) = union_type;
     413                 :         17 :           layout_decl (decl, 0);
     414                 :            :         }
     415                 :            :      }
     416                 :            : 
     417                 :            :   /* If this common block has been declared in a previous program unit,
     418                 :            :      and either it is already initialized or there is no new initialization
     419                 :            :      for it, just return.  */
     420                 :       2098 :   if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
     421                 :            :     return decl;
     422                 :            : 
     423                 :            :   /* If there is no backend_decl for the common block, build it.  */
     424                 :       1113 :   if (decl == NULL_TREE)
     425                 :            :     {
     426                 :       1095 :       if (com->is_bind_c == 1 && com->binding_label)
     427                 :         51 :         decl = build_decl (input_location, VAR_DECL, identifier, union_type);
     428                 :            :       else
     429                 :            :         {
     430                 :       1044 :           decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
     431                 :            :                              union_type);
     432                 :       1044 :           gfc_set_decl_assembler_name (decl, identifier);
     433                 :            :         }
     434                 :            : 
     435                 :       1095 :       TREE_PUBLIC (decl) = 1;
     436                 :       1095 :       TREE_STATIC (decl) = 1;
     437                 :       1095 :       DECL_IGNORED_P (decl) = 1;
     438                 :       1095 :       if (!com->is_bind_c)
     439                 :       2061 :         SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
     440                 :            :       else
     441                 :            :         {
     442                 :            :           /* Do not set the alignment for bind(c) common blocks to
     443                 :            :              BIGGEST_ALIGNMENT because that won't match what C does.  Also,
     444                 :            :              for common blocks with one element, the alignment must be
     445                 :            :              that of the field within the common block in order to match
     446                 :            :              what C will do.  */
     447                 :         59 :           tree field = NULL_TREE;
     448                 :         59 :           field = TYPE_FIELDS (TREE_TYPE (decl));
     449                 :         59 :           if (DECL_CHAIN (field) == NULL_TREE)
     450                 :         23 :             SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
     451                 :            :         }
     452                 :       1095 :       DECL_USER_ALIGN (decl) = 0;
     453                 :       1095 :       GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
     454                 :            : 
     455                 :       1095 :       gfc_set_decl_location (decl, &com->where);
     456                 :            : 
     457                 :       1095 :       if (com->threadprivate)
     458                 :         42 :         set_decl_tls_model (decl, decl_default_tls_model (decl));
     459                 :            : 
     460                 :       1095 :       if (com->omp_declare_target_link)
     461                 :          1 :         DECL_ATTRIBUTES (decl)
     462                 :          1 :           = tree_cons (get_identifier ("omp declare target link"),
     463                 :          1 :                        NULL_TREE, DECL_ATTRIBUTES (decl));
     464                 :       1094 :       else if (com->omp_declare_target)
     465                 :          2 :         DECL_ATTRIBUTES (decl)
     466                 :          2 :           = tree_cons (get_identifier ("omp declare target"),
     467                 :          2 :                        NULL_TREE, DECL_ATTRIBUTES (decl));
     468                 :            : 
     469                 :            :       /* Place the back end declaration for this common block in
     470                 :            :          GLOBAL_BINDING_LEVEL.  */
     471                 :       1095 :       gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
     472                 :            :     }
     473                 :            : 
     474                 :            :   /* Has no initial values.  */
     475                 :       1113 :   if (!is_init)
     476                 :            :     {
     477                 :       1017 :       DECL_INITIAL (decl) = NULL_TREE;
     478                 :       1017 :       DECL_COMMON (decl) = 1;
     479                 :       1017 :       DECL_DEFER_OUTPUT (decl) = 1;
     480                 :            :     }
     481                 :            :   else
     482                 :            :     {
     483                 :         96 :       DECL_INITIAL (decl) = error_mark_node;
     484                 :         96 :       DECL_COMMON (decl) = 0;
     485                 :         96 :       DECL_DEFER_OUTPUT (decl) = 0;
     486                 :            :     }
     487                 :            :   return decl;
     488                 :            : }
     489                 :            : 
     490                 :            : 
     491                 :            : /* Return a field that is the size of the union, if an equivalence has
     492                 :            :    overlapping initializers.  Merge the initializers into a single
     493                 :            :    initializer for this new field, then free the old ones.  */ 
     494                 :            : 
     495                 :            : static tree
     496                 :        946 : get_init_field (segment_info *head, tree union_type, tree *field_init,
     497                 :            :                 record_layout_info rli)
     498                 :            : {
     499                 :        946 :   segment_info *s;
     500                 :        946 :   HOST_WIDE_INT length = 0;
     501                 :        946 :   HOST_WIDE_INT offset = 0;
     502                 :        946 :   unsigned HOST_WIDE_INT known_align, desired_align;
     503                 :        946 :   bool overlap = false;
     504                 :        946 :   tree tmp, field;
     505                 :        946 :   tree init;
     506                 :        946 :   unsigned char *data, *chk;
     507                 :        946 :   vec<constructor_elt, va_gc> *v = NULL;
     508                 :            : 
     509                 :        946 :   tree type = unsigned_char_type_node;
     510                 :        946 :   int i;
     511                 :            : 
     512                 :            :   /* Obtain the size of the union and check if there are any overlapping
     513                 :            :      initializers.  */
     514                 :       4090 :   for (s = head; s; s = s->next)
     515                 :            :     {
     516                 :       3144 :       HOST_WIDE_INT slen = s->offset + s->length;
     517                 :       3144 :       if (s->sym->value)
     518                 :            :         {
     519                 :        234 :           if (s->offset < offset)
     520                 :         50 :             overlap = true;
     521                 :            :           offset = slen;
     522                 :            :         }
     523                 :       3144 :       length = length < slen ? slen : length;
     524                 :            :     }
     525                 :            : 
     526                 :        946 :   if (!overlap)
     527                 :            :     return NULL_TREE;
     528                 :            : 
     529                 :            :   /* Now absorb all the initializer data into a single vector,
     530                 :            :      whilst checking for overlapping, unequal values.  */
     531                 :         46 :   data = XCNEWVEC (unsigned char, (size_t)length);
     532                 :         46 :   chk = XCNEWVEC (unsigned char, (size_t)length);
     533                 :            : 
     534                 :            :   /* TODO - change this when default initialization is implemented.  */
     535                 :         46 :   memset (data, '\0', (size_t)length);
     536                 :         46 :   memset (chk, '\0', (size_t)length);
     537                 :        156 :   for (s = head; s; s = s->next)
     538                 :        110 :     if (s->sym->value)
     539                 :            :       {
     540                 :         96 :         locus *loc = NULL;
     541                 :         96 :         if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
     542                 :         96 :           loc = &s->sym->ns->equiv->eq->expr->where;
     543                 :         96 :         gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
     544                 :            :                               &data[s->offset],
     545                 :         96 :                               &chk[s->offset],
     546                 :         96 :                              (size_t)s->length);
     547                 :            :       }
     548                 :            :   
     549                 :       1142 :   for (i = 0; i < length; i++)
     550                 :       1096 :     CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
     551                 :            : 
     552                 :         46 :   free (data);
     553                 :         46 :   free (chk);
     554                 :            : 
     555                 :            :   /* Build a char[length] array to hold the initializers.  Much of what
     556                 :            :      follows is borrowed from build_field, above.  */
     557                 :            : 
     558                 :         46 :   tmp = build_int_cst (gfc_array_index_type, length - 1);
     559                 :         46 :   tmp = build_range_type (gfc_array_index_type,
     560                 :            :                           gfc_index_zero_node, tmp);
     561                 :         46 :   tmp = build_array_type (type, tmp);
     562                 :         46 :   field = build_decl (gfc_get_location (&gfc_current_locus),
     563                 :            :                       FIELD_DECL, NULL_TREE, tmp);
     564                 :            : 
     565                 :         46 :   known_align = BIGGEST_ALIGNMENT;
     566                 :            : 
     567                 :         46 :   desired_align = update_alignment_for_field (rli, field, known_align);
     568                 :         46 :   if (desired_align > known_align)
     569                 :          0 :     DECL_PACKED (field) = 1;
     570                 :            : 
     571                 :         46 :   DECL_FIELD_CONTEXT (field) = union_type;
     572                 :         46 :   DECL_FIELD_OFFSET (field) = size_int (0);
     573                 :         46 :   DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
     574                 :         46 :   SET_DECL_OFFSET_ALIGN (field, known_align);
     575                 :            : 
     576                 :         46 :   rli->offset = size_binop (MAX_EXPR, rli->offset,
     577                 :            :                             size_binop (PLUS_EXPR,
     578                 :            :                                         DECL_FIELD_OFFSET (field),
     579                 :            :                                         DECL_SIZE_UNIT (field)));
     580                 :            : 
     581                 :         46 :   init = build_constructor (TREE_TYPE (field), v);
     582                 :         46 :   TREE_CONSTANT (init) = 1;
     583                 :            : 
     584                 :         46 :   *field_init = init;
     585                 :            : 
     586                 :        156 :   for (s = head; s; s = s->next)
     587                 :            :     {
     588                 :        110 :       if (s->sym->value == NULL)
     589                 :         14 :         continue;
     590                 :            : 
     591                 :         96 :       gfc_free_expr (s->sym->value);
     592                 :         96 :       s->sym->value = NULL;
     593                 :            :     }
     594                 :            : 
     595                 :            :   return field;
     596                 :            : }
     597                 :            : 
     598                 :            : 
     599                 :            : /* Declare memory for the common block or local equivalence, and create
     600                 :            :    backend declarations for all of the elements.  */
     601                 :            : 
     602                 :            : static void
     603                 :       2778 : create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
     604                 :            : {
     605                 :       2778 :   segment_info *s, *next_s;
     606                 :       2778 :   tree union_type;
     607                 :       2778 :   tree *field_link;
     608                 :       2778 :   tree field;
     609                 :       2778 :   tree field_init = NULL_TREE;
     610                 :       2778 :   record_layout_info rli;
     611                 :       2778 :   tree decl;
     612                 :       2778 :   bool is_init = false;
     613                 :       2778 :   bool is_saved = false;
     614                 :       2778 :   bool is_auto = false;
     615                 :            : 
     616                 :            :   /* Declare the variables inside the common block.
     617                 :            :      If the current common block contains any equivalence object, then
     618                 :            :      make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
     619                 :            :      alias analyzer work well when there is no address overlapping for
     620                 :            :      common variables in the current common block.  */
     621                 :       2778 :   if (saw_equiv)
     622                 :        946 :     union_type = make_node (UNION_TYPE);
     623                 :            :   else
     624                 :       1832 :     union_type = make_node (RECORD_TYPE);
     625                 :            : 
     626                 :       2778 :   rli = start_record_layout (union_type);
     627                 :       2778 :   field_link = &TYPE_FIELDS (union_type);
     628                 :            : 
     629                 :            :   /* Check for overlapping initializers and replace them with a single,
     630                 :            :      artificial field that contains all the data.  */
     631                 :       2778 :   if (saw_equiv)
     632                 :        946 :     field = get_init_field (head, union_type, &field_init, rli);
     633                 :            :   else
     634                 :            :     field = NULL_TREE;
     635                 :            : 
     636                 :        946 :   if (field != NULL_TREE)
     637                 :            :     {
     638                 :         46 :       is_init = true;
     639                 :         46 :       *field_link = field;
     640                 :         46 :       field_link = &DECL_CHAIN (field);
     641                 :            :     }
     642                 :            : 
     643                 :      10930 :   for (s = head; s; s = s->next)
     644                 :            :     {
     645                 :       8152 :       build_field (s, union_type, rli);
     646                 :            : 
     647                 :            :       /* Link the field into the type.  */
     648                 :       8152 :       *field_link = s->field;
     649                 :       8152 :       field_link = &DECL_CHAIN (s->field);
     650                 :            : 
     651                 :            :       /* Has initial value.  */
     652                 :       8152 :       if (s->sym->value)
     653                 :        247 :         is_init = true;
     654                 :            : 
     655                 :            :       /* Has SAVE attribute.  */
     656                 :       8152 :       if (s->sym->attr.save)
     657                 :        545 :         is_saved = true;
     658                 :            : 
     659                 :            :       /* Has AUTOMATIC attribute.  */
     660                 :       8152 :       if (s->sym->attr.automatic)
     661                 :         14 :         is_auto = true;
     662                 :            :     }
     663                 :            : 
     664                 :       2778 :   finish_record_layout (rli, true);
     665                 :            : 
     666                 :       2778 :   if (com)
     667                 :       2080 :     decl = build_common_decl (com, union_type, is_init);
     668                 :            :   else
     669                 :        698 :     decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);
     670                 :            : 
     671                 :       2778 :   if (is_init)
     672                 :            :     {
     673                 :        242 :       tree ctor, tmp;
     674                 :        242 :       vec<constructor_elt, va_gc> *v = NULL;
     675                 :            : 
     676                 :        242 :       if (field != NULL_TREE && field_init != NULL_TREE)
     677                 :         46 :         CONSTRUCTOR_APPEND_ELT (v, field, field_init);
     678                 :            :       else
     679                 :        602 :         for (s = head; s; s = s->next)
     680                 :            :           {
     681                 :        406 :             if (s->sym->value)
     682                 :            :               {
     683                 :            :                 /* Add the initializer for this field.  */
     684                 :        741 :                 tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
     685                 :        247 :                                             TREE_TYPE (s->field),
     686                 :            :                                             s->sym->attr.dimension,
     687                 :            :                                             s->sym->attr.pointer
     688                 :        247 :                                             || s->sym->attr.allocatable, false);
     689                 :            : 
     690                 :        247 :                 CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
     691                 :            :               }
     692                 :            :           }
     693                 :            : 
     694                 :        242 :       gcc_assert (!v->is_empty ());
     695                 :        242 :       ctor = build_constructor (union_type, v);
     696                 :        242 :       TREE_CONSTANT (ctor) = 1;
     697                 :        242 :       TREE_STATIC (ctor) = 1;
     698                 :        242 :       DECL_INITIAL (decl) = ctor;
     699                 :            : 
     700                 :        242 :       if (flag_checking)
     701                 :            :         {
     702                 :            :           tree field, value;
     703                 :            :           unsigned HOST_WIDE_INT idx;
     704                 :        777 :           FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
     705                 :        293 :             gcc_assert (TREE_CODE (field) == FIELD_DECL);
     706                 :            :         }
     707                 :            :     }
     708                 :            : 
     709                 :            :   /* Build component reference for each variable.  */
     710                 :      10930 :   for (s = head; s; s = next_s)
     711                 :            :     {
     712                 :       8152 :       tree var_decl;
     713                 :            : 
     714                 :       8152 :       var_decl = build_decl (gfc_get_location (&s->sym->declared_at),
     715                 :       8152 :                              VAR_DECL, DECL_NAME (s->field),
     716                 :       8152 :                              TREE_TYPE (s->field));
     717                 :       8152 :       TREE_STATIC (var_decl) = TREE_STATIC (decl);
     718                 :            :       /* Mark the variable as used in order to avoid warnings about
     719                 :            :          unused variables.  */
     720                 :       8152 :       TREE_USED (var_decl) = 1;
     721                 :       8152 :       if (s->sym->attr.use_assoc)
     722                 :        423 :         DECL_IGNORED_P (var_decl) = 1;
     723                 :       8152 :       if (s->sym->attr.target)
     724                 :         66 :         TREE_ADDRESSABLE (var_decl) = 1;
     725                 :            :       /* Fake variables are not visible from other translation units.  */
     726                 :       8152 :       TREE_PUBLIC (var_decl) = 0;
     727                 :       8152 :       gfc_finish_decl_attrs (var_decl, &s->sym->attr);
     728                 :            : 
     729                 :            :       /* To preserve identifier names in COMMON, chain to procedure
     730                 :            :          scope unless at top level in a module definition.  */
     731                 :       8152 :       if (com
     732                 :       6367 :           && s->sym->ns->proc_name
     733                 :       6308 :           && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
     734                 :        447 :         var_decl = pushdecl_top_level (var_decl);
     735                 :            :       else
     736                 :       7705 :         gfc_add_decl_to_function (var_decl);
     737                 :            : 
     738                 :       8152 :       SET_DECL_VALUE_EXPR (var_decl,
     739                 :            :                            fold_build3_loc (input_location, COMPONENT_REF,
     740                 :            :                                             TREE_TYPE (s->field),
     741                 :            :                                             decl, s->field, NULL_TREE));
     742                 :       8152 :       DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
     743                 :       8152 :       GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
     744                 :            : 
     745                 :       8152 :       if (s->sym->attr.assign)
     746                 :            :         {
     747                 :         14 :           gfc_allocate_lang_decl (var_decl);
     748                 :         14 :           GFC_DECL_ASSIGN (var_decl) = 1;
     749                 :         14 :           GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
     750                 :         14 :           GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
     751                 :            :         }
     752                 :            : 
     753                 :       8152 :       s->sym->backend_decl = var_decl;
     754                 :            : 
     755                 :       8152 :       next_s = s->next;
     756                 :       8152 :       free (s);
     757                 :            :     }
     758                 :       2778 : }
     759                 :            : 
     760                 :            : 
     761                 :            : /* Given a symbol, find it in the current segment list. Returns NULL if
     762                 :            :    not found.  */
     763                 :            : 
     764                 :            : static segment_info *
     765                 :       7362 : find_segment_info (gfc_symbol *symbol)
     766                 :            : {
     767                 :       7362 :   segment_info *n;
     768                 :            : 
     769                 :      43378 :   for (n = current_segment; n; n = n->next)
     770                 :            :     {
     771                 :      36025 :       if (n->sym == symbol)
     772                 :          0 :         return n;
     773                 :            :     }
     774                 :            : 
     775                 :            :   return NULL;
     776                 :            : }
     777                 :            : 
     778                 :            : 
     779                 :            : /* Given an expression node, make sure it is a constant integer and return
     780                 :            :    the mpz_t value.  */
     781                 :            : 
     782                 :            : static mpz_t *
     783                 :       6064 : get_mpz (gfc_expr *e)
     784                 :            : {
     785                 :            : 
     786                 :          0 :   if (e->expr_type != EXPR_CONSTANT)
     787                 :          0 :     gfc_internal_error ("get_mpz(): Not an integer constant");
     788                 :            : 
     789                 :       6064 :   return &e->value.integer;
     790                 :            : }
     791                 :            : 
     792                 :            : 
     793                 :            : /* Given an array specification and an array reference, figure out the
     794                 :            :    array element number (zero based). Bounds and elements are guaranteed
     795                 :            :    to be constants.  If something goes wrong we generate an error and
     796                 :            :    return zero.  */
     797                 :            :  
     798                 :            : static HOST_WIDE_INT
     799                 :       1427 : element_number (gfc_array_ref *ar)
     800                 :            : {
     801                 :       1427 :   mpz_t multiplier, offset, extent, n;
     802                 :       1427 :   gfc_array_spec *as;
     803                 :       1427 :   HOST_WIDE_INT i, rank;
     804                 :            : 
     805                 :       1427 :   as = ar->as;
     806                 :       1427 :   rank = as->rank;
     807                 :       1427 :   mpz_init_set_ui (multiplier, 1);
     808                 :       1427 :   mpz_init_set_ui (offset, 0);
     809                 :       1427 :   mpz_init (extent);
     810                 :       1427 :   mpz_init (n);
     811                 :            : 
     812                 :       2859 :   for (i = 0; i < rank; i++)
     813                 :            :     { 
     814                 :       1432 :       if (ar->dimen_type[i] != DIMEN_ELEMENT)
     815                 :          0 :         gfc_internal_error ("element_number(): Bad dimension type");
     816                 :            : 
     817                 :       1432 :       if (as && as->lower[i])
     818                 :       1431 :         mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
     819                 :            :       else
     820                 :          1 :         mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
     821                 :            :  
     822                 :       1432 :       mpz_mul (n, n, multiplier);
     823                 :       1432 :       mpz_add (offset, offset, n);
     824                 :            :  
     825                 :       1432 :       if (as && as->upper[i] && as->lower[i])
     826                 :            :         {
     827                 :       1431 :           mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
     828                 :       1431 :           mpz_add_ui (extent, extent, 1);
     829                 :            :         }
     830                 :            :       else
     831                 :          1 :         mpz_set_ui (extent, 0);
     832                 :            :  
     833                 :       1432 :       if (mpz_sgn (extent) < 0)
     834                 :          0 :         mpz_set_ui (extent, 0);
     835                 :            :  
     836                 :       1432 :       mpz_mul (multiplier, multiplier, extent);
     837                 :            :     } 
     838                 :            :  
     839                 :       1427 :   i = mpz_get_ui (offset);
     840                 :            :  
     841                 :       1427 :   mpz_clear (multiplier);
     842                 :       1427 :   mpz_clear (offset);
     843                 :       1427 :   mpz_clear (extent);
     844                 :       1427 :   mpz_clear (n);
     845                 :            :  
     846                 :       1427 :   return i;
     847                 :            : }
     848                 :            : 
     849                 :            : 
     850                 :            : /* Given a single element of an equivalence list, figure out the offset
     851                 :            :    from the base symbol.  For simple variables or full arrays, this is
     852                 :            :    simply zero.  For an array element we have to calculate the array
     853                 :            :    element number and multiply by the element size. For a substring we
     854                 :            :    have to calculate the further reference.  */
     855                 :            : 
     856                 :            : static HOST_WIDE_INT
     857                 :       3146 : calculate_offset (gfc_expr *e)
     858                 :            : {
     859                 :       3146 :   HOST_WIDE_INT n, element_size, offset;
     860                 :       3146 :   gfc_typespec *element_type;
     861                 :       3146 :   gfc_ref *reference;
     862                 :            : 
     863                 :       3146 :   offset = 0;
     864                 :       3146 :   element_type = &e->symtree->n.sym->ts;
     865                 :            : 
     866                 :       5345 :   for (reference = e->ref; reference; reference = reference->next)
     867                 :       2199 :     switch (reference->type)
     868                 :            :       {
     869                 :       1860 :       case REF_ARRAY:
     870                 :       1860 :         switch (reference->u.ar.type)
     871                 :            :           {
     872                 :            :           case AR_FULL:
     873                 :            :             break;
     874                 :            : 
     875                 :       1427 :           case AR_ELEMENT:
     876                 :       1427 :             n = element_number (&reference->u.ar);
     877                 :       1427 :             if (element_type->type == BT_CHARACTER)
     878                 :        221 :               gfc_conv_const_charlen (element_type->u.cl);
     879                 :       1427 :             element_size =
     880                 :       1427 :               int_size_in_bytes (gfc_typenode_for_spec (element_type));
     881                 :       1427 :             offset += n * element_size;
     882                 :       1427 :             break;
     883                 :            : 
     884                 :          0 :           default:
     885                 :          0 :             gfc_error ("Bad array reference at %L", &e->where);
     886                 :            :           }
     887                 :            :         break;
     888                 :        339 :       case REF_SUBSTRING:
     889                 :        339 :         if (reference->u.ss.start != NULL)
     890                 :        339 :           offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
     891                 :            :         break;
     892                 :          0 :       default:
     893                 :          0 :         gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
     894                 :            :                    &e->where);
     895                 :            :     }
     896                 :       3146 :   return offset;
     897                 :            : }
     898                 :            : 
     899                 :            : 
     900                 :            : /* Add a new segment_info structure to the current segment.  eq1 is already
     901                 :            :    in the list, eq2 is not.  */
     902                 :            : 
     903                 :            : static void
     904                 :       1571 : new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
     905                 :            : {
     906                 :       1571 :   HOST_WIDE_INT offset1, offset2;
     907                 :       1571 :   segment_info *a;
     908                 :            : 
     909                 :       1571 :   offset1 = calculate_offset (eq1->expr);
     910                 :       1571 :   offset2 = calculate_offset (eq2->expr);
     911                 :            : 
     912                 :       3142 :   a = get_segment_info (eq2->expr->symtree->n.sym,
     913                 :       1571 :                         v->offset + offset1 - offset2);
     914                 :            :  
     915                 :       1571 :   current_segment = add_segments (current_segment, a);
     916                 :       1571 : }
     917                 :            : 
     918                 :            : 
     919                 :            : /* Given two equivalence structures that are both already in the list, make
     920                 :            :    sure that this new condition is not violated, generating an error if it
     921                 :            :    is.  */
     922                 :            : 
     923                 :            : static void
     924                 :          2 : confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
     925                 :            :                    gfc_equiv *eq2)
     926                 :            : {
     927                 :          2 :   HOST_WIDE_INT offset1, offset2;
     928                 :            : 
     929                 :          2 :   offset1 = calculate_offset (eq1->expr);
     930                 :          2 :   offset2 = calculate_offset (eq2->expr);
     931                 :            : 
     932                 :          2 :   if (s1->offset + offset1 != s2->offset + offset2)
     933                 :          2 :     gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
     934                 :          2 :                "%qs at %L", s1->sym->name, &s1->sym->declared_at,
     935                 :          2 :                s2->sym->name, &s2->sym->declared_at);
     936                 :          2 : }
     937                 :            : 
     938                 :            : 
     939                 :            : /* Process a new equivalence condition. eq1 is know to be in segment f.
     940                 :            :    If eq2 is also present then confirm that the condition holds.
     941                 :            :    Otherwise add a new variable to the segment list.  */
     942                 :            : 
     943                 :            : static void
     944                 :       1573 : add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
     945                 :            : {
     946                 :       1573 :   segment_info *n;
     947                 :            : 
     948                 :       1573 :   n = find_segment_info (eq2->expr->symtree->n.sym);
     949                 :            : 
     950                 :       1573 :   if (n == NULL)
     951                 :       1571 :     new_condition (f, eq1, eq2);
     952                 :            :   else
     953                 :          2 :     confirm_condition (f, eq1, n, eq2);
     954                 :       1573 : }
     955                 :            : 
     956                 :            : static void
     957                 :      44778 : accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)
     958                 :            : {
     959                 :      44778 :   symbol_attribute attr = e->expr->symtree->n.sym->attr;
     960                 :            : 
     961                 :      44778 :   dummy_symbol->dummy |= attr.dummy;
     962                 :      44778 :   dummy_symbol->pointer |= attr.pointer;
     963                 :      44778 :   dummy_symbol->target |= attr.target;
     964                 :      44778 :   dummy_symbol->external |= attr.external;
     965                 :      44778 :   dummy_symbol->intrinsic |= attr.intrinsic;
     966                 :      44778 :   dummy_symbol->allocatable |= attr.allocatable;
     967                 :      44778 :   dummy_symbol->elemental |= attr.elemental;
     968                 :      44778 :   dummy_symbol->recursive |= attr.recursive;
     969                 :      44778 :   dummy_symbol->in_common |= attr.in_common;
     970                 :      44778 :   dummy_symbol->result |= attr.result;
     971                 :      44778 :   dummy_symbol->in_namelist |= attr.in_namelist;
     972                 :      44778 :   dummy_symbol->optional |= attr.optional;
     973                 :      44778 :   dummy_symbol->entry |= attr.entry;
     974                 :      44778 :   dummy_symbol->function |= attr.function;
     975                 :      44778 :   dummy_symbol->subroutine |= attr.subroutine;
     976                 :      44778 :   dummy_symbol->dimension |= attr.dimension;
     977                 :      44778 :   dummy_symbol->in_equivalence |= attr.in_equivalence;
     978                 :      44778 :   dummy_symbol->use_assoc |= attr.use_assoc;
     979                 :      44778 :   dummy_symbol->cray_pointer |= attr.cray_pointer;
     980                 :      44778 :   dummy_symbol->cray_pointee |= attr.cray_pointee;
     981                 :      44778 :   dummy_symbol->data |= attr.data;
     982                 :      44778 :   dummy_symbol->value |= attr.value;
     983                 :      44778 :   dummy_symbol->volatile_ |= attr.volatile_;
     984                 :      44778 :   dummy_symbol->is_protected |= attr.is_protected;
     985                 :      44778 :   dummy_symbol->is_bind_c |= attr.is_bind_c;
     986                 :      44778 :   dummy_symbol->procedure |= attr.procedure;
     987                 :      44778 :   dummy_symbol->proc_pointer |= attr.proc_pointer;
     988                 :      44778 :   dummy_symbol->abstract |= attr.abstract;
     989                 :      44778 :   dummy_symbol->asynchronous |= attr.asynchronous;
     990                 :      44778 :   dummy_symbol->codimension |= attr.codimension;
     991                 :      44778 :   dummy_symbol->contiguous |= attr.contiguous;
     992                 :      44778 :   dummy_symbol->generic |= attr.generic;
     993                 :      44778 :   dummy_symbol->automatic |= attr.automatic;
     994                 :      44778 :   dummy_symbol->threadprivate |= attr.threadprivate;
     995                 :      44778 :   dummy_symbol->omp_declare_target |= attr.omp_declare_target;
     996                 :      44778 :   dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;
     997                 :      44778 :   dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;
     998                 :      44778 :   dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;
     999                 :      44778 :   dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;
    1000                 :      44778 :   dummy_symbol->oacc_declare_device_resident
    1001                 :      44778 :     |= attr.oacc_declare_device_resident;
    1002                 :            : 
    1003                 :            :   /* Not strictly correct, but probably close enough.  */
    1004                 :      44778 :   if (attr.save > dummy_symbol->save)
    1005                 :        680 :     dummy_symbol->save = attr.save;
    1006                 :      44778 :   if (attr.access > dummy_symbol->access)
    1007                 :          4 :     dummy_symbol->access = attr.access;
    1008                 :      44778 : }
    1009                 :            : 
    1010                 :            : /* Given a segment element, search through the equivalence lists for unused
    1011                 :            :    conditions that involve the symbol.  Add these rules to the segment.  */
    1012                 :            : 
    1013                 :            : static bool
    1014                 :       8140 : find_equivalence (segment_info *n)
    1015                 :            : {
    1016                 :       8140 :   gfc_equiv *e1, *e2, *eq;
    1017                 :       8140 :   bool found;
    1018                 :            : 
    1019                 :       8140 :   found = FALSE;
    1020                 :            : 
    1021                 :      31069 :   for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
    1022                 :            :     {
    1023                 :      22929 :       eq = NULL;
    1024                 :            : 
    1025                 :            :       /* Search the equivalence list, including the root (first) element
    1026                 :            :          for the symbol that owns the segment.  */
    1027                 :      22929 :       symbol_attribute dummy_symbol;
    1028                 :      22929 :       memset (&dummy_symbol, 0, sizeof (dummy_symbol));
    1029                 :      66181 :       for (e2 = e1; e2; e2 = e2->eq)
    1030                 :            :         {
    1031                 :      44778 :           accumulate_equivalence_attributes (&dummy_symbol, e2);
    1032                 :      44778 :           if (!e2->used && e2->expr->symtree->n.sym == n->sym)
    1033                 :            :             {
    1034                 :            :               eq = e2;
    1035                 :            :               break;
    1036                 :            :             }
    1037                 :            :         }
    1038                 :            : 
    1039                 :      22929 :       gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);
    1040                 :            : 
    1041                 :            :       /* Go to the next root element.  */
    1042                 :      22929 :       if (eq == NULL)
    1043                 :      21403 :         continue;
    1044                 :            : 
    1045                 :       1526 :       eq->used = 1;
    1046                 :            : 
    1047                 :            :       /* Now traverse the equivalence list matching the offsets.  */
    1048                 :       4625 :       for (e2 = e1; e2; e2 = e2->eq)
    1049                 :            :         {
    1050                 :       3099 :           if (!e2->used && e2 != eq)
    1051                 :            :             {
    1052                 :       1573 :               add_condition (n, eq, e2);
    1053                 :       1573 :               e2->used = 1;
    1054                 :       1573 :               found = TRUE;
    1055                 :            :             }
    1056                 :            :         }
    1057                 :            :     }
    1058                 :       8140 :   return found;
    1059                 :            : }
    1060                 :            : 
    1061                 :            : 
    1062                 :            : /* Add all symbols equivalenced within a segment.  We need to scan the
    1063                 :            :    segment list multiple times to include indirect equivalences.  Since
    1064                 :            :    a new segment_info can inserted at the beginning of the segment list,
    1065                 :            :    depending on its offset, we have to force a final pass through the
    1066                 :            :    loop by demanding that completion sees a pass with no matches; i.e.,
    1067                 :            :    all symbols with equiv_built set and no new equivalences found.  */
    1068                 :            : 
    1069                 :            : static void
    1070                 :       6581 : add_equivalences (bool *saw_equiv)
    1071                 :            : {
    1072                 :       6581 :   segment_info *f;
    1073                 :       6581 :   bool more = TRUE;
    1074                 :            : 
    1075                 :      14328 :   while (more)
    1076                 :            :     {
    1077                 :       7747 :       more = FALSE;
    1078                 :      17784 :       for (f = current_segment; f; f = f->next)
    1079                 :            :         {
    1080                 :      10037 :           if (!f->sym->equiv_built)
    1081                 :            :             {
    1082                 :       8140 :               f->sym->equiv_built = 1;
    1083                 :       8140 :               bool seen_one = find_equivalence (f);
    1084                 :       8140 :               if (seen_one)
    1085                 :            :                 {
    1086                 :       1173 :                   *saw_equiv = true;
    1087                 :       1173 :                   more = true;
    1088                 :            :                 }
    1089                 :            :             }
    1090                 :            :         }
    1091                 :            :     }
    1092                 :            : 
    1093                 :            :   /* Add a copy of this segment list to the namespace.  */
    1094                 :       6581 :   copy_equiv_list_to_ns (current_segment);
    1095                 :       6581 : }
    1096                 :            : 
    1097                 :            : 
    1098                 :            : /* Returns the offset necessary to properly align the current equivalence.
    1099                 :            :    Sets *palign to the required alignment.  */
    1100                 :            : 
    1101                 :            : static HOST_WIDE_INT
    1102                 :       6563 : align_segment (unsigned HOST_WIDE_INT *palign)
    1103                 :            : {
    1104                 :       6563 :   segment_info *s;
    1105                 :       6563 :   unsigned HOST_WIDE_INT offset;
    1106                 :       6563 :   unsigned HOST_WIDE_INT max_align;
    1107                 :       6563 :   unsigned HOST_WIDE_INT this_align;
    1108                 :       6563 :   unsigned HOST_WIDE_INT this_offset;
    1109                 :            : 
    1110                 :       6563 :   max_align = 1;
    1111                 :       6563 :   offset = 0;
    1112                 :      14697 :   for (s = current_segment; s; s = s->next)
    1113                 :            :     {
    1114                 :       8134 :       this_align = TYPE_ALIGN_UNIT (s->field);
    1115                 :       8134 :       if (s->offset & (this_align - 1))
    1116                 :            :         {
    1117                 :            :           /* Field is misaligned.  */
    1118                 :        128 :           this_offset = this_align - ((s->offset + offset) & (this_align - 1));
    1119                 :        128 :           if (this_offset & (max_align - 1))
    1120                 :            :             {
    1121                 :            :               /* Aligning this field would misalign a previous field.  */
    1122                 :          0 :               gfc_error ("The equivalence set for variable %qs "
    1123                 :            :                          "declared at %L violates alignment requirements",
    1124                 :          0 :                          s->sym->name, &s->sym->declared_at);
    1125                 :            :             }
    1126                 :        128 :           offset += this_offset;
    1127                 :            :         }
    1128                 :       8134 :       max_align = this_align;
    1129                 :            :     }
    1130                 :       6563 :   if (palign)
    1131                 :       6563 :     *palign = max_align;
    1132                 :       6563 :   return offset;
    1133                 :            : }
    1134                 :            : 
    1135                 :            : 
    1136                 :            : /* Adjust segment offsets by the given amount.  */
    1137                 :            : 
    1138                 :            : static void
    1139                 :          0 : apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
    1140                 :            : {
    1141                 :      14733 :   for (; s; s = s->next)
    1142                 :       8152 :     s->offset += offset;
    1143                 :          0 : }
    1144                 :            : 
    1145                 :            : 
    1146                 :            : /* Lay out a symbol in a common block.  If the symbol has already been seen
    1147                 :            :    then check the location is consistent.  Otherwise create segments
    1148                 :            :    for that symbol and all the symbols equivalenced with it.  */
    1149                 :            : 
    1150                 :            : /* Translate a single common block.  */
    1151                 :            : 
    1152                 :            : static void
    1153                 :       1979 : translate_common (gfc_common_head *common, gfc_symbol *var_list)
    1154                 :            : {
    1155                 :       1979 :   gfc_symbol *sym;
    1156                 :       1979 :   segment_info *s;
    1157                 :       1979 :   segment_info *common_segment;
    1158                 :       1979 :   HOST_WIDE_INT offset;
    1159                 :       1979 :   HOST_WIDE_INT current_offset;
    1160                 :       1979 :   unsigned HOST_WIDE_INT align;
    1161                 :       1979 :   bool saw_equiv;
    1162                 :            : 
    1163                 :       1979 :   common_segment = NULL;
    1164                 :       1979 :   offset = 0;
    1165                 :       1979 :   current_offset = 0;
    1166                 :       1979 :   align = 1;
    1167                 :       1979 :   saw_equiv = false;
    1168                 :            : 
    1169                 :            :   /* Add symbols to the segment.  */
    1170                 :       7768 :   for (sym = var_list; sym; sym = sym->common_next)
    1171                 :            :     {
    1172                 :       5789 :       current_segment = common_segment;
    1173                 :       5789 :       s = find_segment_info (sym);
    1174                 :            : 
    1175                 :            :       /* Symbol has already been added via an equivalence.  Multiple
    1176                 :            :          use associations of the same common block result in equiv_built
    1177                 :            :          being set but no information about the symbol in the segment.  */
    1178                 :       5789 :       if (s && sym->equiv_built)
    1179                 :            :         {
    1180                 :            :           /* Ensure the current location is properly aligned.  */
    1181                 :          7 :           align = TYPE_ALIGN_UNIT (s->field);
    1182                 :          7 :           current_offset = (current_offset + align - 1) &~ (align - 1);
    1183                 :            : 
    1184                 :            :           /* Verify that it ended up where we expect it.  */
    1185                 :          7 :           if (s->offset != current_offset)
    1186                 :            :             {
    1187                 :          1 :               gfc_error ("Equivalence for %qs does not match ordering of "
    1188                 :            :                          "COMMON %qs at %L", sym->name,
    1189                 :          1 :                          common->name, &common->where);
    1190                 :            :             }
    1191                 :            :         }
    1192                 :            :       else
    1193                 :            :         {
    1194                 :            :           /* A symbol we haven't seen before.  */
    1195                 :       5782 :           s = current_segment = get_segment_info (sym, current_offset);
    1196                 :            : 
    1197                 :            :           /* Add all objects directly or indirectly equivalenced with this
    1198                 :            :              symbol.  */
    1199                 :       5782 :           add_equivalences (&saw_equiv);
    1200                 :            : 
    1201                 :       5782 :           if (current_segment->offset < 0)
    1202                 :          0 :             gfc_error ("The equivalence set for %qs cause an invalid "
    1203                 :            :                        "extension to COMMON %qs at %L", sym->name,
    1204                 :          0 :                        common->name, &common->where);
    1205                 :            : 
    1206                 :       5782 :           if (flag_align_commons)
    1207                 :       5764 :             offset = align_segment (&align);
    1208                 :            : 
    1209                 :       5782 :           if (offset)
    1210                 :            :             {
    1211                 :            :               /* The required offset conflicts with previous alignment
    1212                 :            :                  requirements.  Insert padding immediately before this
    1213                 :            :                  segment.  */
    1214                 :         37 :               if (warn_align_commons)
    1215                 :            :                 {
    1216                 :         35 :                   if (strcmp (common->name, BLANK_COMMON_NAME))
    1217                 :         23 :                     gfc_warning (OPT_Walign_commons,
    1218                 :            :                                  "Padding of %d bytes required before %qs in "
    1219                 :            :                                  "COMMON %qs at %L; reorder elements or use "
    1220                 :            :                                  "%<-fno-align-commons%>", (int)offset,
    1221                 :         23 :                                  s->sym->name, common->name, &common->where);
    1222                 :            :                   else
    1223                 :         12 :                     gfc_warning (OPT_Walign_commons,
    1224                 :            :                                  "Padding of %d bytes required before %qs in "
    1225                 :            :                                  "COMMON at %L; reorder elements or use "
    1226                 :            :                                  "%<-fno-align-commons%>", (int)offset,
    1227                 :         12 :                                  s->sym->name, &common->where);
    1228                 :            :                 }
    1229                 :            :             }
    1230                 :            : 
    1231                 :            :           /* Apply the offset to the new segments.  */
    1232                 :       5782 :           apply_segment_offset (current_segment, offset);
    1233                 :       5782 :           current_offset += offset;
    1234                 :            : 
    1235                 :            :           /* Add the new segments to the common block.  */
    1236                 :       5782 :           common_segment = add_segments (common_segment, current_segment);
    1237                 :            :         }
    1238                 :            : 
    1239                 :            :       /* The offset of the next common variable.  */
    1240                 :       5789 :       current_offset += s->length;
    1241                 :            :     }
    1242                 :            : 
    1243                 :       1979 :   if (common_segment == NULL)
    1244                 :            :     {
    1245                 :          0 :       gfc_error ("COMMON %qs at %L does not exist",
    1246                 :          0 :                  common->name, &common->where);
    1247                 :          0 :       return;
    1248                 :            :     }
    1249                 :            : 
    1250                 :       1979 :   if (common_segment->offset != 0 && warn_align_commons)
    1251                 :            :     {
    1252                 :          0 :       if (strcmp (common->name, BLANK_COMMON_NAME))
    1253                 :          0 :         gfc_warning (OPT_Walign_commons,
    1254                 :            :                      "COMMON %qs at %L requires %d bytes of padding; "
    1255                 :            :                      "reorder elements or use %<-fno-align-commons%>",
    1256                 :            :                      common->name, &common->where, (int)common_segment->offset);
    1257                 :            :       else
    1258                 :          0 :         gfc_warning (OPT_Walign_commons,
    1259                 :            :                      "COMMON at %L requires %d bytes of padding; "
    1260                 :            :                      "reorder elements or use %<-fno-align-commons%>",
    1261                 :            :                      &common->where, (int)common_segment->offset);
    1262                 :            :     }
    1263                 :            : 
    1264                 :       1979 :   create_common (common, common_segment, saw_equiv);
    1265                 :            : }
    1266                 :            : 
    1267                 :            : 
    1268                 :            : /* Create a new block for each merged equivalence list.  */
    1269                 :            : 
    1270                 :            : static void
    1271                 :      64591 : finish_equivalences (gfc_namespace *ns)
    1272                 :            : {
    1273                 :      64591 :   gfc_equiv *z, *y;
    1274                 :      64591 :   gfc_symbol *sym;
    1275                 :      64591 :   gfc_common_head * c;
    1276                 :      64591 :   HOST_WIDE_INT offset;
    1277                 :      64591 :   unsigned HOST_WIDE_INT align;
    1278                 :      64591 :   bool dummy;
    1279                 :            : 
    1280                 :      66117 :   for (z = ns->equiv; z; z = z->next)
    1281                 :       2283 :     for (y = z->eq; y; y = y->eq)
    1282                 :            :       {
    1283                 :       1556 :         if (y->used) 
    1284                 :        757 :           continue;
    1285                 :        799 :         sym = z->expr->symtree->n.sym;
    1286                 :        799 :         current_segment = get_segment_info (sym, 0);
    1287                 :            : 
    1288                 :            :         /* All objects directly or indirectly equivalenced with this
    1289                 :            :            symbol.  */
    1290                 :        799 :         add_equivalences (&dummy);
    1291                 :            : 
    1292                 :            :         /* Align the block.  */
    1293                 :        799 :         offset = align_segment (&align);
    1294                 :            : 
    1295                 :            :         /* Ensure all offsets are positive.  */
    1296                 :        799 :         offset -= current_segment->offset & ~(align - 1);
    1297                 :            : 
    1298                 :        799 :         apply_segment_offset (current_segment, offset);
    1299                 :            : 
    1300                 :            :         /* Create the decl.  If this is a module equivalence, it has a
    1301                 :            :            unique name, pointed to by z->module.  This is written to a
    1302                 :            :            gfc_common_header to push create_common into using
    1303                 :            :            build_common_decl, so that the equivalence appears as an
    1304                 :            :            external symbol.  Otherwise, a local declaration is built using
    1305                 :            :            build_equiv_decl.  */
    1306                 :        799 :         if (z->module)
    1307                 :            :           {
    1308                 :        101 :             c = gfc_get_common_head ();
    1309                 :            :             /* We've lost the real location, so use the location of the
    1310                 :            :                enclosing procedure.  If we're in a BLOCK DATA block, then
    1311                 :            :                use the location in the sym_root.  */
    1312                 :        101 :             if (ns->proc_name)
    1313                 :        100 :               c->where = ns->proc_name->declared_at;
    1314                 :          1 :             else if (ns->is_block_data)
    1315                 :          1 :               c->where = ns->sym_root->n.sym->declared_at;
    1316                 :        101 :             strcpy (c->name, z->module);
    1317                 :            :           }
    1318                 :            :         else
    1319                 :            :           c = NULL;
    1320                 :            : 
    1321                 :        799 :         create_common (c, current_segment, true);
    1322                 :        799 :         break;
    1323                 :            :       }
    1324                 :      64591 : }
    1325                 :            : 
    1326                 :            : 
    1327                 :            : /* Work function for translating a named common block.  */
    1328                 :            : 
    1329                 :            : static void
    1330                 :       1761 : named_common (gfc_symtree *st)
    1331                 :            : {
    1332                 :       1761 :   translate_common (st->n.common, st->n.common->head);
    1333                 :       1761 : }
    1334                 :            : 
    1335                 :            : 
    1336                 :            : /* Translate the common blocks in a namespace. Unlike other variables,
    1337                 :            :    these have to be created before code, because the backend_decl depends
    1338                 :            :    on the rest of the common block.  */
    1339                 :            : 
    1340                 :            : void
    1341                 :      64591 : gfc_trans_common (gfc_namespace *ns)
    1342                 :            : {
    1343                 :      64591 :   gfc_common_head *c;
    1344                 :            : 
    1345                 :            :   /* Translate the blank common block.  */
    1346                 :      64591 :   if (ns->blank_common.head != NULL)
    1347                 :            :     {
    1348                 :        218 :       c = gfc_get_common_head ();
    1349                 :        218 :       c->where = ns->blank_common.head->common_head->where;
    1350                 :        218 :       strcpy (c->name, BLANK_COMMON_NAME);
    1351                 :        218 :       translate_common (c, ns->blank_common.head);
    1352                 :            :     }
    1353                 :            : 
    1354                 :            :   /* Translate all named common blocks.  */
    1355                 :      64591 :   gfc_traverse_symtree (ns->common_root, named_common);
    1356                 :            : 
    1357                 :            :   /* Translate local equivalence.  */
    1358                 :      64591 :   finish_equivalences (ns);
    1359                 :            : 
    1360                 :            :   /* Commit the newly created symbols for common blocks and module
    1361                 :            :      equivalences.  */
    1362                 :      64591 :   gfc_commit_symbols ();
    1363                 :      64591 : }

Generated by: LCOV version 1.0

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto --enable-host-shared. GCC test suite is run with the built compiler.