]> git.ipfire.org Git - thirdparty/gcc.git/blobdiff - gcc/fortran/trans-common.c
Update copyright years.
[thirdparty/gcc.git] / gcc / fortran / trans-common.c
index 572fcb23f5927b6d4fcdffa0c920da69475f8034..bf163bc4f52e7fec22d49804ed9fbbb5634ba8b0 100644 (file)
@@ -1,5 +1,5 @@
 /* Common block and equivalence list handling
-   Copyright (C) 2000-2015 Free Software Foundation, Inc.
+   Copyright (C) 2000-2020 Free Software Foundation, Inc.
    Contributed by Canqun Yang <canqun@nudt.edu.cn>
 
 This file is part of GCC.
@@ -92,20 +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 "alias.h"
-#include "symtab.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"
@@ -284,7 +282,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli)
   unsigned HOST_WIDE_INT desired_align, known_align;
 
   name = get_identifier (h->sym->name);
-  field = build_decl (h->sym->declared_at.lb->location,
+  field = build_decl (gfc_get_location (&h->sym->declared_at),
                      FIELD_DECL, name, h->field);
   known_align = (offset & -offset) * BITS_PER_UNIT;
   if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
@@ -341,10 +339,10 @@ build_field (segment_info *h, tree union_type, record_layout_info rli)
 /* Get storage for local equivalence.  */
 
 static tree
-build_equiv_decl (tree union_type, bool is_init, bool is_saved)
+build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)
 {
   tree decl;
-  char name[15];
+  char name[18];
   static int serial = 0;
 
   if (is_init)
@@ -361,8 +359,8 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved)
   DECL_ARTIFICIAL (decl) = 1;
   DECL_IGNORED_P (decl) = 1;
 
-  if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
-      || is_saved)
+  if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
+      || is_saved))
     TREE_STATIC (decl) = 1;
 
   TREE_ADDRESSABLE (decl) = 1;
@@ -410,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);
        }
@@ -438,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
@@ -449,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;
@@ -459,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));
@@ -534,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]));
@@ -552,7 +559,7 @@ get_init_field (segment_info *head, tree union_type, tree *field_init,
   tmp = build_range_type (gfc_array_index_type,
                          gfc_index_zero_node, tmp);
   tmp = build_array_type (type, tmp);
-  field = build_decl (gfc_current_locus.lb->location,
+  field = build_decl (gfc_get_location (&gfc_current_locus),
                      FIELD_DECL, NULL_TREE, tmp);
 
   known_align = BIGGEST_ALIGNMENT;
@@ -604,6 +611,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
   tree decl;
   bool is_init = false;
   bool is_saved = false;
+  bool is_auto = false;
 
   /* Declare the variables inside the common block.
      If the current common block contains any equivalence object, then
@@ -647,6 +655,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
       /* Has SAVE attribute.  */
       if (s->sym->attr.save)
         is_saved = true;
+
+      /* Has AUTOMATIC attribute.  */
+      if (s->sym->attr.automatic)
+       is_auto = true;
     }
 
   finish_record_layout (rli, true);
@@ -654,7 +666,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
   if (com)
     decl = build_common_decl (com, union_type, is_init);
   else
-    decl = build_equiv_decl (union_type, is_init, is_saved);
+    decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);
 
   if (is_init)
     {
@@ -685,14 +697,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.  */
@@ -700,7 +711,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
     {
       tree var_decl;
 
-      var_decl = build_decl (s->sym->declared_at.lb->location,
+      var_decl = build_decl (gfc_get_location (&s->sym->declared_at),
                             VAR_DECL, DECL_NAME (s->field),
                             TREE_TYPE (s->field));
       TREE_STATIC (var_decl) = TREE_STATIC (decl);
@@ -803,13 +814,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);
@@ -934,6 +953,59 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
     confirm_condition (f, eq1, n, eq2);
 }
 
+static void
+accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)
+{
+  symbol_attribute attr = e->expr->symtree->n.sym->attr;
+
+  dummy_symbol->dummy |= attr.dummy;
+  dummy_symbol->pointer |= attr.pointer;
+  dummy_symbol->target |= attr.target;
+  dummy_symbol->external |= attr.external;
+  dummy_symbol->intrinsic |= attr.intrinsic;
+  dummy_symbol->allocatable |= attr.allocatable;
+  dummy_symbol->elemental |= attr.elemental;
+  dummy_symbol->recursive |= attr.recursive;
+  dummy_symbol->in_common |= attr.in_common;
+  dummy_symbol->result |= attr.result;
+  dummy_symbol->in_namelist |= attr.in_namelist;
+  dummy_symbol->optional |= attr.optional;
+  dummy_symbol->entry |= attr.entry;
+  dummy_symbol->function |= attr.function;
+  dummy_symbol->subroutine |= attr.subroutine;
+  dummy_symbol->dimension |= attr.dimension;
+  dummy_symbol->in_equivalence |= attr.in_equivalence;
+  dummy_symbol->use_assoc |= attr.use_assoc;
+  dummy_symbol->cray_pointer |= attr.cray_pointer;
+  dummy_symbol->cray_pointee |= attr.cray_pointee;
+  dummy_symbol->data |= attr.data;
+  dummy_symbol->value |= attr.value;
+  dummy_symbol->volatile_ |= attr.volatile_;
+  dummy_symbol->is_protected |= attr.is_protected;
+  dummy_symbol->is_bind_c |= attr.is_bind_c;
+  dummy_symbol->procedure |= attr.procedure;
+  dummy_symbol->proc_pointer |= attr.proc_pointer;
+  dummy_symbol->abstract |= attr.abstract;
+  dummy_symbol->asynchronous |= attr.asynchronous;
+  dummy_symbol->codimension |= attr.codimension;
+  dummy_symbol->contiguous |= attr.contiguous;
+  dummy_symbol->generic |= attr.generic;
+  dummy_symbol->automatic |= attr.automatic;
+  dummy_symbol->threadprivate |= attr.threadprivate;
+  dummy_symbol->omp_declare_target |= attr.omp_declare_target;
+  dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;
+  dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;
+  dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;
+  dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;
+  dummy_symbol->oacc_declare_device_resident
+    |= attr.oacc_declare_device_resident;
+
+  /* Not strictly correct, but probably close enough.  */
+  if (attr.save > dummy_symbol->save)
+    dummy_symbol->save = attr.save;
+  if (attr.access > dummy_symbol->access)
+    dummy_symbol->access = attr.access;
+}
 
 /* Given a segment element, search through the equivalence lists for unused
    conditions that involve the symbol.  Add these rules to the segment.  */
@@ -951,9 +1023,12 @@ find_equivalence (segment_info *n)
       eq = NULL;
 
       /* Search the equivalence list, including the root (first) element
-         for the symbol that owns the segment.  */
+        for the symbol that owns the segment.  */
+      symbol_attribute dummy_symbol;
+      memset (&dummy_symbol, 0, sizeof (dummy_symbol));
       for (e2 = e1; e2; e2 = e2->eq)
        {
+         accumulate_equivalence_attributes (&dummy_symbol, e2);
          if (!e2->used && e2->expr->symtree->n.sym == n->sym)
            {
              eq = e2;
@@ -961,6 +1036,8 @@ find_equivalence (segment_info *n)
            }
        }
 
+      gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);
+
       /* Go to the next root element.  */
       if (eq == NULL)
        continue;
@@ -993,10 +1070,8 @@ static void
 add_equivalences (bool *saw_equiv)
 {
   segment_info *f;
-  bool seen_one, more;
+  bool more = TRUE;
 
-  seen_one = false;
-  more = TRUE;
   while (more)
     {
       more = FALSE;
@@ -1005,7 +1080,7 @@ add_equivalences (bool *saw_equiv)
          if (!f->sym->equiv_built)
            {
              f->sym->equiv_built = 1;
-             seen_one = find_equivalence (f);
+             bool seen_one = find_equivalence (f);
              if (seen_one)
                {
                  *saw_equiv = true;
@@ -1139,16 +1214,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);
                }
            }
@@ -1167,7 +1242,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;
     }
@@ -1232,8 +1307,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