Wrap option names in gcc internal messages with %< and %>.

[thirdparty/gcc.git] / gcc / fortran / trans-common.c

diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index ca01b0bf9a058a6d869238d38dbac306b658c288..debdbd98ac0820b927d2d4a43df4de88a25b4d1f 100644 (file)
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -1,5 +1,5 @@
 /* Common block and equivalence list handling
-   Copyright (C) 2000-2015 Free Software Foundation, Inc.
+   Copyright (C) 2000-2019 Free Software Foundation, Inc.
    Contributed by Canqun Yang <canqun@nudt.edu.cn>
 
 This file is part of GCC.
@@ -92,24 +92,18 @@ along with GCC; see the file COPYING3.  If not see
    is examined for still-unused equivalence conditions.  We create a
    block for each merged equivalence list.  */
 
-#include <map>
 #include "config.h"
+#define INCLUDE_MAP
 #include "system.h"
 #include "coretypes.h"
 #include "tm.h"
-#include "hash-set.h"
-#include "vec.h"
-#include "input.h"
-#include "alias.h"
-#include "symtab.h"
-#include "inchash.h"
 #include "tree.h"
-#include "fold-const.h"
+#include "gfortran.h"
+#include "trans.h"
 #include "stringpool.h"
+#include "fold-const.h"
 #include "stor-layout.h"
 #include "varasm.h"
-#include "gfortran.h"
-#include "trans.h"
 #include "trans-types.h"
 #include "trans-const.h"
 #include "target-memory.h"
@@ -348,7 +342,7 @@ static tree
 build_equiv_decl (tree union_type, bool is_init, bool is_saved)
 {
   tree decl;
-  char name[15];
+  char name[18];
   static int serial = 0;
 
   if (is_init)
@@ -414,7 +408,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
        {
          DECL_SIZE (decl) = TYPE_SIZE (union_type);
          DECL_SIZE_UNIT (decl) = size;
-         DECL_MODE (decl) = TYPE_MODE (union_type);
+         SET_DECL_MODE (decl, TYPE_MODE (union_type));
          TREE_TYPE (decl) = union_type;
          layout_decl (decl, 0);
        }
@@ -442,7 +436,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
       TREE_STATIC (decl) = 1;
       DECL_IGNORED_P (decl) = 1;
       if (!com->is_bind_c)
-       DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
+       SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
       else
         {
          /* Do not set the alignment for bind(c) common blocks to
@@ -453,7 +447,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
          tree field = NULL_TREE;
          field = TYPE_FIELDS (TREE_TYPE (decl));
          if (DECL_CHAIN (field) == NULL_TREE)
-           DECL_ALIGN (decl) = TYPE_ALIGN (TREE_TYPE (field));
+           SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
        }
       DECL_USER_ALIGN (decl) = 0;
       GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
@@ -463,7 +457,11 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
       if (com->threadprivate)
        set_decl_tls_model (decl, decl_default_tls_model (decl));
 
-      if (com->omp_declare_target)
+      if (com->omp_declare_target_link)
+       DECL_ATTRIBUTES (decl)
+         = tree_cons (get_identifier ("omp declare target link"),
+                      NULL_TREE, DECL_ATTRIBUTES (decl));
+      else if (com->omp_declare_target)
        DECL_ATTRIBUTES (decl)
          = tree_cons (get_identifier ("omp declare target"),
                       NULL_TREE, DECL_ATTRIBUTES (decl));
@@ -538,10 +536,15 @@ get_init_field (segment_info *head, tree union_type, tree *field_init,
   memset (chk, '\0', (size_t)length);
   for (s = head; s; s = s->next)
     if (s->sym->value)
-      gfc_merge_initializers (s->sym->ts, s->sym->value,
+      {
+       locus *loc = NULL;
+       if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
+         loc = &s->sym->ns->equiv->eq->expr->where;
+       gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
                              &data[s->offset],
                              &chk[s->offset],
                             (size_t)s->length);
+      }
   
   for (i = 0; i < length; i++)
     CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
@@ -689,14 +692,13 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
       TREE_STATIC (ctor) = 1;
       DECL_INITIAL (decl) = ctor;
 
-#ifdef ENABLE_CHECKING
-      {
-       tree field, value;
-       unsigned HOST_WIDE_INT idx;
-       FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
-         gcc_assert (TREE_CODE (field) == FIELD_DECL);
-      }
-#endif
+      if (flag_checking)
+       {
+         tree field, value;
+         unsigned HOST_WIDE_INT idx;
+         FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
+           gcc_assert (TREE_CODE (field) == FIELD_DECL);
+       }
     }
 
   /* Build component reference for each variable.  */
@@ -807,13 +809,21 @@ element_number (gfc_array_ref *ar)
       if (ar->dimen_type[i] != DIMEN_ELEMENT)
         gfc_internal_error ("element_number(): Bad dimension type");
 
-      mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+      if (as && as->lower[i])
+       mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
+      else
+       mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
  
       mpz_mul (n, n, multiplier);
       mpz_add (offset, offset, n);
  
-      mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
-      mpz_add_ui (extent, extent, 1);
+      if (as && as->upper[i] && as->lower[i])
+       {
+         mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
+         mpz_add_ui (extent, extent, 1);
+       }
+      else
+       mpz_set_ui (extent, 0);
  
       if (mpz_sgn (extent) < 0)
         mpz_set_ui (extent, 0);
@@ -1143,16 +1153,16 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
              if (warn_align_commons)
                {
                  if (strcmp (common->name, BLANK_COMMON_NAME))
-                   gfc_warning (0,
+                   gfc_warning (OPT_Walign_commons,
                                 "Padding of %d bytes required before %qs in "
                                 "COMMON %qs at %L; reorder elements or use "
-                                "-fno-align-commons", (int)offset,
+                                "%<-fno-align-commons%>", (int)offset,
                                 s->sym->name, common->name, &common->where);
                  else
-                   gfc_warning (0,
+                   gfc_warning (OPT_Walign_commons,
                                 "Padding of %d bytes required before %qs in "
                                 "COMMON at %L; reorder elements or use "
-                                "-fno-align-commons", (int)offset,
+                                "%<-fno-align-commons%>", (int)offset,
                                 s->sym->name, &common->where);
                }
            }
@@ -1171,7 +1181,7 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
 
   if (common_segment == NULL)
     {
-      gfc_error ("COMMON '%s' at %L does not exist",
+      gfc_error ("COMMON %qs at %L does not exist",
                 common->name, &common->where);
       return;
     }
@@ -1236,8 +1246,12 @@ finish_equivalences (gfc_namespace *ns)
          {
            c = gfc_get_common_head ();
            /* We've lost the real location, so use the location of the
-              enclosing procedure.  */
-           c->where = ns->proc_name->declared_at;
+              enclosing procedure.  If we're in a BLOCK DATA block, then
+              use the location in the sym_root.  */
+           if (ns->proc_name)
+             c->where = ns->proc_name->declared_at;
+           else if (ns->is_block_data)
+             c->where = ns->sym_root->n.sym->declared_at;
            strcpy (c->name, z->module);
          }
        else